From 700205451b045bdb67686ced4dfb5920659cccab Mon Sep 17 00:00:00 2001 From: Radu Popovici Date: Fri, 6 Mar 2020 10:08:13 +0200 Subject: [PATCH] fsharp plus compatible monads (#66) Co-authored-by: Radu Popovici --- src/Core/NBB.Core.Effects.FSharp/Effects.fs | 67 ++++++++++++++----- src/Core/NBB.Core.Evented.FSharp/Evented.fs | 32 +++++---- .../NBB.Core.Effects.FSharp.Tests.fsproj | 1 + .../NBB.Core.Effects.FSharp.Tests/Sample.fs | 7 +- .../NBB.Core.Effects.FSharp.Tests/Tests.fs | 3 +- .../NBB.Core.Evented.FSharp.Tests.fsproj | 1 + .../NBB.Core.Evented.FSharp.Tests/Sample.fs | 11 +-- 7 files changed, 81 insertions(+), 41 deletions(-) diff --git a/src/Core/NBB.Core.Effects.FSharp/Effects.fs b/src/Core/NBB.Core.Effects.FSharp/Effects.fs index 46204cc5..41e979ad 100644 --- a/src/Core/NBB.Core.Effects.FSharp/Effects.fs +++ b/src/Core/NBB.Core.Effects.FSharp/Effects.fs @@ -3,18 +3,49 @@ open System open NBB.Core.Effects + +type Effect<'T> = Effect of IEffect<'T> + module Effect = - let bind func eff = Effect.Bind(eff, Func<'a, IEffect<'b>>(func)) - let map func eff = Effect.Map(Func<'a, 'b>(func), eff) - let apply (func: IEffect<'a->'b>) eff = Effect.Apply(map (fun fn -> Func<'a,'b>(fn)) func, eff) - let pure' x = Effect.Pure x + let wrap eff = Effect eff + let unWrap (Effect eff) = eff + + let map func (Effect eff) = Effect.Map(Func<'a, 'b>(func), eff)|> wrap + + let bind func (Effect eff) = + Effect.Bind(eff, Func<'a, IEffect<'b>>(fun a -> func a |> unWrap)) |> wrap + + let apply (func:Effect<'a->'b>) (eff:Effect<'a>) = bind (fun a -> func |> map (fun fn -> fn a)) eff + + let pure' x = Effect.Pure x |> wrap + let return' = pure' + let ignore eff = map (fun _ -> ()) eff - let composeK f g x = bind g (f x) - let lift2 f = map f >> apply + //let composeK f g x = bind g (f x) + //let lift2 f = map f >> apply + + let interpret<'a> (interpreter:IInterpreter) (Effect eff) = interpreter.Interpret<'a>(eff) |> Async.AwaitTask + +type Effect<'T> with + static member Map (x, f) = Effect.map f x + static member Return (x) = Effect.return' x + static member (>>=) (x,f) = Effect.bind f x + static member (<*>) (f,x) = Effect.apply f x + +//module Effect = +// let bind func eff = Effect.Bind(eff, Func<'a, IEffect<'b>>(func)) +// let map func eff = Effect.Map(Func<'a, 'b>(func), eff) +// let apply (func: IEffect<'a->'b>) eff = Effect.Apply(map (fun fn -> Func<'a,'b>(fn)) func, eff) +// let pure' x = Effect.Pure x +// let return' = pure' +// let ignore eff = map (fun _ -> ()) eff + +// let composeK f g x = bind g (f x) +// let lift2 f = map f >> apply - let interpret<'a> (interpreter:IInterpreter) eff = interpreter.Interpret<'a>(eff) |> Async.AwaitTask +// let interpret<'a> (interpreter:IInterpreter) eff = interpreter.Interpret<'a>(eff) |> Async.AwaitTask module EffectBuilder = type EffectBuilder() = @@ -29,17 +60,17 @@ module EffectBuilder = module Effects = let effect = new EffectBuilder.EffectBuilder() - let () = Effect.map - let (<*>) = Effect.apply - let (>>=) eff func = Effect.bind func eff - let (>=>) = Effect.composeK + //let () = Effect.map + //let (<*>) = Effect.apply + //let (>>=) eff func = Effect.bind func eff + //let (>=>) = Effect.composeK -module List = - let traverseEffect f list = - let cons head tail = head :: tail - let initState = Effect.pure' [] - let folder head tail = Effect.pure' cons <*> (f head) <*> tail - List.foldBack folder list initState +//module List = +// let traverseEffect f list = +// let cons head tail = head :: tail +// let initState = Effect.pure' [] +// let folder head tail = Effect.pure' cons <*> (f head) <*> tail +// List.foldBack folder list initState - let sequenceEffect list = traverseEffect id list +// let sequenceEffect list = traverseEffect id list diff --git a/src/Core/NBB.Core.Evented.FSharp/Evented.fs b/src/Core/NBB.Core.Evented.FSharp/Evented.fs index 3c788461..07396702 100644 --- a/src/Core/NBB.Core.Evented.FSharp/Evented.fs +++ b/src/Core/NBB.Core.Evented.FSharp/Evented.fs @@ -13,9 +13,15 @@ module Evented = let pure' value = Evented(value, []) let return' = pure' - let composeK f g x = bind g (f x) + //let composeK f g x = bind g (f x) - let lift2 f = map f >> apply + //let lift2 f = map f >> apply + +type Evented<'a, 'e> with + static member Map (x, f) = Evented.map f x + static member Return (x) = Evented.return' x + static member (>>=) (x,f) = Evented.bind f x + static member (<*>) (f,x) = Evented.apply f x module EventedBuilder = type EventedBuilder() = @@ -29,16 +35,16 @@ module EventedBuilder = module Events = let evented = new EventedBuilder.EventedBuilder() - let () = Evented.map - let (<*>) = Evented.apply - let (>>=) evented func = Evented.bind func evented - let (>=>) = Evented.composeK + //let () = Evented.map + //let (<*>) = Evented.apply + //let (>>=) evented func = Evented.bind func evented + //let (>=>) = Evented.composeK -module List = - let traverseEvented f list = - let cons head tail = head :: tail - let initState = Evented.pure' [] - let folder head tail = Evented.pure' cons <*> (f head) <*> tail - List.foldBack folder list initState +//module List = +// let traverseEvented f list = +// let cons head tail = head :: tail +// let initState = Evented.pure' [] +// let folder head tail = Evented.pure' cons <*> (f head) <*> tail +// List.foldBack folder list initState - let sequenceEvented list = traverseEvented id list \ No newline at end of file +// let sequenceEvented list = traverseEvented id list \ No newline at end of file diff --git a/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/NBB.Core.Effects.FSharp.Tests.fsproj b/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/NBB.Core.Effects.FSharp.Tests.fsproj index 11897cf3..67aa3542 100644 --- a/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/NBB.Core.Effects.FSharp.Tests.fsproj +++ b/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/NBB.Core.Effects.FSharp.Tests.fsproj @@ -15,6 +15,7 @@ + diff --git a/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/Sample.fs b/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/Sample.fs index 3ac2dff5..7cc80a80 100644 --- a/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/Sample.fs +++ b/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/Sample.fs @@ -2,6 +2,7 @@ open System open NBB.Core.Effects.FSharp +open FSharpPlus module Domain = type AggRoot = AggRoot of int @@ -24,11 +25,11 @@ module Application = do! save agg' } - let handler' (IncrementCommand id) = id |> loadById |> Effect.map increment >>= save + let handler' (IncrementCommand id) = id |> loadById |> map increment >>= save let handler'' (IncrementCommand id) = - let handle = loadById >> Effect.map increment >> Effect.bind save + let handle = loadById >> map increment >> bind save handle id - let listHandler = List.traverseEffect handler + let listHandler (commandList: _ list) = traverse handler commandList |> Effect.ignore diff --git a/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/Tests.fs b/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/Tests.fs index ccdb7792..e8f2d271 100644 --- a/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/Tests.fs +++ b/test/UnitTests/Core/NBB.Core.Effects.FSharp.Tests/Tests.fs @@ -2,12 +2,11 @@ module Tests open Xunit open FsUnit.Xunit open NBB.Core.Effects.FSharp -open NBB.Core.Effects open Moq [] let ``Pure(1) + Pure(2) should equal Pure(3)`` () = - let interpreter = Interpreter(Mock.Of()); + let interpreter = NBB.Core.Effects.Interpreter(Mock.Of()); let eff = effect { let! x = Effect.pure' 1 diff --git a/test/UnitTests/Core/NBB.Core.Evented.FSharp.Tests/NBB.Core.Evented.FSharp.Tests.fsproj b/test/UnitTests/Core/NBB.Core.Evented.FSharp.Tests/NBB.Core.Evented.FSharp.Tests.fsproj index c089d8cb..1f4430c8 100644 --- a/test/UnitTests/Core/NBB.Core.Evented.FSharp.Tests/NBB.Core.Evented.FSharp.Tests.fsproj +++ b/test/UnitTests/Core/NBB.Core.Evented.FSharp.Tests/NBB.Core.Evented.FSharp.Tests.fsproj @@ -15,6 +15,7 @@ + diff --git a/test/UnitTests/Core/NBB.Core.Evented.FSharp.Tests/Sample.fs b/test/UnitTests/Core/NBB.Core.Evented.FSharp.Tests/Sample.fs index 6707367c..7539d135 100644 --- a/test/UnitTests/Core/NBB.Core.Evented.FSharp.Tests/Sample.fs +++ b/test/UnitTests/Core/NBB.Core.Evented.FSharp.Tests/Sample.fs @@ -1,6 +1,7 @@ module Sample open NBB.Core.Evented.FSharp +open FSharpPlus module Domain = type AggRoot = AggRoot of int @@ -14,7 +15,7 @@ module Domain = let increment (AggRoot x) = AggRoot (x + 1) let createAndUpdate x = x |> create >>= update - let createAndUpdate' = create >> Evented.bind update + let createAndUpdate' = create >> bind update let createAndUpdate'' = create >=> update let createAndUpdate''' x = evented { @@ -29,8 +30,8 @@ module Domain = Evented(agg', events @ events') - let createAndIncrement x = x |> create |> Evented.map increment - let createAndIncrement' = create >> Evented.map increment + let createAndIncrement x = x |> create |> map increment + let createAndIncrement' = create >> map increment let createAndIncrement'' x = increment create x let createAndIncrement''' x = evented { @@ -38,8 +39,8 @@ module Domain = return increment x' } - let liftedSum = Evented.lift2 (+) + let liftedSum = lift2 (+) let z = liftedSum (Evented(1, [Added])) (Evented(2, [Updated])) - let createAndIncrementList = List.traverseEvented createAndIncrement + let createAndIncrementList (lst: _ list) = traverse createAndIncrement lst