TypeclassopediaFable

TypeclassopediaFable.fs

module TypeclassopediaFable

// --- HKT core (blog version) ---
type App<'F,'t> = App of obj

module HKT =
    let inline private assoc<'F,'a,'Fa
        when 'F : (static member Assign : App<'F,'a> * 'Fa -> unit)> = ()
    let inline pack (value:'Fa) : App<'F,'a> = assoc<'F,'a,'Fa> ; App value
    let inline unpack (App v : App<'F,'a>) : 'Fa = assoc<'F,'a,'Fa> ; unbox v
    let inline (|Unpack|) x = unpack x

// --- SRTP dispatcher (tupled) ---
let inline fmap< ^F,'a,'b
    when ^F : (static member Fmap : ('a -> 'b) * App< ^F,'a> -> App< ^F,'b>)>
    (f:'a -> 'b) (xs: App< ^F,'a>) : App< ^F,'b> =
    ((^F) : (static member Fmap : _ * _ -> _) (f, xs))

// Repeat the constraint on callers too
let inline incrSqr< ^F
    when ^F : (static member Fmap : (int -> int) * App< ^F,int> -> App< ^F,int>)>
    (x: App< ^F,int>) =
    x |> fmap< ^F,_,_> ((+) 1) |> fmap< ^F,_,_> ((*) 2)

// --- Brands (tupled Fmap) ---
[<Struct>]
type ListF =
    static member Assign (_: App<ListF,'a>, _: 'a list) = ()
    static member Fmap (f: 'a->'b, HKT.Unpack xs : App<ListF,'a>) : App<ListF,'b> =
        HKT.pack (Microsoft.FSharp.Collections.List.map f xs)

[<Struct>]
type OptionF =
    static member Assign (_: App<OptionF,'a>, _: 'a option) = ()
    static member Fmap (f: 'a->'b, HKT.Unpack xo : App<OptionF,'a>) : App<OptionF,'b> =
        HKT.pack (Option.map f xo)

// --- Usage ---
let lst  : App<ListF,_>   = HKT.pack [1;2;3;4]
let opt  : App<OptionF,_> = HKT.pack (Some 10)

incrSqr<ListF> lst |> HKT.unpack  |> printf "%A"  // [4;6;8;10]
incrSqr<OptionF> opt |> HKT.unpack |> printf "%A" // Some 22