ThreadSafeDictionary with selective choice in Hopac

ThreadSafeDictionary.fs

open Hopac
open Hopac.Infixes

/// A thread safe dictionary supports multiple-readers', multiple-writers'
/// access to a normal .Net dictionary.
type ThreadSafeDictionary<'K, 'V> =
  private {
    tryAddCh: Ch<'K * (unit -> 'V) * Ch<'V> * Promise<unit>>
    tryAddSelectCh: Ch<'K * (unit -> 'V) * ('V -> obj) * Ch<obj> * Promise<unit>>
    tryRemoveCh: Ch<'K * Ch<'V option> * Promise<unit>>
  }

/// A thread safe dictionary supports multiple-readers', multiple-writers'
/// access to a normal .Net dictionary.
module ThreadSafeDictionary =
  open System.Collections.Generic
  /// Creates a new thread safe dictionary.
  let create (): Job<ThreadSafeDictionary<'K, 'V>> =
    let tryFindAdd, tryFindAddSel, tryRemove = Ch (), Ch (), Ch ()
    let dic = Dictionary<'K, 'V>()
    let tryFind fac key =
      match dic.TryGetValue key with
      | false, _ -> fac ()
      | _, value -> value
    let selectOp =
      Alt.choose [
        tryFindAdd ^=> fun (key, fac, repl, nack) ->
          let value = tryFind fac key
          dic.[key] <- value
          Alt.choose [
            repl *<- value
            nack ^-> fun () -> ignore (dic.Remove key)
          ]

        tryFindAddSel ^=> fun (key, fac, selector, repl, nack) ->
          let value = tryFind fac key
          dic.[key] <- value
          Alt.choose [
            repl *<- selector value
            nack ^-> fun () -> ignore (dic.Remove key)
          ]

        tryRemove ^=> fun (key, repl, nack) ->
          match dic.TryGetValue key with
          | false, _ ->
            repl *<- None <|> nack
          | _, value ->
            ignore (dic.Remove key)
            Alt.choose [
              repl *<- Some value
              nack ^-> fun () -> dic.Add(key, value)
            ]
      ]

    Job.foreverServer selectOp >>-.
    { tryAddCh = tryFindAdd
      tryAddSelectCh = tryFindAddSel
      tryRemoveCh = tryRemove }

  /// Tries to find the key in the dictionary, otherwise creates the value with
  /// the factory and returns it in the alternative. If the returned
  /// alternative is not committed to, the value is not added to the dictionary.
  let tryFindAdd key fac (x: _): Alt<'V> =
    x.tryAddCh *<+->- fun repl nack -> key, fac, repl, nack

  /// Try to add to the dictionary, at the given key. If the key exists, calls
  /// the selector with the value and returns it as the Alt. If the key doesn't
  /// exist, the factory is invoked to create the value. The created value is
  /// then returned after being passed through the selector. If the returned
  /// alternative is not committed to, the value is not added to the dictionary.
  let tryFindAddSelect key factory (selector: 'V -> 'x) (x: _): Alt<'x> =
    let op =
      x.tryAddSelectCh *<+->- fun repl nack ->
      key, factory, selector >> box, repl, nack
    op ^-> unbox

  /// Tries to find the key in the dictionary, returning the corresponding
  /// `Some value` from the dictionary. If the alternative is not committed to,
  /// the value is not removed from the dictionary.
  let tryRemove key (x: _): Alt<'V option> =
    x.tryRemoveCh *<+->- fun repl nack -> key, repl, nack

Usage.fsx

#r "Hopac.Core.dll"
#r "Hopac.dll"
#load "ThreadSafeDictionary.fs"
open Hopac

let tsd: ThreadSafeDictionary<string, string> = ThreadSafeDictionary.create() |> run
(*
val tsd : ThreadSafeDictionary<string,string> =
  {tryAddCh =
  Hopac.Ch`1[System.Tuple`4[System.String,Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,System.String],Hopac.Ch`1[System.String
],Hopac.Promise`1[Microsoft.FSharp.Core.Unit]]];
 tryAddSelectCh =
  Hopac.Ch`1[System.Tuple`5[System.String,Microsoft.FSharp.Core.FSharpFunc`2[Microsoft.FSharp.Core.Unit,System.String],Microsoft.FSharp.Core.FS
harpFunc`2[System.String,System.Object],Hopac.Ch`1[System.Object],Hopac.Promise`1[Microsoft.FSharp.Core.Unit]]];
 tryRemoveCh =
  Hopac.Ch`1[System.Tuple`3[System.String,Hopac.Ch`1[Microsoft.FSharp.Core.FSharpOption`1[System.String]],Hopac.Promise`1[Microsoft.FSharp.Core
.Unit]]];}
*)

let i = ref 0
// val i : int ref = {contents = 0;}

let factory = fun () -> i := !i + 1; sprintf "exists%i" (!i)
// val factory : unit -> string

tsd |> ThreadSafeDictionary.tryFindAdd "haf" factory |> run
//val it : string = "exists1"
tsd |> ThreadSafeDictionary.tryFindAdd "haf" factory |> run
//val it : string = "exists1"

tsd |> ThreadSafeDictionary.tryFindAddSelect "haf" factory (fun str -> "It " + str) |> run
// val it : string = "It exists1"
tsd |> ThreadSafeDictionary.tryFindAddSelect "haf" factory (fun str -> "It " + str) |> run
// val it : string = "It exists1"

tsd |> ThreadSafeDictionary.tryRemove "haf" |> run
// val it : string option = Some "exists1"
tsd |> ThreadSafeDictionary.tryRemove "haf" |> run
// val it : string option = None

tsd |> ThreadSafeDictionary.tryFindAdd "haf" factory |> run
// val it : string = "exists2"

tsd |> ThreadSafeDictionary.tryRemove "haf" |> run
// val it : string option = Some "exists2"