Skip to content

Commit

Permalink
HKTize Free and Coproduct
Browse files Browse the repository at this point in the history
  • Loading branch information
@gusty
gusty committed Jul 11, 2022
1 parent f5425df commit 4b8ad06
Show file tree
Hide file tree
Showing 3 changed files with 100 additions and 51 deletions.
83 changes: 66 additions & 17 deletions src/FSharpPlus/Data/Coproduct.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,39 +4,88 @@

open FSharpPlus
open FSharpPlus.Control
open FSharpPlus.Internals.Prelude


[<AbstractClass>]
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<[<EqualityConditionalOn>]'``functorL<'t>``,'``functorR<'t>``> (left: '``functorL<'t>``, right: '``functorR<'t>``, isLeft: bool) =
inherit CoproductBase<'``functorL<'t>``,'``functorR<'t>``> (left, right, isLeft)
type CoproductL<[<EqualityConditionalOn>]'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) =
inherit CoproductBase<'functorL, 'functorR, 't> (left, right, isLeft)

type CoproductR<[<EqualityConditionalOn>]'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) =
inherit CoproductL<'functorL, 'functorR, 't> (left, right, isLeft)

type Coproduct<[<EqualityConditionalOn>]'functorL, 'functorR, 't> (left: obj, right: obj, isLeft: bool) =
inherit CoproductR<'functorL, 'functorR, 't> (left, right, isLeft)

[<AutoOpen>]
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
[<GeneralizableValue>]
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)

[<GeneralizableValue>]
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
60 changes: 30 additions & 30 deletions src/FSharpPlus/Data/Free.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,99 +10,99 @@ open FSharpPlus.Internals.Prelude


[<NoComparison>]
type Free<'``functor<'t>``,'t> = Pure of 't | Roll of obj
type Free<'functor, 't> = Pure of 't | Roll of obj

