Skip to content

Commit bb287d3

Browse files
gustygusty
committed
Bring ListT
2 parents 038859e + cdb81a3 commit bb287d3

File tree

3 files changed

+183
-44
lines changed

3 files changed

+183
-44
lines changed

‎src/FSharpPlus/Data/List.fs

+131-44
Original file line numberDiff line numberDiff line change
@@ -36,68 +36,155 @@ open FSharpPlus.Control
3636

3737
/// Monad Transformer for list<'T>
3838
[<Struct>]
39-
type ListT<'``monad<list<'t>>``> = ListT of '``monad<list<'t>>``
39+
type ListT<'``monad<'t>``> = ListT of obj
40+
type ListTNode<'``monad<'t>``,'t> = Nil | Cons of 't * ListT<'``monad<'t>``>
4041

4142
/// Basic operations on ListT
4243
[<RequireQualifiedAccess>]
4344
module ListT =
44-
let run (ListT m) = m : '``Monad<list<'T>>``
4545

46-
/// Embed a Monad<'T> into a ListT<'Monad<list<'T>>>
47-
let inline lift (x: '``Monad<'T>``) : ListT<'``Monad<list<'T>>``> =
48-
if opaqueId false then x |> liftM List.singleton |> ListT
49-
else x |> map List.singleton |> ListT
50-
51-
let inline internal sequence ms =
52-
let k m m' = m >>= fun (x: 'a) -> m' >>= fun xs -> (result: list<'a> -> 'M) (x::xs)
53-
List.foldBack k ms ((result :list<'a> -> 'M) [])
54-
55-
let inline internal mapM f as' = sequence (List.map f as')
56-
57-
let inline bind (f: 'T-> ListT<'``Monad<list<'U>``>) (ListT m: ListT<'``Monad<list<'T>``>) = (ListT (m >>= mapM (run << f) >>= ((List.concat: list<_>->_) >> result)))
58-
let inline apply (ListT f: ListT<'``Monad<list<('T -> 'U)>``>) (ListT x: ListT<'``Monad<list<'T>``>) = ListT (map List.apply f <*> x) : ListT<'``Monad<list<'U>``>
59-
let inline lift2 (f: 'T->'U->'V) (ListT x: ListT<'``Monad<list<'T>``>) (ListT y: ListT<'``Monad<list<'U>``>) = ListT (lift2 (List.lift2 f) x y) : ListT<'``Monad<list<'V>``>
60-
let inline lift3 (f: 'T->'U->'V->'W) (ListT x: ListT<'``Monad<list<'T>``>) (ListT y: ListT<'``Monad<list<'U>``>) (ListT z: ListT<'``Monad<list<'V>``>) = ListT (lift3 (List.lift3 f) x y z) : ListT<'``Monad<list<'W>``>
61-
let inline map (f: 'T->'U) (ListT m: ListT<'``Monad<list<'T>``>) = ListT (map (List.map f) m) : ListT<'``Monad<list<'U>``>
62-
63-
type ListT<'``monad<list<'t>>``> with
64-
65-
static member inline Return (x: 'T) = [x] |> result |> ListT : ListT<'``Monad<list<'T>``>
46+
let inline internal wrap (mit: 'mit) =
47+
let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result ListTNode<'mt,'t>.Nil ) : 'mit
48+
ListT mit : ListT<'mt>
49+
50+
let inline internal unwrap (ListT mit : ListT<'mt>) =
51+
let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result ListTNode<'mt,'t>.Nil ) : 'mit
52+
unbox mit : 'mit
53+
54+
let inline empty () = wrap ((result ListTNode<'mt,'t>.Nil) : 'mit) : ListT<'mt>
55+
56+
/// Concatenates the elements of two lists
57+
let inline concat l1 l2 =
58+
let rec loop (l1: ListT<'mt>) (lst2: ListT<'mt>) =
59+
let (l1, l2) = unwrap l1, unwrap lst2
60+
ListT (l1 >>= function Nil -> l2 | Cons (x: 't, xs) -> ((result (Cons (x, loop xs lst2))) : 'mit))
61+
loop l1 l2 : ListT<'mt>
62+
63+
let inline bind f (source: ListT<'mt>) : ListT<'mu> =
64+
let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_: 't) -> (result Unchecked.defaultof<'u>) : 'mu
65+
let rec loop f input =
66+
ListT (
67+
(unwrap input : 'mit) >>= function
68+
| Nil -> result <| (Nil : ListTNode<'mu,'u>) : 'miu
69+
| Cons (h:'t, t: ListT<'mt>) ->
70+
let res = concat (f h: ListT<'mu>) (loop f t)
71+
unwrap res : 'miu)
72+
loop f source : ListT<'mu>
73+
74+
let inline unfold (f:'State -> '``M<('T * 'State) option>``) (s:'State) : ListT<'MT> =
75+
let rec loop f s = f s |> map (function
76+
| Some (a, s) -> Cons(a, loop f s)
77+
| None -> Nil) |> wrap
78+
loop f s
79+
80+
let inline map f (input : ListT<'mt>) : ListT<'mu> =
81+
let rec collect f (input : ListT<'mt>) : ListT<'mu> =
82+
wrap (
83+
(unwrap input : 'mit) >>= function
84+
| Nil -> result <| (Nil : ListTNode<'mu,'u>) : 'miu
85+
| Cons (h: 't, t: ListT<'mt>) ->
86+
let ( res) = Cons (f h, collect f t)
87+
result res : 'miu)
88+
collect f (input: ListT<'mt>) : ListT<'mu>
89+
90+
let inline singleton (v: 't) =
91+
let mresult x = result x
92+
let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= konst (mresult ListTNode<'mt,'t>.Nil ) : 'mit
93+
wrap ((mresult <| ListTNode<'mt,'t>.Cons (v, (wrap (mresult ListTNode<'mt,'t>.Nil): ListT<'mt> ))) : 'mit) : ListT<'mt>
94+
95+
let inline apply f x = bind (fun (x1: _) -> bind (fun x2 -> singleton (x1 x2)) x) f
96+
97+
let inline append (head: 't) tail = wrap ((result <| ListTNode<'mt,'t>.Cons (head, (tail: ListT<'mt> ))) : 'mit) : ListT<'mt>
98+
99+
let inline head (x : ListT<'mt>) =
100+
unwrap x >>= function
101+
| Nil -> failwith "empty list"
102+
| Cons (head, _) -> result head : 'mt
103+
104+
let inline tail (x: ListT<'mt>) : ListT<'mt> =
105+
(unwrap x >>= function
106+
| Nil -> failwith "empty list"
107+
| Cons (_: 't, tail) -> unwrap tail) |> wrap
108+
109+
let inline iterM (action: 'T -> '``M<unit>``) (lst: ListT<'MT>) : '``M<unit>`` =
110+
let rec loop lst action =
111+
unwrap lst >>= function
112+
| Nil -> result ()
113+
| Cons (h, t) -> action h >>= (fun () -> loop t action)
114+
loop lst action
115+
116+
let inline iter (action: 'T -> unit) (lst: ListT<'MT>) : '``M<unit>`` = iterM (action >> result) lst
117+
118+
let inline lift (x: '``Monad<'T>``) = wrap (x >>= (result << (fun x -> Cons (x, empty () )))) : ListT<'``Monad<'T>``>
119+
120+
let inline take count (input : ListT<'MT>) : ListT<'MT> =
121+
let rec loop count (input : ListT<'MT>) : ListT<'MT> = wrap <| monad {
122+
if count > 0 then
123+
let! v = unwrap input
124+
match v with
125+
| Cons (h, t) -> return Cons (h, loop (count - 1) t)
126+
| Nil -> return Nil
127+
else return Nil }
128+
loop count (input: ListT<'MT>)
129+
130+
let inline filterM (f: 'T -> '``M<bool>``) (input: ListT<'MT>) : ListT<'MT> =
131+
input |> bind (fun v -> lift (f v) |> bind (fun b -> if b then singleton v else empty ()))
132+
133+
let inline filter f (input: ListT<'MT>) : ListT<'MT> = filterM (f >> result) input
134+
135+
let inline run (lst: ListT<'MT>) : '``Monad<list<'T>>`` =
136+
let rec loop acc x = unwrap x >>= function
137+
| Nil -> result (List.rev acc)
138+
| Cons (x, xs) -> loop (x::acc) xs
139+
loop [] lst
140+
141+
142+
143+
[<AutoOpen>]
144+
module ListTPrimitives =
145+
let inline listT (al: '``Monad<list<'T>>``) : ListT<'``Monad<'T>``> =
146+
ListT.unfold (fun i -> map (fun (lst:list<_>) -> if lst.Length > i then Some (lst.[i], i+1) else None) al) 0
147+
148+
// let inline lift2 (f: 'T->'U->'V) (ListT x: ListT<'``Monad<list<'T>``>) (ListT y: ListT<'``Monad<list<'U>``>) = ListT (lift2 (List.lift2 f) x y) : ListT<'``Monad<list<'V>``>
149+
// let inline lift3 (f: 'T->'U->'V->'W) (ListT x: ListT<'``Monad<list<'T>``>) (ListT y: ListT<'``Monad<list<'U>``>) (ListT z: ListT<'``Monad<list<'V>``>) = ListT (lift3 (List.lift3 f) x y z) : ListT<'``Monad<list<'W>``>
150+
151+
152+
type ListT<'``monad<'t>``> with
153+
static member inline Return (x: 'T) = ListT.singleton x : ListT<'M>
66154

67155
[<EditorBrowsable(EditorBrowsableState.Never)>]
68-
static member inline Map (x: ListT<'``Monad<list<'T>``>, f: 'T->'U) = ListT.map f x : ListT<'``Monad<list<'U>``>
156+
static member inline Map (x, f) = ListT.map f x
69157

70-
[<EditorBrowsable(EditorBrowsableState.Never)>]
71-
static member inline Lift2 (f: 'T->'U->'V, x: ListT<'``Monad<list<'T>``>, y: ListT<'``Monad<list<'U>``>) = ListT.lift2 f x y : ListT<'``Monad<list<'V>``>
158+
// [<EditorBrowsable(EditorBrowsableState.Never)>]
159+
// static member inline Lift2 (f: 'T->'U->'V, x: ListT<'``Monad<list<'T>``>, y: ListT<'``Monad<list<'U>``>) = ListT.lift2 f x y : ListT<'``Monad<list<'V>``>
72160

73-
[<EditorBrowsable(EditorBrowsableState.Never)>]
74-
static member inline Lift3 (f: 'T->'U->'V->'W, x: ListT<'``Monad<list<'T>``>, y: ListT<'``Monad<list<'U>``>, z: ListT<'``Monad<list<'V>``>) = ListT.lift3 f x y z : ListT<'``Monad<list<'W>``>
161+
// [<EditorBrowsable(EditorBrowsableState.Never)>]
162+
// static member inline Lift3 (f: 'T->'U->'V->'W, x: ListT<'``Monad<list<'T>``>, y: ListT<'``Monad<list<'U>``>, z: ListT<'``Monad<list<'V>``>) = ListT.lift3 f x y z : ListT<'``Monad<list<'W>``>
75163

76-
static member inline (<*>) (f: ListT<'``Monad<list<('T -> 'U)>``>, x: ListT<'``Monad<list<'T>``>) = ListT.apply f x : ListT<'``Monad<list<'U>``>
77-
static member inline (>>=) (x: ListT<'``Monad<list<'T>``>, f: 'T -> ListT<'``Monad<list<'U>``>) = ListT.bind f x
164+
static member inline (<*>) (f, x) = ListT.apply f x
78165

79-
static member inline get_Empty () = ListT <| result [] : ListT<'``MonadPlus<list<'T>``>
80-
static member inline (<|>) (ListT x, ListT y) = ListT (x >>= (fun a -> y >>= (fun b -> result (a @ b)))) : ListT<'``MonadPlus<list<'T>``>
166+
static member inline (>>=) (x, f) = ListT.bind f x
167+
static member inline get_Empty () = ListT.empty ()
168+
static member inline (<|>) (x, y) = ListT.concat x y
81169

82-
static member inline TryWith (source: ListT<'``Monad<list<'T>>``>, f: exn -> ListT<'``Monad<list<'T>>``>) = ListT (TryWith.Invoke (ListT.run source) (ListT.run << f))
83-
static member inline TryFinally (computation: ListT<'``Monad<list<'T>>``>, f) = ListT (TryFinally.Invoke (ListT.run computation) f)
84-
static member inline Using (resource, f: _ -> ListT<'``Monad<list<'T>>``>) = ListT (Using.Invoke resource (ListT.run << f))
85-
static member inline Delay (body : unit -> ListT<'``Monad<list<'T>>``>) = ListT (Delay.Invoke (fun _ -> ListT.run (body ()))) : ListT<'``Monad<list<'T>>``>
170+
static member inline TryWith (source: ListT<'``Monad<'T>``>, f: exn -> ListT<'``Monad<'T>``>) = ListT (TryWith.Invoke (ListT.unwrap source) (ListT.unwrap << f))
171+
static member inline TryFinally (computation: ListT<'``Monad<'T>``>, f) = ListT (TryFinally.Invoke (ListT.unwrap computation) f)
172+
static member inline Using (resource, f: _ -> ListT<'``Monad<'T>``>) = ListT (Using.Invoke resource (ListT.unwrap << f))
173+
static member inline Delay (body : unit -> ListT<'``Monad<'T>``>) = ListT (Delay.Invoke (fun _ -> ListT.unwrap (body ()))) : ListT<'``Monad<'T>``>
86174

87-
[<EditorBrowsable(EditorBrowsableState.Never)>]
88-
static member inline Lift (x: '``Monad<'T>``) : ListT<'``Monad<list<'T>>``> = ListT.lift x
175+
static member inline Lift (x: '``Monad<'T>``) = ListT.lift x : ListT<'``Monad<'T>``>
89176

90-
static member inline LiftAsync (x: Async<'T>) = ListT.lift (liftAsync x) : ListT<'``MonadAsync<'T>``>
177+
static member inline LiftAsync (x: Async<'T>) = lift (liftAsync x) : '``ListT<'MonadAsync<'T>>``
91178

92-
static member inline Throw (x: 'E) = x |> throw |> ListT.lift
179+
static member inline Throw (x: 'E) = x |> throw |> lift
93180
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>``>
94181

95182
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>>``>
96183

97-
static member inline get_Get () = ListT.lift get : ListT<'``MonadState<'S,'S>``>
98-
static member inline Put (x: 'S) = x |> put |> ListT.lift : ListT<'``MonadState<unit,'S>``>
184+
static member inline get_Get () = lift get : '``ListT<'MonadState<'S,'S>>``
185+
static member inline Put (x: 'T) = x |> put |> lift : '``ListT<'MonadState<unit,'S>>``
99186

100-
static member inline get_Ask () = ListT.lift ask : ListT<'``MonadReader<'R, list<'R>>``>
101-
static member inline Local (ListT (m: '``MonadReader<'R2,'T>``), f: 'R1->'R2) = ListT (local f m)
187+
static member inline get_Ask () = lift ask : '``ListT<'MonadReader<'R, list<'R>>>``
188+
static member inline Local (m: ListT<'``MonadReader<'R2,'T>``>, f: 'R1->'R2) = listT (local f (ListT.run m))
102189

103-
#endif
190+
static member inline Take (lst, c, _: Take) = ListT.take c lst

‎tests/FSharpPlus.Tests/FSharpPlus.Tests.fsproj

+1
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@
2020
<Compile Include="Validations.fs" />
2121
<Compile Include="Task.fs" />
2222
<Compile Include="Free.fs" />
23+
<Compile Include="ListT.fs" />
2324
<Compile Include="ComputationExpressions.fs" />
2425
<Compile Include="Lens.fs" />
2526
<Compile Include="Extensions.fs" />

‎tests/FSharpPlus.Tests/ListT.fs

+51
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,51 @@
1+
module FSharpPlus.Tests.ListT
2+
3+
open System
4+
open FSharpPlus
5+
open FSharpPlus.Data
6+
open NUnit.Framework
7+
open FsCheck
8+
open Helpers
9+
open System.Collections.Generic
10+
open System.Threading.Tasks
11+
12+
module BasicTests =
13+
[<Test>]
14+
let wrap_unwrap () =
15+
let c = listT (async.Return (['a'..'g']))
16+
let res = c |> ListT.run |> listT |> ListT.run |> extract
17+
let exp = c |> ListT.run |> extract
18+
CollectionAssert.AreEqual (res, exp)
19+
20+
[<Test>]
21+
let infiniteLists () =
22+
let (infinite: ListT<Lazy<_>>) = ListT.unfold (fun x -> monad { return (Some (x, x + 1) ) }) 0
23+
let finite = take 12 infinite
24+
let res = finite <|> infinite
25+
CollectionAssert.AreEqual (res |> take 13 |> ListT.run |> extract, [0;1;2;3;4;5;6;7;8;9;10;11;0])
26+
27+
// Compile tests
28+
let binds () =
29+
let res1 = listT [| [1..4] |] >>= fun x -> listT [| [x * 2] |]
30+
let res2 = listT (Task.FromResult [1..4]) >>= (fun x -> listT (Task.FromResult [x * 2]))
31+
let res3 = listT (ResizeArray [ [1..4] ]) >>= (fun x -> listT (ResizeArray [ [x * 2] ]))
32+
let res4 = listT (lazy [1..4]) >>= (fun x -> listT (lazy ( [x * 2])))
33+
let (res5: ListT<_ seq>) = listT (seq [ [1..4] ]) >>= (fun x -> listT (seq [ [x * 2] ]))
34+
() // Note: seq needs type annotation.
35+
36+
let bind_for_ideantity () =
37+
let res = listT (Identity [1..4]) >>= fun x -> listT (Identity [x * 2])
38+
()
39+
40+
let computation_expressions () =
41+
let oneTwoThree : ListT<_> = monad.plus {
42+
do! lift <| Async.Sleep 10
43+
yield 1
44+
do! lift <| Async.Sleep 50
45+
yield 2
46+
yield 3}
47+
()
48+
49+
let applicative_with_options () =
50+
let x = (+) <!> listT None <*> listT (Some [1;2;3;4])
51+
() // It doesn't work with asyncs

0 commit comments

Comments
 (0)