Skip to content

Commit 4b8ad06

Browse files
gustygusty
committed
HKTize Free and Coproduct
1 parent f5425df commit 4b8ad06

File tree

3 files changed

+100
-51
lines changed

3 files changed

+100
-51
lines changed

‎src/FSharpPlus/Data/Coproduct.fs

+66-17
Original file line numberDiff line numberDiff line change
@@ -4,39 +4,88 @@
44

55
open FSharpPlus
66
open FSharpPlus.Control
7+
open FSharpPlus.Internals.Prelude
78

89

910
[<AbstractClass>]
10-
type CoproductBase<'``functorL<'t>``,'``functorR<'t>``> (left: '``functorL<'t>``, right: '``functorR<'t>``, isLeft: bool) =
11+
type CoproductBase<'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) =
1112
let (left, right, isLeft) = left, right, isLeft
1213
with
1314
member __.getContents () = left, right, isLeft
1415
override x.GetHashCode () = Unchecked.hash (x.getContents ())
1516
override x.Equals o =
1617
match o with
17-
| :? CoproductBase<'``functorL<'t>``,'``functorR<'t>``> as y -> Unchecked.equals (x.getContents ()) (y.getContents ())
18+
| :? CoproductBase<'functorL, 'functorR, 't> as y -> Unchecked.equals (x.getContents ()) (y.getContents ())
1819
| _ -> false
1920

20-
type Coproduct<[<EqualityConditionalOn>]'``functorL<'t>``,'``functorR<'t>``> (left: '``functorL<'t>``, right: '``functorR<'t>``, isLeft: bool) =
21-
inherit CoproductBase<'``functorL<'t>``,'``functorR<'t>``> (left, right, isLeft)
21+
type CoproductL<[<EqualityConditionalOn>]'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) =
22+
inherit CoproductBase<'functorL, 'functorR, 't> (left, right, isLeft)
23+
24+
type CoproductR<[<EqualityConditionalOn>]'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) =
25+
inherit CoproductL<'functorL, 'functorR, 't> (left, right, isLeft)
26+
27+
type Coproduct<[<EqualityConditionalOn>]'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) =
28+
inherit CoproductR<'functorL, 'functorR, 't> (left, right, isLeft)
2229