[<AutoOpen>]
module FreePrimitives =
let inline Roll (f: '``Functor<Free<'Functor<'T>,'T>>``) : Free<'``Functor<'T>``,'T> =
let inline Roll (f: '``Functor<Free<'Functor, 'T>>``) : 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
[<RequireQualifiedAccess>]
module Free =

let inline run (f: Free<'``Functor<'T>``,'T>) : Choice<_,'``Functor<Free<'Functor<'T>,'T>>``> =
let inline run (f: Free<'Functor, 'T>) : Choice<_, '``Functor<Free<'Functor, 'T>>``> =
if opaqueId false then
let (_: ^``Functor<Free<'Functor<'T>,'T>>``) = Map.Invoke (fun (_: 'T) -> Unchecked.defaultof<Free<'``Functor<'T>``,'T>>) Unchecked.defaultof<'``Functor<'T>``>
let (_: ^``Functor<Free<'Functor, 'T>>``) = Map.Invoke (fun (_: __) -> Unchecked.defaultof<Free<'Functor, 'T>>) 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<Free<'Functor<'T>,'T>>``) -> Roll (Map.Invoke (loop f : Free<'``Functor<'T>``,'T> -> _) x: ^``Functor<Free<'Functor<'U>,'U>>``)
| Roll (x: ^``Functor<Free<'Functor, 'T>>``) -> Roll (Map.Invoke (loop f : Free<'Functor, 'T> -> _) x: ^``Functor<Free<'Functor, 'U>>``)
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<Free<'Functor<'T>,'T>>``) -> Roll (Map.Invoke (loop f : Free<'``Functor<'T>``,'T> -> _) x: ^``Functor<Free<'Functor<'U>,'U>>``) : Free<'``Functor<'U>``,'U>
| Roll (x: ^``Functor<Free<'Functor, 'T>>``) -> Roll (Map.Invoke (loop f : Free<'Functor, 'T> -> _) x: ^``Functor<Free<'Functor, 'U>>``) : 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<Free<'Functor<'T>,'T>>``,'``Functor<Free<'Functor<'U>,'U>>``,'``Functor<'U>``> f x : Free<'``Functor<'U>``,'U>
| 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>>``)
| Pure f -> map<'T, 'U, 'Functor, '``Functor<Free<'Functor, 'T>>``, '``Functor<Free<'Functor, 'U>>``> f x : Free<'Functor, 'U>
| Roll (f: ^``Functor<Free<'Functor, ('T -> 'U)>>``) -> Roll (Map.Invoke (loop x: Free<'Functor, ('T -> 'U)> -> _) f: '``Functor<Free<'Functor, 'U>>``)
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<Free<'Functor<'U>,'U>>``,'``Functor<Free<'Functor<'V>,'V>>``,'``Functor<'V>``> (f x) y : Free<'``Functor<'V>``,'V>
| Roll (x: ^``Functor<Free<'Functor<'T>,'T>>``) -> Roll (Map.Invoke (loop y: Free<'``Functor<'T>``,'T> -> _) x: '``Functor<Free<'Functor<'V>,'V>>``)
| Pure x -> map<'U, 'V, 'Functor, '``Functor<Free<'Functor, 'U>>``, '``Functor<Free<'Functor, 'V>>``> (f x) y : Free<'Functor, 'V>
| Roll (x: ^``Functor<Free<'Functor, 'T>>``) -> Roll (Map.Invoke (loop y: Free<'Functor, 'T> -> _) x: '``Functor<Free<'Functor, 'V>>``)
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<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>
| Roll (x: ^``Functor<Free<'Functor<'T>,'T>>``) -> Roll (Map.Invoke (loop y: Free<'``Functor<'T>``,'T> -> _) x: '``Functor<Free<'Functor<'W>,'W>>``)
| 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>
| Roll (x: ^``Functor<Free<'Functor, 'T>>``) -> Roll (Map.Invoke (loop y: Free<'Functor, 'T> -> _) x: '``Functor<Free<'Functor, 'W>>``)
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
| Roll x -> f x >>= loop f
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<Free<'Functor<'T>,'T>>``) -> f (loop f <!> x)
| Roll (x: ^``Functor<Free<'Functor, 'T>>``) -> 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<Free<'Functor<'T>,'T>>``)
let inline liftF (x: '``Functor<'T>``) : Free<'Functor, 'T> = Roll (Map.Invoke (Pure: 'T -> Free<'Functor, 'T>) x : '``Functor<Free<'Functor, 'T>>``)


type Free<'``functor<'t>``,'t> with
type Free<'functor, 't> with

[<EditorBrowsable(EditorBrowsableState.Never)>]
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>

[<EditorBrowsable(EditorBrowsableState.Never)>]
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>

[<EditorBrowsable(EditorBrowsableState.Never)>]
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
8 changes: 4 additions & 4 deletions tests/FSharpPlus.Tests/Free.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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<DSL<'a>,'a>
type FreeDSL<'a> = Free<DSL<__>,'a>

let ex1 = Set ("alma", "bela", (Get ("alma", id)))
let exF1 = Roll (Set ("alma", "bela", (Roll (Get ("alma", (fun s -> Pure s))))))
Expand Down Expand Up @@ -173,7 +173,7 @@ module Sample3 =
| GetSlots (x, next) -> GetSlots (x, next >> f)
| PostReservation (x, next) -> PostReservation (x, next |> f)

type Program<'t> = Free<Coproduct<CommandLineInstruction<'t>, ReservationsApiInstruction<'t>>,'t>
type Program<'t> = Free<Coproduct<CommandLineInstruction<__>, ReservationsApiInstruction<__>, __>, 't>


let readLine = (Free.liftF << InL) (ReadLine id) : Program<_>
Expand Down Expand Up @@ -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
Expand All @@ -291,7 +291,7 @@ module Fold =
match instruction with
| Read (id, next) -> Read(id, next >> f)

type Program<'a> = Free<Instruction<'a>, 'a>
type Program<'a> = Free<Instruction<__>, 'a>

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

Expand Down

0 comments on commit 4b8ad06

Please sign in to comment.