From 983bd8c657c41c558a4de795367823e018bd0c07 Mon Sep 17 00:00:00 2001 From: Gusty <1261319+gusty@users.noreply.github.com> Date: Sun, 10 Jul 2022 23:39:46 +0200 Subject: [PATCH] HKTize Free and Coproduct --- src/FSharpPlus/Data/Coproduct.fs | 83 +++++++++++++++++++++++++------- src/FSharpPlus/Data/Free.fs | 60 +++++++++++------------ tests/FSharpPlus.Tests/Free.fs | 8 +-- 3 files changed, 100 insertions(+), 51 deletions(-) diff --git a/src/FSharpPlus/Data/Coproduct.fs b/src/FSharpPlus/Data/Coproduct.fs index 62fb43fee..1d7ab6808 100644 --- a/src/FSharpPlus/Data/Coproduct.fs +++ b/src/FSharpPlus/Data/Coproduct.fs @@ -4,39 +4,88 @@ open FSharpPlus open FSharpPlus.Control +open FSharpPlus.Internals.Prelude [] -type CoproductBase<'``functorL<'t>``,'``functorR<'t>``> (left: '``functorL<'t>``, right: '``functorR<'t>``, isLeft: bool) = +type CoproductBase<'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) = let (left, right, isLeft) = left, right, isLeft with member __.getContents () = left, right, isLeft override x.GetHashCode () = Unchecked.hash (x.getContents ()) override x.Equals o = match o with - | :? CoproductBase<'``functorL<'t>``,'``functorR<'t>``> as y -> Unchecked.equals (x.getContents ()) (y.getContents ()) + | :? CoproductBase<'functorL, 'functorR, 't> as y -> Unchecked.equals (x.getContents ()) (y.getContents ()) | _ -> false -type Coproduct<[]'``functorL<'t>``,'``functorR<'t>``> (left: '``functorL<'t>``, right: '``functorR<'t>``, isLeft: bool) = - inherit CoproductBase<'``functorL<'t>``,'``functorR<'t>``> (left, right, isLeft) +type CoproductL<[]'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) = + inherit CoproductBase<'functorL, 'functorR, 't> (left, right, isLeft) + +type CoproductR<[]'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) = + inherit CoproductL<'functorL, 'functorR, 't> (left, right, isLeft) + +type Coproduct<[]'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) = + inherit CoproductR<'functorL, 'functorR, 't> (left, right, isLeft) [] module CoproductPrimitives = - let InL x = Coproduct<'``functorL<'t>``,'``functorR<'t>``> (x, Unchecked.defaultof<'``functorR<'t>``>, true) - let InR x = Coproduct<'``functorL<'t>``,'``functorR<'t>``> (Unchecked.defaultof<'``functorL<'t>``>, x, false) - let (|InL|InR|) (x: Coproduct<'``functorL<'t>``,'``functorR<'t>``>) = let (l, r, isL) = x.getContents () in if isL then InL l else InR r + [] + let inline InL (x: '``FunctorL<'T>``) : Coproduct<'FunctorL, 'FunctorR, 'T> = + if opaqueId false then + let (_: 'FunctorL) = Map.Invoke (fun (_: 'T) -> Unchecked.defaultof<__>) Unchecked.defaultof<'``FunctorL<'T>``> + () + Coproduct<'FunctorL, 'FunctorR, 'T> (box x, null, true) + + [] + let inline InR (x: '``FunctorR<'T>``) : Coproduct<'FunctorL, 'FunctorR, 'T> = + if opaqueId false then + let (_: 'FunctorR) = Map.Invoke (fun (_: 'T) -> Unchecked.defaultof<__>) Unchecked.defaultof<'``FunctorR<'T>``> + () + Coproduct<'FunctorL, 'FunctorR, 'T> (null, box x, false) + + + let inline (|InL|InR|) (x: Coproduct<'FunctorL, 'FunctorR, 'T>) : Choice<'``FunctorL<'T>``, '``FunctorR<'T>``> = + if opaqueId false then + let (_: '``FunctorL<'T>``) = Map.Invoke (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorL> + let (_: '``FunctorR<'T>``) = Map.Invoke (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorR> + () + let (l, r, isL) = x.getContents () + if isL then InL (unbox<'``FunctorL<'T>``> l) + else InR (unbox<'``FunctorR<'T>``> r) -type CoproductBase<'``functorL<'t>``,'``functorR<'t>``> with - static member inline Map (x: CoproductBase<'``FunctorL<'T>``,'``FunctorR<'T>``>, f: 'T -> 'U) : Coproduct<'``FunctorL<'U>``,'``FunctorR<'U>``> = +type CoproductBase<'functorL, 'functorR, 't> with + static member inline Map (x: CoproductBase<'FunctorL, 'FunctorR, 'T>, f: 'T -> 'U) : Coproduct<'FunctorL, 'FunctorR, 'U> = let (l, r, isL) = x.getContents () - if isL then InL (Map.Invoke f l) - else InR (Map.Invoke f r) - -type Coproduct<'``functorL<'t>``,'``functorR<'t>``> with - static member inline Map (a: Coproduct<'``FunctorL<'T>``,'``FunctorR<'T>``>, f: 'T -> 'U) : Coproduct<'``FunctorL<'U>``,'``FunctorR<'U>``> = - let (l, r, isL) = a.getContents () - if isL then InL (Map.InvokeOnInstance f l) - else InR (Map.InvokeOnInstance f r) + if isL then InL (Map.Invoke f (unbox l: '``FunctorL<'T>``) : '``FunctorL<'U>``) + else InR (Map.Invoke f (unbox r: '``FunctorR<'T>``) : '``FunctorR<'U>``) + +type CoproductL<'functorL, 'functorR, 't> with + static member inline Map (x: CoproductL<'FunctorL, 'FunctorR, 'T>, f: 'T -> 'U) : Coproduct<'FunctorL, 'FunctorR, 'U> = + let inline _CXs (_: '``FunctorL<'T>``* '``FunctorR<'T>``) = + let (_: '``FunctorR<'T>``) = Map.InvokeOnInstance (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorR> + () + let (l, r, isL) = x.getContents () + if isL then InL (Map.Invoke f (unbox l: '``FunctorL<'T>``) : '``FunctorL<'U>``) + else Coproduct<_, _, _> (null, box (Map.InvokeOnInstance f (unbox r: '``FunctorR<'T>``) : ^``FunctorR<'U>`` ), false) + +type CoproductL<'functorL, 'functorR, 't> with + static member inline Map (x: CoproductL<'FunctorL, 'FunctorR, 'T>, f: 'T -> 'U) : Coproduct<'FunctorL, 'FunctorR, 'U> = + let inline _CXs (_: '``FunctorL<'T>``* '``FunctorR<'T>``) = + let (_: '``FunctorL<'T>``) = Map.InvokeOnInstance (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorL> + () + let (l, r, isL) = x.getContents () + if isL then Coproduct<_, _, _> (box (Map.InvokeOnInstance f (unbox l: '``FunctorL<'T>``) : ^``FunctorL<'U>`` ), null, true ) + else InR (Map.Invoke f (unbox r: '``FunctorR<'T>``) : '``FunctorR<'U>``) + +type Coproduct<'functorL, 'functorR, 't> with + static member inline Map (x: Coproduct<'FunctorL, 'FunctorR, 'T>, f: 'T -> 'U) : Coproduct<'FunctorL, 'FunctorR, 'U> = + let inline _CXs (_: '``FunctorL<'T>``* '``FunctorR<'T>``) = + let (_: '``FunctorL<'T>``) = Map.InvokeOnInstance (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorL> + let (_: '``FunctorR<'T>``) = Map.InvokeOnInstance (fun (_: __) -> Unchecked.defaultof<'T>) Unchecked.defaultof<'FunctorR> + () + let (l, r, isL) = x.getContents () + if isL then Coproduct<_, _, _> (box (Map.InvokeOnInstance f (unbox l: '``FunctorL<'T>``) : ^``FunctorL<'U>`` ), null, true ) + else Coproduct<_, _, _> (null, box (Map.InvokeOnInstance f (unbox r: '``FunctorR<'T>``) : ^``FunctorR<'U>`` ), false) #endif \ No newline at end of file diff --git a/src/FSharpPlus/Data/Free.fs b/src/FSharpPlus/Data/Free.fs index 4a9f13b63..04a4d45e2 100644 --- a/src/FSharpPlus/Data/Free.fs +++ b/src/FSharpPlus/Data/Free.fs @@ -10,66 +10,66 @@ open FSharpPlus.Internals.Prelude [] -type Free<'``functor<'t>``,'t> = Pure of 't | Roll of obj +type Free<'functor, 't> = Pure of 't | Roll of obj [] module FreePrimitives = - let inline Roll (f: '``Functor,'T>>``) : Free<'``Functor<'T>``,'T> = + let inline Roll (f: '``Functor>``) : Free<'Functor, 'T> = if opaqueId false then - let (_: '``Functor<'T>``) = Map.Invoke (fun (_: Free<'``Functor<'T>``,'T>) -> Unchecked.defaultof<'T>) f + let (_: 'Functor) = Map.Invoke (fun (_: Free<'Functor, 'T>) -> Unchecked.defaultof<__>) f () - Free<'``Functor<'T>``,'T>.Roll f + Free<'Functor, 'T>.Roll f let (|Pure|Roll|) x = match x with Choice1Of2 x -> Pure x | Choice2Of2 x -> Roll x /// Basic operations on Free Monads [] module Free = - let inline run (f: Free<'``Functor<'T>``,'T>) : Choice<_,'``Functor,'T>>``> = + let inline run (f: Free<'Functor, 'T>) : Choice<_, '``Functor>``> = if opaqueId false then - let (_: ^``Functor,'T>>``) = Map.Invoke (fun (_: 'T) -> Unchecked.defaultof``,'T>>) Unchecked.defaultof<'``Functor<'T>``> + let (_: ^``Functor>``) = Map.Invoke (fun (_: __) -> Unchecked.defaultof>) Unchecked.defaultof<'Functor> () match f with | Free.Pure x -> Choice1Of2 x | Free.Roll x -> let x = unbox x in Choice2Of2 x let inline map f x = - let rec loop (f: 'T->'U) (x: Free<'``Functor<'T>``,'T>) : Free<'``Functor<'U>``,'U> = + let rec loop (f: 'T->'U) (x: Free<'Functor, 'T>) : Free<'Functor, 'U> = match run x with | Pure x -> Pure (f x) - | Roll (x: ^``Functor,'T>>``) -> Roll (Map.Invoke (loop f : Free<'``Functor<'T>``,'T> -> _) x: ^``Functor,'U>>``) + | Roll (x: ^``Functor>``) -> Roll (Map.Invoke (loop f : Free<'Functor, 'T> -> _) x: ^``Functor>``) loop f x - let inline bind (f: 'T -> Free<'``Functor<'U>``,'U>) (x: Free<'``Functor<'T>``,'T>) : Free<'``Functor<'U>``,'U> = + let inline bind (f: 'T -> Free<'Functor, 'U>) (x: Free<'Functor, 'T>) : Free<'Functor, 'U> = let rec loop f (x: Free<_,_>) = match run x with | Pure r -> f r - | Roll (x: ^``Functor,'T>>``) -> Roll (Map.Invoke (loop f : Free<'``Functor<'T>``,'T> -> _) x: ^``Functor,'U>>``) : Free<'``Functor<'U>``,'U> + | Roll (x: ^``Functor>``) -> Roll (Map.Invoke (loop f : Free<'Functor, 'T> -> _) x: ^``Functor>``) : Free<'Functor, 'U> loop f x - let inline apply (f: Free<'``Functor<'T->'U>``,'T->'U>) (x: Free<'``Functor<'T>``,'T>) : Free<'``Functor<'U>``,'U> = + let inline apply (f: Free<'Functor, 'T->'U>) (x: Free<'Functor, 'T>) : Free<'Functor, 'U> = let rec loop (x: Free<_,_>) (f: Free<_,_>) = match run f with - | Pure f -> map<'T,'U,'``Functor<'T>``,'``Functor,'T>>``,'``Functor,'U>>``,'``Functor<'U>``> f x : Free<'``Functor<'U>``,'U> - | Roll (f: ^``Functor'U>,'T->'U>>``) -> Roll (Map.Invoke (loop x: Free<'``Functor<'T->'U>``,'T->'U> -> _) f: '``Functor,'U>>``) + | Pure f -> map<'T, 'U, 'Functor, '``Functor>``, '``Functor>``> f x : Free<'Functor, 'U> + | Roll (f: ^``Functor 'U)>>``) -> Roll (Map.Invoke (loop x: Free<'Functor, ('T -> 'U)> -> _) f: '``Functor>``) loop x f - let inline map2 (f: 'T->'U->'V) (x: Free<'``Functor<'T>``,'T>) (y: Free<'``Functor<'U>``,'U>) : Free<'``Functor<'V>``,'V> = + let inline map2 (f: 'T->'U->'V) (x: Free<'Functor, 'T>) (y: Free<'Functor, 'U>) : Free<'Functor, 'V> = let rec loop (y: Free<_,_>) (x: Free<_,_>) = match run x with - | Pure x -> map<'U,'V,'``Functor<'U>``,'``Functor,'U>>``,'``Functor,'V>>``,'``Functor<'V>``> (f x) y : Free<'``Functor<'V>``,'V> - | Roll (x: ^``Functor,'T>>``) -> Roll (Map.Invoke (loop y: Free<'``Functor<'T>``,'T> -> _) x: '``Functor,'V>>``) + | Pure x -> map<'U, 'V, 'Functor, '``Functor>``, '``Functor>``> (f x) y : Free<'Functor, 'V> + | Roll (x: ^``Functor>``) -> Roll (Map.Invoke (loop y: Free<'Functor, 'T> -> _) x: '``Functor>``) loop y x - 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> = + let inline map3 (f: 'T->'U->'V->'W) (x: Free<'Functor, 'T>) (y: Free<'Functor, 'U>) (z: Free<'Functor, 'V>) : Free<'Functor, 'W> = let rec loop (y: Free<_,_>) (x: Free<_,_>) (z: Free<_,_>) = match run x with - | Pure x -> map2<'U,'V,'W,'``Functor<'U>``,'``Functor,'U>>``,'``Functor,'V>>``,'``Functor,'W>>``,'``Functor<'V>``,'``Functor<'W>``> (f x) y z : Free<'``Functor<'W>``,'W> - | Roll (x: ^``Functor,'T>>``) -> Roll (Map.Invoke (loop y: Free<'``Functor<'T>``,'T> -> _) x: '``Functor,'W>>``) + | Pure x -> map2<'U, 'V, 'W, 'Functor, '``Functor>``, '``Functor>``, '``Functor>``> (f x) y z : Free<'Functor, 'W> + | Roll (x: ^``Functor>``) -> Roll (Map.Invoke (loop y: Free<'Functor, 'T> -> _) x: '``Functor>``) loop y x z /// Folds the Free structure into a Monad - let inline fold (f: '``Functor<'T>`` -> '``Monad<'T>``) (x: Free<'``Functor<'U>``,'U>) : '``Monad<'U>`` = + let inline fold (f: '``Functor<'T>`` -> '``Monad<'T>``) (x: Free<'Functor, 'U>) : '``Monad<'U>`` = let rec loop f x = match run x with | Pure a -> Return.Invoke a @@ -77,32 +77,32 @@ module Free = loop f x /// Tear down a Free monad using iteration. - let inline iterM (f: '``Functor<'Monad<'T>>`` -> '``Monad<'T>``) (x: Free<'``Functor<'T>``,'T>) : '``Monad<'T>`` = + let inline iterM (f: '``Functor<'Monad<'T>>`` -> '``Monad<'T>``) (x: Free<'Functor, 'T>) : '``Monad<'T>`` = let rec loop f x = match run x with | Pure x -> Return.Invoke x - | Roll (x: ^``Functor,'T>>``) -> f (loop f x) + | Roll (x: ^``Functor>``) -> f (loop f x) loop f x /// Lift any Functor into a Free structure - let inline liftF (x: '``Functor<'T>``) : Free<'``Functor<'T>``,'T> = Roll (Map.Invoke (Pure: 'T -> Free<'``Functor<'T>``,'T>) x : '``Functor,'T>>``) + let inline liftF (x: '``Functor<'T>``) : Free<'Functor, 'T> = Roll (Map.Invoke (Pure: 'T -> Free<'Functor, 'T>) x : '``Functor>``) -type Free<'``functor<'t>``,'t> with +type Free<'functor, 't> with [] - static member inline Map (x: Free<'``Functor<'T>``,'T>, f: 'T -> 'U) = Free.map f x : Free<'``Functor<'U>``,'U> + static member inline Map (x: Free<'Functor, 'T>, f: 'T -> 'U) = Free.map f x : Free<'Functor, 'U> static member Return x = Pure x - static member inline (>>=) (x: Free<'``Functor<'T>``,'T>, f: 'T -> Free<'``Functor<'U>``,'U>) = Free.bind f x : Free<'``Functor<'U>``,'U> - static member inline (<*>) (f: Free<'``Functor<'T->'U>``,'T->'U>, x: Free<'``Functor<'T>``,'T>) = Free.apply f x : Free<'``Functor<'U>``,'U> + static member inline (>>=) (x: Free<'Functor, 'T>, f: 'T -> Free<'Functor, 'U>) = Free.bind f x : Free<'Functor, 'U> + static member inline (<*>) (f: Free<'Functor, ('T -> 'U)>, x: Free<'Functor, 'T>) = Free.apply f x : Free<'Functor, 'U> [] - static member inline Lift2 (f, x: Free<'``Functor<'T>``,'T>, y: Free<'``Functor<'U>``,'U>) = Free.map2 f x y: Free<'``Functor<'V>``,'V> + static member inline Lift2 (f, x: Free<'Functor, 'T>, y: Free<'Functor, 'U>) = Free.map2 f x y: Free<'Functor, 'V> [] - 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> + 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> - static member Delay (x: unit -> Free<'``Functor<'T>``,'T>) = x () + static member Delay (x: unit -> Free<'Functor, 'T>) = x () #endif \ No newline at end of file diff --git a/tests/FSharpPlus.Tests/Free.fs b/tests/FSharpPlus.Tests/Free.fs index f3e82cba1..5a5b08907 100644 --- a/tests/FSharpPlus.Tests/Free.fs +++ b/tests/FSharpPlus.Tests/Free.fs @@ -38,7 +38,7 @@ module Sample1 = | Get (k, c) -> Get (k, c >> f) | Set (k, v, c) -> Set (k, v, f c ) - type FreeDSL<'a> = Free,'a> + type FreeDSL<'a> = Free,'a> let ex1 = Set ("alma", "bela", (Get ("alma", id))) let exF1 = Roll (Set ("alma", "bela", (Roll (Get ("alma", (fun s -> Pure s)))))) @@ -173,7 +173,7 @@ module Sample3 = | GetSlots (x, next) -> GetSlots (x, next >> f) | PostReservation (x, next) -> PostReservation (x, next |> f) - type Program<'t> = Free, ReservationsApiInstruction<'t>>,'t> + type Program<'t> = Free, ReservationsApiInstruction<__>, __>, 't> let readLine = (Free.liftF << InL) (ReadLine id) : Program<_> @@ -264,7 +264,7 @@ module TestCoproduct = let a36 = map string a31 let a37 = map string a32 - let a41 = InL [3] : Coproduct<_,_ list> + let a41 = InL [3] : Coproduct<_,__ list, _> let a42 = map ((+)10 >> string) a41 open Sample3 @@ -291,7 +291,7 @@ module Fold = match instruction with | Read (id, next) -> Read(id, next >> f) - type Program<'a> = Free, 'a> + type Program<'a> = Free, 'a> let read fooId = Read(fooId, id) |> Free.liftF