From ef60f802370e8dd979df1d1df6040c19fb6a0300 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Fri, 23 Aug 2019 11:36:29 +0200 Subject: [PATCH 01/11] Initial implementation --- src/FSharpPlus/List.fs | 150 ++++++++++++++++++++++++++++++++--------- 1 file changed, 118 insertions(+), 32 deletions(-) diff --git a/src/FSharpPlus/List.fs b/src/FSharpPlus/List.fs index a5288cf58..e6aae1ac1 100644 --- a/src/FSharpPlus/List.fs +++ b/src/FSharpPlus/List.fs @@ -33,51 +33,137 @@ open FSharpPlus.Control /// Monad Transformer for list<'T> [] -type ListT<'``monad>``> = ListT of '``monad>`` +type ListT<'``monad<'t>``> = ListT of obj +type ListTNode<'``monad<'t>``,'t> = Nil | Cons of 't * ListT<'``monad<'t>``> /// Basic operations on ListT [] module ListT = - let run (ListT m) = m : '``Monad>`` - let inline internal sequence ms = - let k m m' = m >>= fun (x: 'a) -> m' >>= fun xs -> (result: list<'a> -> 'M) (x::xs) - List.foldBack k ms ((result :list<'a> -> 'M) []) - - let inline internal mapM f as' = sequence (List.map f as') - - let inline bind (f: 'T-> ListT<'``Monad``>) (ListT m: ListT<'``Monad``>) = (ListT (m >>= mapM (run << f) >>= ((List.concat: list<_>->_) >> result))) - let inline apply (ListT f: ListT<'``Monad 'U)>``>) (ListT x: ListT<'``Monad``>) = ListT (map List.apply f <*> x) : ListT<'``Monad``> - let inline map (f: 'T->'U) (ListT m: ListT<'``Monad``>) = ListT (map (List.map f) m) : ListT<'``Monad``> - -type ListT<'``monad>``> with - static member inline Return (x: 'T) = [x] |> result |> ListT : ListT<'``Monad``> + let inline internal wrap (mit: 'mit) = + let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result ListTNode<'mt,'t>.Nil ) : 'mit + ListT mit : ListT<'mt> + + let inline internal unwrap (ListT mit : ListT<'mt>) = + let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result ListTNode<'mt,'t>.Nil ) : 'mit + unbox mit : 'mit + + let inline empty () = wrap ((result ListTNode<'mt,'t>.Nil) : 'mit) : ListT<'mt> + + /// Concatenates the elements of two lists + let inline concat l1 l2 = + let rec loop (l1: ListT<'mt>) (lst2: ListT<'mt>) = + let (l1, l2) = unwrap l1, unwrap lst2 + ListT (l1 >>= function Nil -> l2 | Cons (x: 't, xs) -> ((result (Cons (x, loop xs lst2))) : 'mit)) + loop l1 l2 : ListT<'mt> + + let inline bind f (source: ListT<'mt>) : ListT<'mu> = + let rec loop f input = + wrap ( + (unwrap input : 'mit) >>= function + | Nil -> result <| (Nil : ListTNode<'mu,'u>) : 'miu + | Cons (h:'t, t: ListT<'mt>) -> + let ( res) = concat (f h: ListT<'mu>) (loop f t ) + unwrap res : 'miu) + loop f source : ListT<'mu> + + let inline unfold (f:'State -> '``M<('T * 'State) option>``) (s:'State) : ListT<'MT> = + let rec loop f s = f s |> map (function + | Some (a, s) -> Cons(a, loop f s) + | None -> Nil) |> wrap + loop f s + + let inline map f (input : ListT<'mt>) : ListT<'mu> = + let rec collect f (input : ListT<'mt>) : ListT<'mu> = + wrap ( + (unwrap input : 'mit) >>= function + | Nil -> result <| (Nil : ListTNode<'mu,'u>) : 'miu + | Cons (h: 't, t: ListT<'mt>) -> + let ( res) = Cons (f h, collect f t) + result res : 'miu) + collect f (input: ListT<'mt>) : ListT<'mu> + + let inline singleton (v:'t) = + let mresult x = result x + let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= konst (mresult ListTNode<'mt,'t>.Nil ) : 'mit + wrap ((mresult <| ListTNode<'mt,'t>.Cons (v, (wrap (mresult ListTNode<'mt,'t>.Nil): ListT<'mt> ))) : 'mit) : ListT<'mt> + + let inline apply f x = bind (fun (x1: _) -> bind (fun x2 -> singleton (x1 x2)) x) f + + let inline append (head: 't) tail = wrap ((result <| ListTNode<'mt,'t>.Cons (head, (tail: ListT<'mt> ))) : 'mit) : ListT<'mt> + + let inline head (x : ListT<'mt>) = + unwrap x >>= function + | Nil -> failwith "empty list" + | Cons (head, _) -> result head : 'mt + + let inline tail (x: ListT<'mt>) : ListT<'mt> = + (unwrap x >>= function + | Nil -> failwith "empty list" + | Cons (_: 't, tail) -> unwrap tail) |> wrap + + let inline iter action lst = + let rec loop (seq: ListT<'MT>) (action: 'T -> '``M``) : '``M`` = + unwrap seq >>= function + | Nil -> result () + | Cons (h, t) -> action h >>= (fun () -> loop t action) + loop lst action + + let inline lift (x: '``Monad<'T>``) = wrap (x >>= (result << (fun x -> Cons (x, empty () )))) : ListT<'``Monad<'T>``> + + let inline take count (input : ListT<'MT>) : ListT<'MT> = + let rec loop count (input : ListT<'MT>) : ListT<'MT> = wrap <| monad { + if count > 0 then + let! v = unwrap input + match v with + | Cons (h, t) -> return Cons (h, loop (count - 1) t) + | Nil -> return Nil + else return Nil } + loop count (input: ListT<'MT>) + + let inline run (lst: ListT<'MT>) : '``Monad>`` = + let rec loop acc x = unwrap x >>= function + | Nil -> result (List.rev acc) + | Cons (x, xs) -> loop (x::acc) xs + loop [] lst + + +[] +module ListTPrimitives = + let inline listT (al: '``Monad>``) : ListT<'``Monad<'T>``> = + ListT.unfold (fun i -> map (fun (lst:list<_>) -> if lst.Length > i then Some (lst.[i], i+1) else None) al) 0 + + +type ListT<'``monad<'t>``> with + static member inline Return (x: 'T) = ListT.singleton x : ListT<'M> [] - static member inline Map (x: ListT<'``Monad``>, f: 'T->'U) = ListT.map f x : ListT<'``Monad``> + static member inline Map (x, f) = ListT.map f x - static member inline (<*>) (f: ListT<'``Monad 'U)>``>, x: ListT<'``Monad``>) = ListT.apply f x : ListT<'``Monad``> - static member inline (>>=) (x: ListT<'``Monad``>, f: 'T -> ListT<'``Monad``>) = ListT.bind f x + static member inline (<*>) (f, x) = ListT.apply f x - static member inline get_Empty () = ListT <| result [] : ListT<'``MonadPlus``> - static member inline (<|>) (ListT x, ListT y) = ListT (x >>= (fun a -> y >>= (fun b -> result (a @ b)))) : ListT<'``MonadPlus``> + static member inline (>>=) (x, f) = ListT.bind f x + static member inline get_Empty () = ListT.empty () + static member inline (<|>) (x, y) = ListT.concat x y - static member inline TryWith (source: ListT<'``Monad>``>, f: exn -> ListT<'``Monad>``>) = ListT (TryWith.Invoke (ListT.run source) (ListT.run << f)) - static member inline TryFinally (computation: ListT<'``Monad>``>, f) = ListT (TryFinally.Invoke (ListT.run computation) f) - static member inline Using (resource, f: _ -> ListT<'``Monad>``>) = ListT (Using.Invoke resource (ListT.run << f)) - static member inline Delay (body : unit -> ListT<'``Monad>``>) = ListT (Delay.Invoke (fun _ -> ListT.run (body ()))) : ListT<'``Monad>``> + static member inline TryWith (source: ListT<'``Monad<'T>``>, f: exn -> ListT<'``Monad<'T>``>) = ListT (TryWith.Invoke (ListT.unwrap source) (ListT.unwrap << f)) + static member inline TryFinally (computation: ListT<'``Monad<'T>``>, f) = ListT (TryFinally.Invoke (ListT.unwrap computation) f) + static member inline Using (resource, f: _ -> ListT<'``Monad<'T>``>) = ListT (Using.Invoke resource (ListT.unwrap << f)) + static member inline Delay (body : unit -> ListT<'``Monad<'T>``>) = ListT (Delay.Invoke (fun _ -> ListT.unwrap (body ()))) : ListT<'``Monad<'T>``> + + static member inline Lift (x:'``Monad<'T>``) = ListT.wrap (x >>= (result << (fun x -> Cons (x, ListT.empty () )))) : ListT<'``Monad<'T>``> - static member inline Lift (x: '``Monad<'T>``) = x |> liftM List.singleton |> ListT : ListT<'``Monad>``> - static member inline LiftAsync (x: Async<'T>) = lift (liftAsync x) : '``ListT<'MonadAsync<'T>>`` - + static member inline Throw (x: 'E) = x |> throw |> lift - static member inline Catch (m: ListT<'``MonadError<'E1,'T>``>, h: 'E1 -> ListT<'``MonadError<'E2,'T>``>) = ListT ((fun v h -> Catch.Invoke v h) (ListT.run m) (ListT.run << h)) : ListT<'``MonadError<'E2,'T>``> - - static member inline CallCC (f: (('T -> ListT<'``MonadCont<'R,list<'U>>``>) -> _)) = ListT (callCC <| fun c -> ListT.run (f (ListT << c << List.singleton))) : ListT<'``MonadCont<'R, list<'T>>``> - + static member inline Catch (m: ListT<'``MonadError<'E1,'T>``>, h: 'E1 -> ListT<'``MonadError<'E2,'T>``>) = listT ((fun v h -> Catch.Invoke v h) (ListT.run m) (ListT.run << h)) : ListT<'``MonadError<'E2,'T>``> + + static member inline CallCC (f: (('T -> ListT<'``MonadCont<'R,list<'U>>``>) -> _)) = listT (callCC <| fun c -> ListT.run (f (listT << c << List.singleton))) : ListT<'``MonadCont<'R, list<'T>>``> + static member inline get_Get () = lift get : '``ListT<'MonadState<'S,'S>>`` static member inline Put (x: 'T) = x |> put |> lift : '``ListT<'MonadState>`` - + static member inline get_Ask () = lift ask : '``ListT<'MonadReader<'R, list<'R>>>`` - static member inline Local (ListT (m: '``MonadReader<'R2,'T>``), f: 'R1->'R2) = ListT (local f m) \ No newline at end of file + static member inline Local (m: ListT<'``MonadReader<'R2,'T>``>, f: 'R1->'R2) = listT (local f (ListT.run m)) + + static member inline Take (lst, c, _: Take) = ListT.take c lst From 032f0e512ffab3902c22b57c5223f55f9e59ca9d Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Fri, 23 Aug 2019 15:11:45 +0200 Subject: [PATCH 02/11] + Some basic tests --- .../FSharpPlus.Tests/FSharpPlus.Tests.fsproj | 1 + tests/FSharpPlus.Tests/ListT.fs | 24 +++++++++++++++++++ 2 files changed, 25 insertions(+) create mode 100644 tests/FSharpPlus.Tests/ListT.fs diff --git a/tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj b/tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj index 4db77a790..af0dbb345 100644 --- a/tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj +++ b/tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj @@ -13,6 +13,7 @@ + diff --git a/tests/FSharpPlus.Tests/ListT.fs b/tests/FSharpPlus.Tests/ListT.fs new file mode 100644 index 000000000..4685e9d77 --- /dev/null +++ b/tests/FSharpPlus.Tests/ListT.fs @@ -0,0 +1,24 @@ +module FSharpPlus.Tests.ListT + +open System +open FSharpPlus +open FSharpPlus.Data +open NUnit.Framework +open FsCheck +open Helpers +open System.Collections.Generic + +module BasicTests = + [] + let wrap_unwrap () = + let c = listT (lazy (['a'..'g'])) + let res = c |> ListT.run |> listT |> ListT.run |> extract + let exp = c |> ListT.run |> extract + CollectionAssert.AreEqual (res, exp) + + [] + let infiniteLists = + let (infinite: ListT>) = ListT.unfold (fun x -> monad { return (Some (x, x + 1) ) }) 0 + let finite = take 12 infinite + let res = finite <|> infinite + CollectionAssert.AreEqual (res |> take 13 |> ListT.run |> extract, [0;1;2;3;4;5;6;7;8;9;10;11;0]) \ No newline at end of file From 7070c94a20de8610ac9ade9415614584bb712522 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Fri, 23 Aug 2019 18:01:05 +0200 Subject: [PATCH 03/11] Roundtrip test fails with Lazy, use Async --- tests/FSharpPlus.Tests/ListT.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/FSharpPlus.Tests/ListT.fs b/tests/FSharpPlus.Tests/ListT.fs index 4685e9d77..36de6904c 100644 --- a/tests/FSharpPlus.Tests/ListT.fs +++ b/tests/FSharpPlus.Tests/ListT.fs @@ -11,7 +11,7 @@ open System.Collections.Generic module BasicTests = [] let wrap_unwrap () = - let c = listT (lazy (['a'..'g'])) + let c = listT (async.Return (['a'..'g'])) let res = c |> ListT.run |> listT |> ListT.run |> extract let exp = c |> ListT.run |> extract CollectionAssert.AreEqual (res, exp) From 231da23c99db8438b2e1e97aac61dff50940cf92 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Fri, 23 Aug 2019 19:00:30 +0200 Subject: [PATCH 04/11] + More tests --- tests/FSharpPlus.Tests/ListT.fs | 26 ++++++++++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/tests/FSharpPlus.Tests/ListT.fs b/tests/FSharpPlus.Tests/ListT.fs index 36de6904c..3e119c5c9 100644 --- a/tests/FSharpPlus.Tests/ListT.fs +++ b/tests/FSharpPlus.Tests/ListT.fs @@ -17,8 +17,30 @@ module BasicTests = CollectionAssert.AreEqual (res, exp) [] - let infiniteLists = + let infiniteLists () = let (infinite: ListT>) = ListT.unfold (fun x -> monad { return (Some (x, x + 1) ) }) 0 let finite = take 12 infinite let res = finite <|> infinite - CollectionAssert.AreEqual (res |> take 13 |> ListT.run |> extract, [0;1;2;3;4;5;6;7;8;9;10;11;0]) \ No newline at end of file + CollectionAssert.AreEqual (res |> take 13 |> ListT.run |> extract, [0;1;2;3;4;5;6;7;8;9;10;11;0]) + + // Compile tests + let binds () = + let res = listT ( [| [1..4] |]) >>= fun x -> listT ( [| [x * 2] |]) + () // but for some reason it doesn't work for Task, ResizeArray, Lazy and seq + + let bind_for_ideantity () = + let res = listT (Identity [1..4]) >>= fun x -> listT (Identity [x * 2]) + () + + let computation_expressions () = + let oneTwoThree : ListT<_> = monad.plus { + do! lift <| Async.Sleep 10 + yield 1 + do! lift <| Async.Sleep 50 + yield 2 + yield 3} + () + + let applicative_with_options () = + let x = (+) listT None <*> listT (Some [1;2;3;4]) + () // It doesn't work with asyncs From ad89c2a3f9f637ec5d3ed59d73810b8b79aacae1 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Fri, 23 Aug 2019 23:58:56 +0200 Subject: [PATCH 05/11] Adapt bind for non-sealed types --- src/FSharpPlus/List.fs | 11 ++++++----- tests/FSharpPlus.Tests/ListT.fs | 9 +++++++-- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/src/FSharpPlus/List.fs b/src/FSharpPlus/List.fs index e6aae1ac1..950ff8e06 100644 --- a/src/FSharpPlus/List.fs +++ b/src/FSharpPlus/List.fs @@ -58,13 +58,14 @@ module ListT = loop l1 l2 : ListT<'mt> let inline bind f (source: ListT<'mt>) : ListT<'mu> = - let rec loop f input = - wrap ( - (unwrap input : 'mit) >>= function + let _mnil _ = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_: 't) -> (result Unchecked.defaultof<'u>) : 'mu + let rec loop f (ListT input) = + ListT ( + (unbox input : 'mit) >>= function | Nil -> result <| (Nil : ListTNode<'mu,'u>) : 'miu | Cons (h:'t, t: ListT<'mt>) -> - let ( res) = concat (f h: ListT<'mu>) (loop f t ) - unwrap res : 'miu) + let res = concat (f h: ListT<'mu>) (loop f t) + unwrap res : 'miu) loop f source : ListT<'mu> let inline unfold (f:'State -> '``M<('T * 'State) option>``) (s:'State) : ListT<'MT> = diff --git a/tests/FSharpPlus.Tests/ListT.fs b/tests/FSharpPlus.Tests/ListT.fs index 3e119c5c9..61e805a25 100644 --- a/tests/FSharpPlus.Tests/ListT.fs +++ b/tests/FSharpPlus.Tests/ListT.fs @@ -7,6 +7,7 @@ open NUnit.Framework open FsCheck open Helpers open System.Collections.Generic +open System.Threading.Tasks module BasicTests = [] @@ -25,8 +26,12 @@ module BasicTests = // Compile tests let binds () = - let res = listT ( [| [1..4] |]) >>= fun x -> listT ( [| [x * 2] |]) - () // but for some reason it doesn't work for Task, ResizeArray, Lazy and seq + let res1 = listT [| [1..4] |] >>= fun x -> listT [| [x * 2] |] + let res2 = listT (Task.FromResult [1..4]) |> ListT.bind (fun x -> listT (Task.FromResult [x * 2])) + let res3 = listT (ResizeArray [ [1..4] ]) |> ListT.bind (fun x -> listT (ResizeArray [ [x * 2] ])) + let res4 = listT (lazy [1..4]) |> ListT.bind (fun x -> listT (lazy ( [x * 2]))) + let (res5: ListT<_ seq>) = listT (seq [ [1..4] ]) |> ListT.bind (fun x -> listT (seq [ [x * 2] ])) + () // Note: seq needs type annotation, the non-sealead types don't work with generic >>= (internal error, unsolved type var) let bind_for_ideantity () = let res = listT (Identity [1..4]) >>= fun x -> listT (Identity [x * 2]) From 1e0ad438a90aa20d9c21bb4d9fd25cc2ff993755 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Sat, 24 Aug 2019 00:59:54 +0200 Subject: [PATCH 06/11] Workaround F# bug for generic bind --- src/FSharpPlus/List.fs | 6 +++--- tests/FSharpPlus.Tests/ListT.fs | 10 +++++----- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/FSharpPlus/List.fs b/src/FSharpPlus/List.fs index 950ff8e06..40ec66198 100644 --- a/src/FSharpPlus/List.fs +++ b/src/FSharpPlus/List.fs @@ -58,10 +58,10 @@ module ListT = loop l1 l2 : ListT<'mt> let inline bind f (source: ListT<'mt>) : ListT<'mu> = - let _mnil _ = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_: 't) -> (result Unchecked.defaultof<'u>) : 'mu - let rec loop f (ListT input) = + let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_: 't) -> (result Unchecked.defaultof<'u>) : 'mu + let rec loop f input = ListT ( - (unbox input : 'mit) >>= function + (unwrap input : 'mit) >>= function | Nil -> result <| (Nil : ListTNode<'mu,'u>) : 'miu | Cons (h:'t, t: ListT<'mt>) -> let res = concat (f h: ListT<'mu>) (loop f t) diff --git a/tests/FSharpPlus.Tests/ListT.fs b/tests/FSharpPlus.Tests/ListT.fs index 61e805a25..bc99bc430 100644 --- a/tests/FSharpPlus.Tests/ListT.fs +++ b/tests/FSharpPlus.Tests/ListT.fs @@ -27,11 +27,11 @@ module BasicTests = // Compile tests let binds () = let res1 = listT [| [1..4] |] >>= fun x -> listT [| [x * 2] |] - let res2 = listT (Task.FromResult [1..4]) |> ListT.bind (fun x -> listT (Task.FromResult [x * 2])) - let res3 = listT (ResizeArray [ [1..4] ]) |> ListT.bind (fun x -> listT (ResizeArray [ [x * 2] ])) - let res4 = listT (lazy [1..4]) |> ListT.bind (fun x -> listT (lazy ( [x * 2]))) - let (res5: ListT<_ seq>) = listT (seq [ [1..4] ]) |> ListT.bind (fun x -> listT (seq [ [x * 2] ])) - () // Note: seq needs type annotation, the non-sealead types don't work with generic >>= (internal error, unsolved type var) + let res2 = listT (Task.FromResult [1..4]) >>= (fun x -> listT (Task.FromResult [x * 2])) + let res3 = listT (ResizeArray [ [1..4] ]) >>= (fun x -> listT (ResizeArray [ [x * 2] ])) + let res4 = listT (lazy [1..4]) >>= (fun x -> listT (lazy ( [x * 2]))) + let (res5: ListT<_ seq>) = listT (seq [ [1..4] ]) >>= (fun x -> listT (seq [ [x * 2] ])) + () // Note: seq needs type annotation. let bind_for_ideantity () = let res = listT (Identity [1..4]) >>= fun x -> listT (Identity [x * 2]) From 9d646a63b0862811d831c43359f6dd64c48b87d1 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Mon, 26 Aug 2019 22:02:55 +0200 Subject: [PATCH 07/11] Rename iter to iterM and add a (non-M) iter --- src/FSharpPlus/List.fs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/FSharpPlus/List.fs b/src/FSharpPlus/List.fs index 40ec66198..36dc62f19 100644 --- a/src/FSharpPlus/List.fs +++ b/src/FSharpPlus/List.fs @@ -84,7 +84,7 @@ module ListT = result res : 'miu) collect f (input: ListT<'mt>) : ListT<'mu> - let inline singleton (v:'t) = + let inline singleton (v: 't) = let mresult x = result x let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= konst (mresult ListTNode<'mt,'t>.Nil ) : 'mit wrap ((mresult <| ListTNode<'mt,'t>.Cons (v, (wrap (mresult ListTNode<'mt,'t>.Nil): ListT<'mt> ))) : 'mit) : ListT<'mt> @@ -103,12 +103,14 @@ module ListT = | Nil -> failwith "empty list" | Cons (_: 't, tail) -> unwrap tail) |> wrap - let inline iter action lst = - let rec loop (seq: ListT<'MT>) (action: 'T -> '``M``) : '``M`` = - unwrap seq >>= function + let inline iterM (action: 'T -> '``M``) (lst: ListT<'MT>) : '``M`` = + let rec loop lst action = + unwrap lst >>= function | Nil -> result () | Cons (h, t) -> action h >>= (fun () -> loop t action) loop lst action + + let inline iter (action: 'T -> unit) (lst: ListT<'MT>) = iterM (action >> singleton) lst let inline lift (x: '``Monad<'T>``) = wrap (x >>= (result << (fun x -> Cons (x, empty () )))) : ListT<'``Monad<'T>``> From 3dfad1c2520ec93b3f3a42603595146afe5050ca Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Mon, 26 Aug 2019 22:39:25 +0200 Subject: [PATCH 08/11] fix --- src/FSharpPlus/List.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/FSharpPlus/List.fs b/src/FSharpPlus/List.fs index 36dc62f19..7859dfbf1 100644 --- a/src/FSharpPlus/List.fs +++ b/src/FSharpPlus/List.fs @@ -110,7 +110,7 @@ module ListT = | Cons (h, t) -> action h >>= (fun () -> loop t action) loop lst action - let inline iter (action: 'T -> unit) (lst: ListT<'MT>) = iterM (action >> singleton) lst + let inline iter (action: 'T -> unit) (lst: ListT<'MT>) : '``M`` = iterM (action >> result) lst let inline lift (x: '``Monad<'T>``) = wrap (x >>= (result << (fun x -> Cons (x, empty () )))) : ListT<'``Monad<'T>``> From 20bbea630a58b3f8c80fa6e47e8ea8de20ab7df8 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Mon, 26 Aug 2019 22:56:23 +0200 Subject: [PATCH 09/11] + filterM and filter --- src/FSharpPlus/List.fs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/FSharpPlus/List.fs b/src/FSharpPlus/List.fs index 7859dfbf1..5e3fcd515 100644 --- a/src/FSharpPlus/List.fs +++ b/src/FSharpPlus/List.fs @@ -123,6 +123,11 @@ module ListT = | Nil -> return Nil else return Nil } loop count (input: ListT<'MT>) + + let inline filterM (f: 'T -> ListT<'``M``>) (input: ListT<'MT>) : ListT<'MT> = + input |> ListT.bind (fun v -> f v |> ListT.bind (fun b -> if b then singleton v else empty ())) + + let inline filter f (input: ListT<'MT>) : ListT<'MT> = filterM (f >> singleton) input let inline run (lst: ListT<'MT>) : '``Monad>`` = let rec loop acc x = unwrap x >>= function From e6f854950004be15937208086f8f30a2d249c8e4 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Mon, 26 Aug 2019 23:05:22 +0200 Subject: [PATCH 10/11] fix --- src/FSharpPlus/List.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/FSharpPlus/List.fs b/src/FSharpPlus/List.fs index 5e3fcd515..190646806 100644 --- a/src/FSharpPlus/List.fs +++ b/src/FSharpPlus/List.fs @@ -125,7 +125,7 @@ module ListT = loop count (input: ListT<'MT>) let inline filterM (f: 'T -> ListT<'``M``>) (input: ListT<'MT>) : ListT<'MT> = - input |> ListT.bind (fun v -> f v |> ListT.bind (fun b -> if b then singleton v else empty ())) + input |> bind (fun v -> f v |> bind (fun b -> if b then singleton v else empty ())) let inline filter f (input: ListT<'MT>) : ListT<'MT> = filterM (f >> singleton) input From cdb81a3207d28755d73bc6917a4df0eb0647d058 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Mon, 26 Aug 2019 23:25:15 +0200 Subject: [PATCH 11/11] Align filterM filter type with iterM action type --- src/FSharpPlus/List.fs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/FSharpPlus/List.fs b/src/FSharpPlus/List.fs index 190646806..b397b3747 100644 --- a/src/FSharpPlus/List.fs +++ b/src/FSharpPlus/List.fs @@ -124,10 +124,10 @@ module ListT = else return Nil } loop count (input: ListT<'MT>) - let inline filterM (f: 'T -> ListT<'``M``>) (input: ListT<'MT>) : ListT<'MT> = - input |> bind (fun v -> f v |> bind (fun b -> if b then singleton v else empty ())) + let inline filterM (f: 'T -> '``M``) (input: ListT<'MT>) : ListT<'MT> = + input |> bind (fun v -> lift (f v) |> bind (fun b -> if b then singleton v else empty ())) - let inline filter f (input: ListT<'MT>) : ListT<'MT> = filterM (f >> singleton) input + let inline filter f (input: ListT<'MT>) : ListT<'MT> = filterM (f >> result) input let inline run (lst: ListT<'MT>) : '``Monad>`` = let rec loop acc x = unwrap x >>= function