Und tatsächlich gibt es bereits eine Haskell Version. Hundertprozentig ist die Funktionsweise von der Monad für mich noch nicht klar, aber soweit ich es beurteilen kann ist die Transaktion ein Hybrid aus der Continuation und der State Monad.
Erstmal ein paar Tests:
open TransactionM
// 5 ways you can leave the monad.
// handle : transaction handle.
let test0 handle =
transaction {
let! s = get
do! set 99
match s with
| 0 -> return id
| 1 -> return! abort handle (Some s)
| 2 -> return! dirty handle (Some s.)
| 3 -> return! rollback handle "rollback!"
| _ -> return! commit handle "commit"
}
// return TransactionState<int,string> * int. second item is result of transaction.
let runTest0 =
let run = runTransaction_ (beginT test0)
List.map run [0..4]val test0 :
TransactionM.TransactionHandle<'a,int,
TransactionM.TransactionState<int,string>> ->
TransactionM.TransactionM<'a,int,('b -> 'b)>
val runTest0 : (TransactionM.TransactionState<int,string> * int) list =
[ (Abort null, 0);
(Abort (Some 1), 1);
(Dirty (Some 2), 99);
(Rollback "rollback!", 3);
(Commit "commit", 99) ]Einfache Listenmanipulation als eine Transaktion.
// Simple list manipulation as transaction.
// p : some condition
// l : init list
// handle : transaction handle.
let testList p l handle = transaction {
do! set l
do! modify (fun xs-> 6::xs)
do! modify (fun xs-> 7::xs)
match p with
| false -> return! rollback handle "rollback!"
| true -> return! commit handle "commit."
}
// Only if both transactions are successful then concatenate the two lists and commit all transactions.
// rollback otherwise.
// m1, m2 - transactions.
// handle : transaction handle.
let merge m1 m2 handle =
transaction {
let! state1 = m1
match state1 with
| Commit a ->
let! firstList = get
printfn " first list: %A" firstList
let! state2 = m2
match state2 with
| Commit b ->
let! secondList = get
printfn " second list: %A" secondList
do! set (firstList @ secondList)
return! commit handle b
| Rollback b -> return! rollback handle b
| _ -> return! abort handle (Some "abort")
| Rollback a -> return! rollback handle a
| _ -> return! abort handle (Some "abort")
}
//return TransactionState<string,'b> * 'c list. second item is result of transaction.
let runMerge i m1 m2 =
printfn "Start runMerge %A." i
let m = beginT (merge m1 m2)
runTransaction_ m []
// ls : list of list.
// return TransactionState<string,string> * int list. second item is result of transaction.
let runList ls =
printfn "Start runList."
let m = List.fold (fun acc (l, p) -> beginT (merge acc (beginT (testList p l)))) (alwaysCommit "commit") ls
runTransaction_ m []
printfn "runMerge 1: %A " (runMerge 1 (beginT (testList true [0..3] )) (beginT (testList true [10..13])))
printfn "runMerge 2: %A " (runMerge 2 (beginT (testList false [0..3] )) (beginT (testList true [10..13])))
printfn "%A" (runList [([0..3], true); ([10..13], true); ([20..23], true)])
printfn "%A" (runList [([0..3], true); ([10..13], true); ([20..23], false)])val testList :
bool ->
int list ->
TransactionM.TransactionHandle<'a,int list,
TransactionM.TransactionState<'b,string>> ->
TransactionM.TransactionM<'a,int list,('c -> 'c)>
val merge :
TransactionM.TransactionM<'a,'b list,TransactionM.TransactionState<'c,'d>> ->
TransactionM.TransactionM<'a,'b list,TransactionM.TransactionState<'e,'d>> ->
TransactionM.TransactionHandle<'a,'b list,
TransactionM.TransactionState<string,'d>> ->
TransactionM.TransactionM<'a,'b list,('f -> 'f)>
val runMerge :
'a ->
TransactionM.TransactionM<(TransactionM.TransactionState<string,'b> *
'c list),'c list,
TransactionM.TransactionState<'d,'b>> ->
TransactionM.TransactionM<(TransactionM.TransactionState<string,'b> *
'c list),'c list,
TransactionM.TransactionState<'e,'b>> ->
TransactionM.TransactionState<string,'b> * 'c list
val runList :
(int list * bool) list ->
TransactionM.TransactionState<string,string> * int list
Start runMerge 1.
first list: [7; 6; 0; 1; 2; 3]
second list: [7; 6; 10; 11; 12; 13]
runMerge 1: (Commit "commit.", [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13])
Start runMerge 2.
runMerge 2: (Rollback "rollback!", [])
Start runList.
first list: []
second list: [7; 6; 0; 1; 2; 3]
first list: [7; 6; 0; 1; 2; 3]
second list: [7; 6; 10; 11; 12; 13]
first list: [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13]
second list: [7; 6; 20; 21; 22; 23]
(Commit "commit.",
[7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13; 7; 6; 20; 21; 22; 23])
Start runList.
first list: []
second list: [7; 6; 0; 1; 2; 3]
first list: [7; 6; 0; 1; 2; 3]
second list: [7; 6; 10; 11; 12; 13]
first list: [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13]
(Rollback "rollback!", [])Interessant ist ob die Transaktionen asynchron ausgeführt werden können. Ich habe es leider nicht hingekriegt.Hier ist meine F# Implementierung von der Transaktion Monad.
// from http://hackage.haskell.org/packages/archive/monad-tx/0.0.1/doc/html/Control-Monad-Tx.html
module TransactionM
open System
// 'e : error type
// 'a : transaction state type
type TransactionState<'e,'a> =
| Begin
| Abort of ('e option)
| Dirty of ('e option)
| Rollback of 'a
| Commit of 'a
// 's : state
// 'a : TransactionState
// 'r : result
// ('s -> 'a -> 'r) : continuation
type TransactionM<'r, 's, 'a> = TransactionM of ('s -> ('s -> 'a -> 'r) -> 'r)
type TransactionHandle<'r, 's, 'a> = TransactionHandle of (('a * TransactionHandle<'r, 's, 'a>) -> TransactionM<'r, 's, unit>)
let inline runTransaction (TransactionM g) s k = g s k
// result is of type (TransactionState * state)
let inline runTransaction_ (TransactionM g) s = g s (fun s' a -> (a, s'))
// result is of type TransactionState
let inline runTransactionState (TransactionM g) s = g s (fun _ a -> a)
let inline withCommit f =
TransactionM (fun s k ->
let (TransactionM g) = f (fun a -> TransactionM (fun s' _ -> k s' a))
g s k)
let inline withRollback f =
TransactionM (fun s k ->
let (TransactionM g) = (f (fun a -> TransactionM (fun _ _ -> k s a)))
g s k)
let inline bind (TransactionM g) f =
TransactionM(fun s k ->
g s (fun s' a ->
let (TransactionM g') = f a
g' s' k))
//computation workflow builder.
type TransactionBuilder() =
member this.Return(a) = TransactionM(fun s k -> k s a)
member this.Bind(m, k) = bind m k
member this.Zero () = this.Return ()
member this.Combine(r1, r2) = this.Bind(r1, fun _ -> r2)
member this.ReturnFrom(m : TransactionM<_,_,_>) = m
member this.Delay(f) = this.Bind(this.Return (), f)
member this.TryFinally(computation, compensation) =
TransactionM(fun s k ->
try
runTransaction computation s k
finally
compensation())
member this.Using(res: #IDisposable, body) =
this.TryFinally(body res,
(fun () -> match res with null -> () | disp -> disp.Dispose()))
member this.TryWith(computation, handler) =
TransactionM(fun s k ->
try
runTransaction computation s k
with e -> runTransaction (handler e) s k)
let transaction = new TransactionBuilder()
let inline bindM builder m f = (^M: (member Bind: 'd -> ('e -> 'c) -> 'c) (builder, m, f))
let inline (>>.) m n = bindM transaction m (fun _ -> n)
let inline isBegin t =
match t with
| Begin -> true
| _ -> false
let inline fmap f (TransactionM g) = TransactionM (fun s k -> g s (fun s' a -> k s' (f a)))
//begin transaction.
let inline beginT f =
let checkpoint =
withCommit (fun fcommit ->
withRollback (fun frollback ->
transaction {
let go (transactionState, handle) =
match transactionState with
| Begin -> failwith "nested"
| Abort e -> frollback (Abort e, handle)
| Dirty e -> fcommit (Dirty e, handle)
| Rollback a -> frollback (Rollback a, handle)
| Commit a -> fcommit (Commit a, handle)
return (Begin, TransactionHandle go)
} ))
withRollback (fun fabort ->
transaction {
let! (transactionState, handle) = checkpoint
if isBegin transactionState then
return! (f handle >>. fabort (Abort None))
return transactionState
})
//a bunch of helpers, which allow to access and manipulate transaction.
let inline alwaysCommit a = TransactionM(fun s k -> k s (Commit a))
let inline jump (TransactionHandle k) stat =
(k (stat, TransactionHandle k)) >>. TransactionM(fun s k -> k s id)
let inline abort handle e = jump handle (Abort e)
let inline dirty handle e = jump handle (Dirty e)
let inline rollback handle a = jump handle (Rollback a)
let inline commit handle a = jump handle (Commit a)
let get = TransactionM (fun s k -> k s s)
let inline gets f = TransactionM (fun s k -> k s (f s))
let inline set s =
TransactionM (fun _ k -> k s ())
let inline modify f = TransactionM(fun s k -> k (f s) ())
Keine Kommentare:
Kommentar veröffentlichen