Moved FSharp monadic data strures from PayrollCalculus (#69)

src/Core/NBB.Core.Effects.FSharp/Data/ReaderStateEffect.fs

@@ -0,0 +1,99 @@
+namespace NBB.Core.Effects.FSharp.Data.ReaderStateEffect
+
+open NBB.Core.Effects.FSharp
+open NBB.Core.FSharp.Data
+open NBB.Core.FSharp.Data.State
+open NBB.Core.FSharp.Data.Reader
+open NBB.Core.FSharp.Data.ReaderState
+open NBB.Core.Effects.FSharp.Data.ReaderEffect
+open NBB.Core.Effects.FSharp.Data.StateEffect
+
+type ReaderStateEffect<'r, 's, 'a> = 'r -> 's -> Effect<'a * 's>
+module ReaderStateEffect =
+    let run (x: ReaderStateEffect<'r, 's, 'a>) : 'r -> 's -> Effect<'a * 's> = 
+        x 
+
+    let map (f: 'a -> 'b) (m : ReaderStateEffect<'r, 's, 'a>) : ReaderStateEffect<'r, 's, 'b> = 
+        fun r s -> run m r s |> Effect.map (fun (a, s') -> (f a, s')) 
+
+    let bind (f: 'a-> ReaderStateEffect<'r, 's, 'b>) (m : ReaderStateEffect<'r, 's, 'a>) : ReaderStateEffect<'r, 's, 'b> = 
+        fun r s -> run m r s |> Effect.bind (fun (a, s') -> run (f a) r s') 
+
+    let apply (f: ReaderStateEffect<'r, 's, ('a -> 'b)>) (m: ReaderStateEffect<'r, 's, 'a>) : ReaderStateEffect<'r, 's, 'b> =
+        fun r s ->
+            effect {
+                let! (f', s') = run f r s
+                let! (a, s'') = run m r s'
+                return (f' a, s'')
+            }
+
+    let ask () : ReaderStateEffect<'r, 's, 'r> = 
+        fun r s -> Effect.pure' (r, s)
+
+    let get () : ReaderStateEffect<'r, 's, 's> = 
+        fun _r s -> Effect.pure' (s, s)
+
+    let put (s: 's) : ReaderStateEffect<'r, 's, unit> = 
+        fun _r  _s -> Effect.pure' ((), s)
+
+    let modify (f: 's -> 's) : ReaderStateEffect<'r, 's, unit> =
+        get() |> bind (put << f)
+
+    let join (m: ReaderStateEffect<'r, 's, ReaderStateEffect<'r, 's, 'a>>) : ReaderStateEffect<'r, 's, 'a> = 
+        m |> bind id 
+
+    let lift (eff : Effect<'a>) : ReaderStateEffect<'r, 's, 'a> =
+        fun _r s -> eff |> Effect.map (fun a -> (a, s))
+
+    let pure' (a:'a) : ReaderStateEffect<'r, 's, 'a> = 
+        a |> Effect.pure' |> lift
+
+
+    let hoist (readerState: ReaderState<'r, 's, 'a>) : ReaderStateEffect<'r, 's, 'a> =
+        fun r s -> Effect.pure' (ReaderState.run readerState r s)
+
+module StateEffectBulder =
+    type ReaderStateEffectBulder() =
+        member _.Bind (m, f) = ReaderStateEffect.bind f m                    : ReaderStateEffect<'r, 's,'u>
+        member _.Return x = ReaderStateEffect.pure' x                        : ReaderStateEffect<'r, 's,'u>
+        member _.ReturnFrom x = x                                            : ReaderStateEffect<'r, 's,'u>
+        member _.Combine (m1, m2) = ReaderStateEffect.bind (fun _ -> m1) m2  : ReaderStateEffect<'r, 's,'u>
+        member _.Zero () = ReaderStateEffect.pure' ()                        : ReaderStateEffect<'r, 's, unit>
+
+
+[<AutoOpen>]
+module ReaderStateEffectExtensions =
+    let readerStateEffect = new StateEffectBulder.ReaderStateEffectBulder()
+
+    let (<!>) = ReaderStateEffect.map
+    let (<*>) = ReaderStateEffect.apply
+    let (>>=) eff func = ReaderStateEffect.bind func eff
+
+    [<RequireQualifiedAccess>]
+    module List =
+        let traverseReaderStateEffect f list =
+            let pure' = ReaderStateEffect.pure'
+            let (<*>) = ReaderStateEffect.apply
+            let cons head tail = head :: tail  
+            let initState = pure' []
+            let folder head tail = pure' cons <*> (f head) <*> tail
+            List.foldBack folder list initState
+
+        let sequenceReaderStateEffect list = traverseReaderStateEffect id list
+
+    [<RequireQualifiedAccess>]
+    module Result = 
+          let traverseReaderStateEffect (f: 'a-> ReaderStateEffect<'r, 's, 'b>) (result:Result<'a,'e>) : ReaderStateEffect<'r, 's, Result<'b, 'e>> = 
+              match result with
+                  | Error err -> ReaderStateEffect.pure' (Error err)
+                  | Ok v -> ReaderStateEffect.map Result.Ok (f v)
+
+          let sequenceReaderStateEffect result = traverseReaderStateEffect id result
+
+    [<RequireQualifiedAccess>]
+    module ReaderStateEffect =
+        let addCaching (key: 'k) (readerStateEff: ReaderStateEffect<'r, Map<'k, 'v>, 'v>) : ReaderStateEffect<'r, Map<'k, 'v>, 'v> =
+            reader {
+                let! stateEff = readerStateEff
+                return stateEff |> StateEffect.addCaching key 
+            }

src/Core/NBB.Core.Effects.FSharp/Data/StateEffect.fs

@@ -27,6 +27,9 @@ module StateEffect =
     let put (x: 's) : StateEffect<'s, unit> = 
         fun _ -> Effect.pure' ((), x)
 
+    let modify (f: 's -> 's) : StateEffect<'s, unit> =
+         get() |> bind (put << f)
+
     let flatten x = 
         bind id x
 
@@ -73,4 +76,18 @@ module StateEffectExtensions =
                   | Error err -> StateEffect.map Result.Error (StateEffect.pure' err)
                   | Ok v -> StateEffect.map Result.Ok (f v)
 
-          let sequenceStateEffect result = traverseStateEffect id result
+          let sequenceStateEffect result = traverseStateEffect id result
+
+    [<RequireQualifiedAccess>]
+    module StateEffect =
+        let addCaching (key: 'k) (stateEff: StateEffect<Map<'k, 'v>, 'v>) : StateEffect<Map<'k, 'v>, 'v> =
+            stateEffect {
+                let! cache = StateEffect.get ()
+                match (cache.TryFind key) with
+                    | Some value -> 
+                        return value
+                    | None -> 
+                        let! value = stateEff
+                        do! StateEffect.modify(fun cache -> cache.Add (key, value))
+                        return value     
+            } 

src/Core/NBB.Core.Effects.FSharp/NBB.Core.Effects.FSharp.fsproj

@@ -8,6 +8,7 @@
     <Compile Include="Effects.fs" />
     <Compile Include="Data\ReaderEffect.fs" />
     <Compile Include="Data\StateEffect.fs" />
+    <Compile Include="Data\ReaderStateEffect.fs" />
   </ItemGroup>
 
   <ItemGroup>

src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/ReaderState.fs

@@ -0,0 +1,82 @@
+namespace NBB.Core.FSharp.Data.ReaderState
+
+open NBB.Core.FSharp.Data
+open NBB.Core.FSharp.Data.State
+open NBB.Core.FSharp.Data.Reader
+
+type ReaderState<'r, 's, 'a> = 'r -> 's -> ('a * 's)
+module ReaderState =
+    let run (x: ReaderState<'r, 's, 'a>) : 'r -> 's -> ('a * 's) = 
+        x 
+
+    let map (f: 'a -> 'b) (m : ReaderState<'r, 's, 'a>) : ReaderState<'r, 's, 'b> = 
+        fun r s -> let (a, s') = run m r s in (f a, s')
+
+    let bind (f: 'a-> ReaderState<'r, 's, 'b>) (m : ReaderState<'r, 's, 'a>) : ReaderState<'r, 's, 'b> = 
+        fun r s -> let (a, s') = run m r s in run (f a) r s' 
+
+    let apply (f: ReaderState<'r, 's, ('a -> 'b)>) (m: ReaderState<'r, 's, 'a>) : ReaderState<'r, 's, 'b> =
+        fun r s -> let (f', s') = run f r s in let (a, s'') = run m r s' in (f' a, s'')
+
+    let ask () : ReaderState<'r, 's, 'r> = 
+        fun r s -> (r, s)
+
+    let get () : ReaderState<'r, 's, 's> = 
+        fun _r s -> (s, s)
+
+    let put (s: 's) : ReaderState<'r, 's, unit> = 
+        fun _r  _s -> ((), s)
+
+    let modify (f: 's -> 's) : ReaderState<'r, 's, unit> =
+        get() |> bind (put << f)
+
+    let join (m: ReaderState<'r, 's, ReaderState<'r, 's, 'a>>) : ReaderState<'r, 's, 'a> = 
+        m |> bind id 
+
+    let lift (st : State<'s, 'a>) : ReaderState<'r, 's, 'a> =
+        fun _r s -> st s
+
+    let hoist (rd: Reader<'r, 'a>) : ReaderState<'r, 's, 'a> =
+        fun r s -> (Reader.run rd r, s)
+
+    let pure' (a:'a) : ReaderState<'r, 's, 'a> = 
+        a |> State.pure' |> lift
+
+
+module ReaderStateBuilder =
+    type ReaderStateBulder() =
+        member _.Bind (m, f) = ReaderState.bind f m                    : ReaderState<'r, 's,'u>
+        member _.Return x = ReaderState.pure' x                        : ReaderState<'r, 's,'u>
+        member _.ReturnFrom x = x                                            : ReaderState<'r, 's,'u>
+        member _.Combine (m1, m2) = ReaderState.bind (fun _ -> m1) m2  : ReaderState<'r, 's,'u>
+        member _.Zero () = ReaderState.pure' ()                        : ReaderState<'r, 's, unit>
+
+
+[<AutoOpen>]
+module ReaderStateExtensions =
+    let readerState = new ReaderStateBuilder.ReaderStateBulder()
+
+    let (<!>) = ReaderState.map
+    let (<*>) = ReaderState.apply
+    let (>>=) eff func = ReaderState.bind func eff
+
+    [<RequireQualifiedAccess>]
+    module List =
+        let traverseReaderState f list =
+            let pure' = ReaderState.pure'
+            let (<*>) = ReaderState.apply
+            let cons head tail = head :: tail  
+            let initState = pure' []
+            let folder head tail = pure' cons <*> (f head) <*> tail
+            List.foldBack folder list initState
+
+        let sequenceReaderState list = traverseReaderState id list
+
+    [<RequireQualifiedAccess>]
+    module Result = 
+          let traverseReaderState (f: 'a-> ReaderState<'r, 's, 'b>) (result:Result<'a,'e>) : ReaderState<'r, 's, Result<'b, 'e>> = 
+              match result with
+                  | Error err -> ReaderState.pure' (Error err)
+                  | Ok v -> ReaderState.map Result.Ok (f v)
+
+          let sequenceReaderState result = traverseReaderState id result

src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/ResultExtensions.fs

@@ -3,6 +3,11 @@
 [<AutoOpen>]
 module ResultExtensions =
 
+    [<RequireQualifiedAccess>]
+    module Result =
+        let inline join (res: Result<Result<'t, 'e>, 'e>) =
+           res |> Result.bind id 
+
     [<RequireQualifiedAccess>]
     module List =
         let traverseResult f list =

src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/State.fs

@@ -20,6 +20,9 @@ module State =
     let put (x: 's) : State<'s, unit> = 
         fun _ -> ((), x)
 
+    let modify (f: 's -> 's) : State<'s, unit> =
+         get() |> bind (put << f)
+
     let pure' x = 
         fun s -> (x, s)
 

src/Core/NBB.Core.FSharp/NBB.Core.FSharp/NBB.Core.FSharp.fsproj

@@ -8,6 +8,7 @@
     <Compile Include="Data\Reader.fs" />
     <Compile Include="Data\ResultExtensions.fs" />
     <Compile Include="Data\State.fs" />
+    <Compile Include="Data\ReaderState.fs" />
   </ItemGroup>
 
 </Project>