diff --git a/src/Core/NBB.Core.Effects.FSharp/Data/ReaderStateEffect.fs b/src/Core/NBB.Core.Effects.FSharp/Data/ReaderStateEffect.fs new file mode 100644 index 00000000..4a70c565 --- /dev/null +++ b/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> + + +[] +module ReaderStateEffectExtensions = + let readerStateEffect = new StateEffectBulder.ReaderStateEffectBulder() + + let () = ReaderStateEffect.map + let (<*>) = ReaderStateEffect.apply + let (>>=) eff func = ReaderStateEffect.bind func eff + + [] + 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 + + [] + 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 + + [] + 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 + } \ No newline at end of file diff --git a/src/Core/NBB.Core.Effects.FSharp/Data/StateEffect.fs b/src/Core/NBB.Core.Effects.FSharp/Data/StateEffect.fs index 5baa4deb..38b9fe11 100644 --- a/src/Core/NBB.Core.Effects.FSharp/Data/StateEffect.fs +++ b/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 \ No newline at end of file + let sequenceStateEffect result = traverseStateEffect id result + + [] + module StateEffect = + let addCaching (key: 'k) (stateEff: StateEffect, 'v>) : StateEffect, '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 + } \ No newline at end of file diff --git a/src/Core/NBB.Core.Effects.FSharp/NBB.Core.Effects.FSharp.fsproj b/src/Core/NBB.Core.Effects.FSharp/NBB.Core.Effects.FSharp.fsproj index 038617d8..c7189ffe 100644 --- a/src/Core/NBB.Core.Effects.FSharp/NBB.Core.Effects.FSharp.fsproj +++ b/src/Core/NBB.Core.Effects.FSharp/NBB.Core.Effects.FSharp.fsproj @@ -8,6 +8,7 @@ + diff --git a/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/ReaderState.fs b/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/ReaderState.fs new file mode 100644 index 00000000..7c4eb304 --- /dev/null +++ b/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> + + +[] +module ReaderStateExtensions = + let readerState = new ReaderStateBuilder.ReaderStateBulder() + + let () = ReaderState.map + let (<*>) = ReaderState.apply + let (>>=) eff func = ReaderState.bind func eff + + [] + 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 + + [] + 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 \ No newline at end of file diff --git a/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/ResultExtensions.fs b/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/ResultExtensions.fs index 6eeeee6a..be93697a 100644 --- a/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/ResultExtensions.fs +++ b/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/ResultExtensions.fs @@ -3,6 +3,11 @@ [] module ResultExtensions = + [] + module Result = + let inline join (res: Result, 'e>) = + res |> Result.bind id + [] module List = let traverseResult f list = diff --git a/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/State.fs b/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/State.fs index 5daf223a..68e26ce7 100644 --- a/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/Data/State.fs +++ b/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) diff --git a/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/NBB.Core.FSharp.fsproj b/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/NBB.Core.FSharp.fsproj index e3fb1de0..28be083f 100644 --- a/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/NBB.Core.FSharp.fsproj +++ b/src/Core/NBB.Core.FSharp/NBB.Core.FSharp/NBB.Core.FSharp.fsproj @@ -8,6 +8,7 @@ +