15 people like it.
Like the snippet!

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

Previous Version Raw view Test code New version

More information

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