fsharp plus compatible monads (#66)

Co-authored-by: Radu Popovici <[email protected]>
osstotalsoft · Mar 6, 2020 · 7002054 · 7002054
1 parent 0d1bd48
commit 7002054
Show file tree

Hide file tree

Showing 7 changed files with 81 additions and 41 deletions.
diff --git 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
@@ -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
+//    let sequenceEvented list = traverseEvented id list
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
@@ -15,6 +15,7 @@
 
   <ItemGroup>
     <PackageReference Include="Foq" Version="1.8.0" />
+    <PackageReference Include="FSharpPlus" Version="1.1.0-RC3" />
     <PackageReference Include="FsUnit.xUnit" Version="3.8.0" />
     <PackageReference Include="Microsoft.NET.Test.Sdk" Version="16.5.0" />
     <PackageReference Include="Moq" Version="4.13.1" />

diff --git 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
@@ -2,12 +2,11 @@ module Tests
 open Xunit
 open FsUnit.Xunit
 open NBB.Core.Effects.FSharp
-open NBB.Core.Effects
 open Moq
 
 [<Fact>]
 let ``Pure(1) + Pure(2) should equal Pure(3)`` () =
-    let interpreter = Interpreter(Mock.Of<ISideEffectHandlerFactory>());
+    let interpreter = NBB.Core.Effects.Interpreter(Mock.Of<NBB.Core.Effects.ISideEffectHandlerFactory>());
     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
@@ -15,6 +15,7 @@
 
   <ItemGroup>
     <PackageReference Include="Foq" Version="1.8.0" />
+    <PackageReference Include="FSharpPlus" Version="1.1.0-RC3" />
     <PackageReference Include="FsUnit.xUnit" Version="3.8.0" />
     <PackageReference Include="Microsoft.NET.Test.Sdk" Version="16.5.0" />
     <PackageReference Include="Moq" Version="4.13.1" />

diff --git 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,17 +30,17 @@ 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 {
             let! x' = create x
             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