15 people like it.

Monadic transactions for Clojure-style atoms

This is a simple implementation of a monadic transaction builder for Clojure-style atoms. Based on original code by Nick Palladinos.

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 
64: 
65: 
66: 
67: 
68: 
69: 
open System.Threading

type Transaction<'State,'Result> = T of ('State -> 'State * 'Result)

type Atom<'S when 'S : not struct>(value : 'S) =
    let refCell = ref value
    
    let rec swap (f : 'S -> 'S) = 
        let currentValue = !refCell
        let result = Interlocked.CompareExchange<'S>(refCell, f currentValue, currentValue)
        if obj.ReferenceEquals(result, currentValue) then ()
        else Thread.SpinWait 20; swap f

    let transact (f : 'S -> 'S * 'R) =
        let output = ref Unchecked.defaultof<'R>
        let f' x = let t,s = f x in output := s ; t
        swap f' ; output.Value

    static member Create<'S> (x : 'S) = new Atom<'S>(x)

    member self.Value with get() : 'S = !refCell
    member self.Swap (f : 'S -> 'S) : unit = swap f
    member self.Commit<'R> (f : Transaction<'S,'R>) : 'R = 
        match f with T f0 -> transact f0 

    static member get : Transaction<'S,'S> = T (fun t -> t,t)
    static member set : 'S -> Transaction<'S,unit> = fun t -> T (fun _ -> t,())

type TransactionBuilder() =
    let (!) = function T f -> f

    member __.Return (x : 'R) : Transaction<'S,'R> = T (fun t -> t,x)
    member __.ReturnFrom (f : Transaction<'S,'R>) = f
    member __.Bind (f : Transaction<'S,'T> , 
                    g : 'T -> Transaction<'S,'R>) : Transaction<'S,'R> =
        T (fun t -> let t',x = !f t in !(g x) t')

let transact = new TransactionBuilder()

// example : thread safe stack
type Stack<'T> () =
    let container : Atom<'T list> = Atom.Create []

    member __.Push (x : 'T) =
        transact {
            let! contents = Atom.get

            return! Atom.set <| x :: contents
        } |> container.Commit

    member __.Pop () =
        transact {
            let! contents = Atom.get

            match contents with
            | [] -> return failwith "stack is empty!"
            | head :: tail ->
                do! Atom.set tail
                return head
        } |> container.Commit

    member __.Flush () =
        transact {
            let! contents = Atom.get

            do! Atom.set []

            return contents
        } |> container.Commit
namespace System
namespace System.Threading
type Transaction<'State,'Result> = | T of ('State -> 'State * 'Result)

Full name: Script.Transaction<_,_>
union case Transaction.T: ('State -> 'State * 'Result) -> Transaction<'State,'Result>
Multiple items
type Atom<'S (requires reference type)> =
  new : value:'S -> Atom<'S>
  member Commit : f:Transaction<'S,'R> -> 'R
  member Swap : f:('S -> 'S) -> unit
  member Value : 'S
  static member Create : x:'S -> Atom<'S>
  static member get : Transaction<'S,'S>
  static member set : ('S -> Transaction<'S,unit>)

Full name: Script.Atom<_>

--------------------
new : value:'S -> Atom<'S>
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
val value : 'S (requires reference type)
val refCell : 'S ref (requires reference type)
Multiple items
val ref : value:'T -> 'T ref

Full name: Microsoft.FSharp.Core.Operators.ref

--------------------
type 'T ref = Ref<'T>

Full name: Microsoft.FSharp.Core.ref<_>
val swap : (('S -> 'S) -> unit) (requires reference type)
val f : ('S -> 'S) (requires reference type)
val currentValue : 'S (requires reference type)
val result : 'S (requires reference type)
type Interlocked =
  static member Add : location1:int * value:int -> int + 1 overload
  static member CompareExchange : location1:int * value:int * comparand:int -> int + 6 overloads
  static member Decrement : location:int -> int + 1 overload
  static member Exchange : location1:int * value:int -> int + 6 overloads
  static member Increment : location:int -> int + 1 overload
  static member Read : location:int64 -> int64

Full name: System.Threading.Interlocked
Interlocked.CompareExchange<'T (requires reference type)>(location1: byref<'T>, value: 'T, comparand: 'T) : 'T
Interlocked.CompareExchange(location1: byref<nativeint>, value: nativeint, comparand: nativeint) : nativeint
Interlocked.CompareExchange(location1: byref<obj>, value: obj, comparand: obj) : obj
Interlocked.CompareExchange(location1: byref<float>, value: float, comparand: float) : float
Interlocked.CompareExchange(location1: byref<float32>, value: float32, comparand: float32) : float32
Interlocked.CompareExchange(location1: byref<int64>, value: int64, comparand: int64) : int64
Interlocked.CompareExchange(location1: byref<int>, value: int, comparand: int) : int
type obj = System.Object

Full name: Microsoft.FSharp.Core.obj
System.Object.ReferenceEquals(objA: obj, objB: obj) : bool
Multiple items
type Thread =
  inherit CriticalFinalizerObject
  new : start:ThreadStart -> Thread + 3 overloads
  member Abort : unit -> unit + 1 overload
  member ApartmentState : ApartmentState with get, set
  member CurrentCulture : CultureInfo with get, set
  member CurrentUICulture : CultureInfo with get, set
  member DisableComObjectEagerCleanup : unit -> unit
  member ExecutionContext : ExecutionContext
  member GetApartmentState : unit -> ApartmentState
  member GetCompressedStack : unit -> CompressedStack
  member GetHashCode : unit -> int
  ...

Full name: System.Threading.Thread

--------------------
Thread(start: ThreadStart) : unit
Thread(start: ParameterizedThreadStart) : unit
Thread(start: ThreadStart, maxStackSize: int) : unit
Thread(start: ParameterizedThreadStart, maxStackSize: int) : unit
Thread.SpinWait(iterations: int) : unit
val transact : (('S -> 'S * 'R) -> 'R) (requires reference type)
val f : ('S -> 'S * 'R) (requires reference type)
val output : 'R ref
module Unchecked

from Microsoft.FSharp.Core.Operators
val defaultof<'T> : 'T

Full name: Microsoft.FSharp.Core.Operators.Unchecked.defaultof
val f' : ('S -> 'S) (requires reference type)
val x : 'S (requires reference type)
val t : 'S (requires reference type)
val s : 'R
property Ref.Value: 'R
static member Atom.Create : x:'S -> Atom<'S>

Full name: Script.Atom`1.Create
val self : Atom<'S> (requires reference type)
member Atom.Value : 'S

Full name: Script.Atom`1.Value
member Atom.Swap : f:('S -> 'S) -> unit

Full name: Script.Atom`1.Swap
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
member Atom.Commit : f:Transaction<'S,'R> -> 'R

Full name: Script.Atom`1.Commit
val f : Transaction<'S,'R> (requires reference type)
val f0 : ('S -> 'S * 'R) (requires reference type)
static member Atom.get : Transaction<'S,'S>

Full name: Script.Atom`1.get
static member Atom.set : ('S -> Transaction<'S,unit>)

Full name: Script.Atom`1.set
Multiple items
type TransactionBuilder =
  new : unit -> TransactionBuilder
  member Bind : f:Transaction<'S,'T> * g:('T -> Transaction<'S,'R>) -> Transaction<'S,'R>
  member Return : x:'R -> Transaction<'S,'R>
  member ReturnFrom : f:Transaction<'S,'R> -> Transaction<'S,'R>

Full name: Script.TransactionBuilder

--------------------
new : unit -> TransactionBuilder
val f : ('a -> 'a * 'b)
member TransactionBuilder.Return : x:'R -> Transaction<'S,'R>

Full name: Script.TransactionBuilder.Return
val x : 'R
val t : 'S
val __ : TransactionBuilder
member TransactionBuilder.ReturnFrom : f:Transaction<'S,'R> -> Transaction<'S,'R>

Full name: Script.TransactionBuilder.ReturnFrom
val f : Transaction<'S,'R>
member TransactionBuilder.Bind : f:Transaction<'S,'T> * g:('T -> Transaction<'S,'R>) -> Transaction<'S,'R>

Full name: Script.TransactionBuilder.Bind
val f : Transaction<'S,'T>
val g : ('T -> Transaction<'S,'R>)
val t' : 'S
val x : 'T
val transact : TransactionBuilder

Full name: Script.transact
Multiple items
type Stack<'T> =
  new : unit -> Stack<'T>
  member Flush : unit -> 'T list
  member Pop : unit -> 'T
  member Push : x:'T -> unit

Full name: Script.Stack<_>

--------------------
new : unit -> Stack<'T>
val container : Atom<'T list>
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
static member Atom.Create : x:'S -> Atom<'S>
member Stack.Push : x:'T -> unit

Full name: Script.Stack`1.Push
val contents : 'T list
property Atom.get: Transaction<'S,'S>
property Atom.set: 'S -> Transaction<'S,unit>
member Atom.Commit : f:Transaction<'S,'R> -> 'R
val __ : Stack<'T>
member Stack.Pop : unit -> 'T

Full name: Script.Stack`1.Pop
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val head : 'T
val tail : 'T list
member Stack.Flush : unit -> 'T list

Full name: Script.Stack`1.Flush

More information

Link:http://fssnip.net/bw
Posted:11 years ago
Author:Eirik Tsarpalis
Tags: monadic transactions , thread safety , atom