2330
[<AutoOpen>]
2431
module CoproductPrimitives =
25-
let InL x = Coproduct<'``functorL<'t>``,'``functorR<'t>``> (x, Unchecked.defaultof<'``functorR<'t>``>, true)
26-
let InR x = Coproduct<'``functorL<'t>``,'``functorR<'t>``> (Unchecked.defaultof<'``functorL<'t>``>, x, false)
27-
let (|InL|InR|) (x: Coproduct<'``functorL<'t>``,'``functorR<'t>``>) = let (l, r, isL) = x.getContents () in if isL then InL l else InR r
32+
[<GeneralizableValue>]
33+
let inline InL (x: '``FunctorL<'T>``) : Coproduct<'FunctorL, 'FunctorR, 'T> =
34+
if opaqueId false then
35+
let (_: 'FunctorL) = Map.Invoke (fun (_: 'T) -> Unchecked.defaultof<__>) Unchecked.defaultof<'``FunctorL<'T>``>
36+
()
37+
Coproduct<'FunctorL, 'FunctorR, 'T> (box x, null, true)
38+
39+
[<GeneralizableValue>]
40+
let inline InR (x: '``FunctorR<'T>``) : Coproduct<'FunctorL, 'FunctorR, 'T> =
41+
if opaqueId false then
42+
let (_: 'FunctorR) = Map.Invoke (fun (_: 'T) -> Unchecked.defaultof<__>) Unchecked.defaultof<'``FunctorR<'T>``>
43+
()
44+
Coproduct<'FunctorL, 'FunctorR, 'T> (null, box x, false)
45+
46+
47+
let inline (|InL|InR|) (x: Coproduct<'FunctorL, 'FunctorR, 'T>) : Choice<'``FunctorL<'T>``, '``FunctorR<'T>``> =
48+
if opaqueId false then
49+
let (_: '``FunctorL<'T>``) = Map.Invoke (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorL>
50+
let (_: '``FunctorR<'T>``) = Map.Invoke (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorR>
51+
()
52+
let (l, r, isL) = x.getContents ()
53+
if isL then InL (unbox<'``FunctorL<'T>``> l)
54+
else InR (unbox<'``FunctorR<'T>``> r)
2855

2956

30-
type CoproductBase<'``functorL<'t>``,'``functorR<'t>``> with
31-
static member inline Map (x: CoproductBase<'``FunctorL<'T>``,'``FunctorR<'T>``>, f: 'T -> 'U) : Coproduct<'``FunctorL<'U>``,'``FunctorR<'U>``> =
57+
type CoproductBase<'functorL, 'functorR, 't> with
58+
static member inline Map (x: CoproductBase<'FunctorL, 'FunctorR, 'T>, f: 'T -> 'U) : Coproduct<'FunctorL, 'FunctorR, 'U> =
3259
let (l, r, isL) = x.getContents ()
33-
if isL then InL (Map.Invoke f l)
34-
else InR (Map.Invoke f r)
35-
36-
type Coproduct<'``functorL<'t>``,'``functorR<'t>``> with
37-
static member inline Map (a: Coproduct<'``FunctorL<'T>``,'``FunctorR<'T>``>, f: 'T -> 'U) : Coproduct<'``FunctorL<'U>``,'``FunctorR<'U>``> =
38-
let (l, r, isL) = a.getContents ()
39-
if isL then InL (Map.InvokeOnInstance f l)
40-
else InR (Map.InvokeOnInstance f r)
60+
if isL then InL (Map.Invoke f (unbox l: '``FunctorL<'T>``) : '``FunctorL<'U>``)
61+
else InR (Map.Invoke f (unbox r: '``FunctorR<'T>``) : '``FunctorR<'U>``)
62+
63+
type CoproductL<'functorL, 'functorR, 't> with
64+
static member inline Map (x: CoproductL<'FunctorL, 'FunctorR, 'T>, f: 'T -> 'U) : Coproduct<'FunctorL, 'FunctorR, 'U> =
65+
let inline _CXs (_: '``FunctorL<'T>``* '``FunctorR<'T>``) =
66+
let (_: '``FunctorR<'T>``) = Map.InvokeOnInstance (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorR>
67+
()
68+
let (l, r, isL) = x.getContents ()
69+
if isL then InL (Map.Invoke f (unbox l: '``FunctorL<'T>``) : '``FunctorL<'U>``)
70+
else Coproduct<_, _, _> (null, box (Map.InvokeOnInstance f (unbox r: '``FunctorR<'T>``) : ^``FunctorR<'U>`` ), false)
71+
72+
type CoproductL<'functorL, 'functorR, 't> with
73+
static member inline Map (x: CoproductL<'FunctorL, 'FunctorR, 'T>, f: 'T -> 'U) : Coproduct<'FunctorL, 'FunctorR, 'U> =
74+
let inline _CXs (_: '``FunctorL<'T>``* '``FunctorR<'T>``) =
75+
let (_: '``FunctorL<'T>``) = Map.InvokeOnInstance (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorL>
76+
()
77+
let (l, r, isL) = x.getContents ()
78+
if isL then Coproduct<_, _, _> (box (Map.InvokeOnInstance f (unbox l: '``FunctorL<'T>``) : ^``FunctorL<'U>`` ), null, true )
79+
else InR (Map.Invoke f (unbox r: '``FunctorR<'T>``) : '``FunctorR<'U>``)
80+
81+
type Coproduct<'functorL, 'functorR, 't> with
82+
static member inline Map (x: Coproduct<'FunctorL, 'FunctorR, 'T>, f: 'T -> 'U) : Coproduct<'FunctorL, 'FunctorR, 'U> =
83+
let inline _CXs (_: '``FunctorL<'T>``* '``FunctorR<'T>``) =
84+
let (_: '``FunctorL<'T>``) = Map.InvokeOnInstance (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorL>
85+
let (_: '``FunctorR<'T>``) = Map.InvokeOnInstance (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorR>
86+
()
87+
let (l, r, isL) = x.getContents ()
88+
if isL then Coproduct<_, _, _> (box (Map.InvokeOnInstance f (unbox l: '``FunctorL<'T>``) : ^``FunctorL<'U>`` ), null, true )
89+
else Coproduct<_, _, _> (null, box (Map.InvokeOnInstance f (unbox r: '``FunctorR<'T>``) : ^``FunctorR<'U>`` ), false)
4190

4291
#endif

‎src/FSharpPlus/Data/Free.fs

+30-30
Original file line numberDiff line numberDiff line change
@@ -10,99 +10,99 @@ open FSharpPlus.Internals.Prelude
1010

1111

1212
[<NoComparison>]
13-
type Free<'``functor<'t>``,'t> = Pure of 't | Roll of obj
13+
type Free<'functor, 't> = Pure of 't | Roll of obj
1414

1515
[<AutoOpen>]
1616
module FreePrimitives =
17-
let inline Roll (f: '``Functor<Free<'Functor<'T>,'T>>``) : Free<'``Functor<'T>``,'T> =
17+
let inline Roll (f: '``Functor<Free<'Functor, 'T>>``) : Free<'Functor, 'T> =
1818
if opaqueId false then
19-
let (_: '``Functor<'T>``) = Map.Invoke (fun (_: Free<'``Functor<'T>``,'T>) -> Unchecked.defaultof<'T>) f
19+
let (_: 'Functor) = Map.Invoke (fun (_: Free<'Functor, 'T>) -> Unchecked.defaultof<__>) f
2020
()
21-
Free<'``Functor<'T>``,'T>.Roll f
21+
Free<'Functor, 'T>.Roll f
2222
let (|Pure|Roll|) x = match x with Choice1Of2 x -> Pure x | Choice2Of2 x -> Roll x
2323

2424
/// Basic operations on Free Monads
2525
[<RequireQualifiedAccess>]
2626
module Free =
2727

28-
let inline run (f: Free<'``Functor<'T>``,'T>) : Choice<_,'``Functor<Free<'Functor<'T>,'T>>``> =
28+
let inline run (f: Free<'Functor, 'T>) : Choice<_, '``Functor<Free<'Functor, 'T>>``> =
2929
if opaqueId false then
30-
let (_: ^``Functor<Free<'Functor<'T>,'T>>``) = Map.Invoke (fun (_: 'T) -> Unchecked.defaultof<Free<'``Functor<'T>``,'T>>) Unchecked.defaultof<'``Functor<'T>``>
30+
let (_: ^``Functor<Free<'Functor, 'T>>``) = Map.Invoke (fun (_: __) -> Unchecked.defaultof<Free<'Functor, 'T>>) Unchecked.defaultof<'Functor>
3131
()
3232
match f with
3333
| Free.Pure x -> Choice1Of2 x
3434
| Free.Roll x -> let x = unbox x in Choice2Of2 x
3535

3636
let inline map f x =
37-
let rec loop (f: 'T->'U) (x: Free<'``Functor<'T>``,'T>) : Free<'``Functor<'U>``,'U> =
37+
let rec loop (f: 'T->'U) (x: Free<'Functor, 'T>) : Free<'Functor, 'U> =
3838
match run x with
3939
| Pure x -> Pure (f x)
40-
| Roll (x: ^``Functor<Free<'Functor<'T>,'T>>``) -> Roll (Map.Invoke (loop f : Free<'``Functor<'T>``,'T> -> _) x: ^``Functor<Free<'Functor<'U>,'U>>``)
40+
| Roll (x: ^``Functor<Free<'Functor, 'T>>``) -> Roll (Map.Invoke (loop f : Free<'Functor, 'T> -> _) x: ^``Functor<Free<'Functor, 'U>>``)
4141
loop f x
4242

43-
let inline bind (f: 'T -> Free<'``Functor<'U>``,'U>) (x: Free<'``Functor<'T>``,'T>) : Free<'``Functor<'U>``,'U> =
43+
let inline bind (f: 'T -> Free<'Functor, 'U>) (x: Free<'Functor, 'T>) : Free<'Functor, 'U> =
4444
let rec loop f (x: Free<_,_>) =
4545
match run x with
4646
| Pure r -> f r
47-
| Roll (x: ^``Functor<Free<'Functor<'T>,'T>>``) -> Roll (Map.Invoke (loop f : Free<'``Functor<'T>``,'T> -> _) x: ^``Functor<Free<'Functor<'U>,'U>>``) : Free<'``Functor<'U>``,'U>
47+
| Roll (x: ^``Functor<Free<'Functor, 'T>>``) -> Roll (Map.Invoke (loop f : Free<'Functor, 'T> -> _) x: ^``Functor<Free<'Functor, 'U>>``) : Free<'Functor, 'U>
4848
loop f x
4949

50-
let inline apply (f: Free<'``Functor<'T->'U>``,'T->'U>) (x: Free<'``Functor<'T>``,'T>) : Free<'``Functor<'U>``,'U> =
50+
let inline apply (f: Free<'Functor, 'T->'U>) (x: Free<'Functor, 'T>) : Free<'Functor, 'U> =
5151
let rec loop (x: Free<_,_>) (f: Free<_,_>) =
5252
match run f with
53-
| Pure f -> map<'T,'U,'``Functor<'T>``,'``Functor<Free<'Functor<'T>,'T>>``,'``Functor<Free<'Functor<'U>,'U>>``,'``Functor<'U>``> f x : Free<'``Functor<'U>``,'U>
54-
| Roll (f: ^``Functor<Free<'Functor<'T->'U>,'T->'U>>``) -> Roll (Map.Invoke (loop x: Free<'``Functor<'T->'U>``,'T->'U> -> _) f: '``Functor<Free<'Functor<'U>,'U>>``)
53+
| Pure f -> map<'T, 'U, 'Functor, '``Functor<Free<'Functor, 'T>>``, '``Functor<Free<'Functor, 'U>>``> f x : Free<'Functor, 'U>
54+
| Roll (f: ^``Functor<Free<'Functor, ('T -> 'U)>>``) -> Roll (Map.Invoke (loop x: Free<'Functor, ('T -> 'U)> -> _) f: '``Functor<Free<'Functor, 'U>>``)
5555
loop x f
5656

57-
let inline map2 (f: 'T->'U->'V) (x: Free<'``Functor<'T>``,'T>) (y: Free<'``Functor<'U>``,'U>) : Free<'``Functor<'V>``,'V> =
57+
let inline map2 (f: 'T->'U->'V) (x: Free<'Functor, 'T>) (y: Free<'Functor, 'U>) : Free<'Functor, 'V> =
5858
let rec loop (y: Free<_,_>) (x: Free<_,_>) =
5959
match run x with
60-
| Pure x -> map<'U,'V,'``Functor<'U>``,'``Functor<Free<'Functor<'U>,'U>>``,'``Functor<Free<'Functor<'V>,'V>>``,'``Functor<'V>``> (f x) y : Free<'``Functor<'V>``,'V>
61-
| Roll (x: ^``Functor<Free<'Functor<'T>,'T>>``) -> Roll (Map.Invoke (loop y: Free<'``Functor<'T>``,'T> -> _) x: '``Functor<Free<'Functor<'V>,'V>>``)
60+
| Pure x -> map<'U, 'V, 'Functor, '``Functor<Free<'Functor, 'U>>``, '``Functor<Free<'Functor, 'V>>``> (f x) y : Free<'Functor, 'V>
61+
| Roll (x: ^``Functor<Free<'Functor, 'T>>``) -> Roll (Map.Invoke (loop y: Free<'Functor, 'T> -> _) x: '``Functor<Free<'Functor, 'V>>``)
6262
loop y x
6363

64-
let inline map3 (f: 'T->'U->'V->'W) (x: Free<'``Functor<'T>``,'T>) (y: Free<'``Functor<'U>``,'U>) (z: Free<'``Functor<'V>``,'V>) : Free<'``Functor<'W>``,'W> =
64+
let inline map3 (f: 'T->'U->'V->'W) (x: Free<'Functor, 'T>) (y: Free<'Functor, 'U>) (z: Free<'Functor, 'V>) : Free<'Functor, 'W> =
6565
let rec loop (y: Free<_,_>) (x: Free<_,_>) (z: Free<_,_>) =
6666
match run x with
67-
| Pure x -> map2<'U,'V,'W,'``Functor<'U>``,'``Functor<Free<'Functor<'U>,'U>>``,'``Functor<Free<'Functor<'V>,'V>>``,'``Functor<Free<'Functor<'W>,'W>>``,'``Functor<'V>``,'``Functor<'W>``> (f x) y z : Free<'``Functor<'W>``,'W>
68-
| Roll (x: ^``Functor<Free<'Functor<'T>,'T>>``) -> Roll (Map.Invoke (loop y: Free<'``Functor<'T>``,'T> -> _) x: '``Functor<Free<'Functor<'W>,'W>>``)
67+
| Pure x -> map2<'U, 'V, 'W, 'Functor, '``Functor<Free<'Functor, 'U>>``, '``Functor<Free<'Functor, 'V>>``, '``Functor<Free<'Functor, 'W>>``> (f x) y z : Free<'Functor, 'W>
68+
| Roll (x: ^``Functor<Free<'Functor, 'T>>``) -> Roll (Map.Invoke (loop y: Free<'Functor, 'T> -> _) x: '``Functor<Free<'Functor, 'W>>``)
6969
loop y x z
7070

7171
/// Folds the Free structure into a Monad
72-
let inline fold (f: '``Functor<'T>`` -> '``Monad<'T>``) (x: Free<'``Functor<'U>``,'U>) : '``Monad<'U>`` =
72+
let inline fold (f: '``Functor<'T>`` -> '``Monad<'T>``) (x: Free<'Functor, 'U>) : '``Monad<'U>`` =
7373
let rec loop f x =
7474
match run x with
7575
| Pure a -> Return.Invoke a
7676
| Roll x -> f x >>= loop f
7777
loop f x
7878

7979
/// Tear down a Free monad using iteration.
80-
let inline iterM (f: '``Functor<'Monad<'T>>`` -> '``Monad<'T>``) (x: Free<'``Functor<'T>``,'T>) : '``Monad<'T>`` =
80+
let inline iterM (f: '``Functor<'Monad<'T>>`` -> '``Monad<'T>``) (x: Free<'Functor, 'T>) : '``Monad<'T>`` =
8181
let rec loop f x =
8282
match run x with
8383
| Pure x -> Return.Invoke x
84-
| Roll (x: ^``Functor<Free<'Functor<'T>,'T>>``) -> f (loop f <!> x)
84+
| Roll (x: ^``Functor<Free<'Functor, 'T>>``) -> f (loop f <!> x)
8585
loop f x
8686

8787
/// Lift any Functor into a Free structure
88-
let inline liftF (x: '``Functor<'T>``) : Free<'``Functor<'T>``,'T> = Roll (Map.Invoke (Pure: 'T -> Free<'``Functor<'T>``,'T>) x : '``Functor<Free<'Functor<'T>,'T>>``)
88+
let inline liftF (x: '``Functor<'T>``) : Free<'Functor, 'T> = Roll (Map.Invoke (Pure: 'T -> Free<'Functor, 'T>) x : '``Functor<Free<'Functor, 'T>>``)
8989

9090

91-
type Free<'``functor<'t>``,'t> with
91+
type Free<'functor, 't> with
9292

9393
[<EditorBrowsable(EditorBrowsableState.Never)>]
94-
static member inline Map (x: Free<'``Functor<'T>``,'T>, f: 'T -> 'U) = Free.map f x : Free<'``Functor<'U>``,'U>
94+
static member inline Map (x: Free<'Functor, 'T>, f: 'T -> 'U) = Free.map f x : Free<'Functor, 'U>
9595

9696
static member Return x = Pure x
97-
static member inline (>>=) (x: Free<'``Functor<'T>``,'T>, f: 'T -> Free<'``Functor<'U>``,'U>) = Free.bind f x : Free<'``Functor<'U>``,'U>
98-
static member inline (<*>) (f: Free<'``Functor<'T->'U>``,'T->'U>, x: Free<'``Functor<'T>``,'T>) = Free.apply f x : Free<'``Functor<'U>``,'U>
97+
static member inline (>>=) (x: Free<'Functor, 'T>, f: 'T -> Free<'Functor, 'U>) = Free.bind f x : Free<'Functor, 'U>
98+
static member inline (<*>) (f: Free<'Functor, ('T -> 'U)>, x: Free<'Functor, 'T>) = Free.apply f x : Free<'Functor, 'U>
9999

100100
[<EditorBrowsable(EditorBrowsableState.Never)>]
101-
static member inline Lift2 (f, x: Free<'``Functor<'T>``,'T>, y: Free<'``Functor<'U>``,'U>) = Free.map2 f x y: Free<'``Functor<'V>``,'V>
101+
static member inline Lift2 (f, x: Free<'Functor, 'T>, y: Free<'Functor, 'U>) = Free.map2 f x y: Free<'Functor, 'V>
102102

103103
[<EditorBrowsable(EditorBrowsableState.Never)>]
104-
static member inline Lift3 (f, x: Free<'``Functor<'T>``,'T>, y: Free<'``Functor<'U>``,'U>, z: Free<'``Functor<'V>``,'V>) = Free.map3 f x y z: Free<'``Functor<'W>``,'W>
104+
static member inline Lift3 (f, x: Free<'Functor, 'T>, y: Free<'Functor, 'U>, z: Free<'Functor, 'V>) = Free.map3 f x y z: Free<'Functor, 'W>
105105

106-
static member Delay (x: unit -> Free<'``Functor<'T>``,'T>) = x ()
106+
static member Delay (x: unit -> Free<'Functor, 'T>) = x ()
107107

108108
#endif

‎tests/FSharpPlus.Tests/Free.fs

+4-4
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,7 @@ module Sample1 =
3838
| Get (k, c) -> Get (k, c >> f)
3939
| Set (k, v, c) -> Set (k, v, f c )
4040

41-
type FreeDSL<'a> = Free<DSL<'a>,'a>
41+
type FreeDSL<'a> = Free<DSL<__>,'a>
4242

4343
let ex1 = Set ("alma", "bela", (Get ("alma", id)))
4444
let exF1 = Roll (Set ("alma", "bela", (Roll (Get ("alma", (fun s -> Pure s))))))
@@ -173,7 +173,7 @@ module Sample3 =
173173
| GetSlots (x, next) -> GetSlots (x, next >> f)
174174
| PostReservation (x, next) -> PostReservation (x, next |> f)
175175

176-
type Program<'t> = Free<Coproduct<CommandLineInstruction<'t>, ReservationsApiInstruction<'t>>,'t>
176+
type Program<'t> = Free<Coproduct<CommandLineInstruction<__>, ReservationsApiInstruction<__>, __>, 't>
177177

178178

179179
let readLine = (Free.liftF << InL) (ReadLine id) : Program<_>
@@ -264,7 +264,7 @@ module TestCoproduct =
264264
let a36 = map string a31
265265
let a37 = map string a32
266266

267-
let a41 = InL [3] : Coproduct<_,_ list>
267+
let a41 = InL [3] : Coproduct<_,__ list, _>
268268
let a42 = map ((+)10 >> string) a41
269269

270270
open Sample3
@@ -291,7 +291,7 @@ module Fold =
291291
match instruction with
292292
| Read (id, next) -> Read(id, next >> f)
293293

294-
type Program<'a> = Free<Instruction<'a>, 'a>
294+
type Program<'a> = Free<Instruction<__>, 'a>
295295

296296
let read fooId = Read(fooId, id) |> Free.liftF
297297

0 commit comments

Comments
 (0)