Lightweight HKT Encoding

Lightweight HKT encoding using a tiny amount of SRTP constraint solving for assigning the encoding to underlying types

Core Definition

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25:

type HKT = interface end

//[Struct] no F# 4.1 in ffsnip!
type App<'F, 't when 'F :> HKT> = private App of payload : obj

type App<'F, 't1, 't2 when 'F :> HKT> = App<'F, TCons<'t1, 't2>>
and  App<'F, 't1, 't2, 't3 when 'F :> HKT> = App<'F, TCons<'t1, 't2, 't3>>
and  App<'F, 't1, 't2, 't3, 't4 when 'F :> HKT> = App<'F, TCons<'t1, 't2, 't3, 't4>>

and  TCons<'T1, 'T2> = class end
and  TCons<'T1, 'T2, 'T3> = TCons<TCons<'T1, 'T2>, 'T3>
and  TCons<'T1, 'T2, 'T3, 'T4> = TCons<TCons<'T1, 'T2, 'T3>, 'T4>

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module HKT =
    let inline pack (value : 'Fa) : App<'F, 'a>
        when 'F : (static member Assign : App<'F, 'a> * 'Fa -> unit) =
        App value
        
    let inline unpack (App value : App<'F, 'a>) : 'Fa
        when 'F : (static member Assign : App<'F, 'a> * 'Fa -> unit) =
        value :?> _
        
    // active pattern variant useful for method definitions
    let inline (|Unpack|) app = unpack app

Pair Example

1: 
2: 
3: 
4: 
5: 
6: 
7: 
8:

type Pair =
    interface HKT
    // method signature associates HKT encoding with underlying type
    // to be picked up by SRTP constraint solver
    static member Assign(_ : App<Pair,'a, 'b>, _ : 'a * 'b) = ()

let packed : App<Pair,_,_> = HKT.pack ("foo", 42)
let unpacked = HKT.unpack packed

Functor Example

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23:

type Functor<'F when 'F :> Functor<'F> and 'F : struct> =
    inherit HKT
    abstract Fmap : ('a -> 'b) -> App<'F, 'a> -> App<'F, 'b>

let fmap f x : App<'F, 'b> when 'F :> Functor<'F> = Unchecked.defaultof<'F>.Fmap f x

let incrementAndSquare xs =
    xs 
    |> fmap (fun i -> i + 1)
    |> fmap (fun i -> i * i)

[<Struct>]
type List =
    // associate App<List, 'a> to 'a list
    static member Assign(_ : App<List, 'a>, _ : 'a list) = ()

    interface Functor<List> with
        member __.Fmap f (HKT.Unpack xs) = HKT.pack (List.map f xs)


let packedList = HKT.pack [1 .. 10] : App<List,_>
let packedList' = packedList |> incrementAndSquare |> fmap (fun i -> i.ToString())
let unpackedList' = HKT.unpack packedList'

Multiple items
union case App.App: payload: obj -> App<'F,'t>

--------------------
type App<'F,'t (requires 'F :> HKT)> = private | App of payload: obj

Full name: Script.App<_,_>

type HKT

Full name: Script.HKT

type obj = System.Object

Full name: Microsoft.FSharp.Core.obj

type TCons<'T1,'T2>

Full name: Script.TCons<_,_>

Multiple items
type CompilationRepresentationAttribute =
  inherit Attribute
  new : flags:CompilationRepresentationFlags -> CompilationRepresentationAttribute
  member Flags : CompilationRepresentationFlags

Full name: Microsoft.FSharp.Core.CompilationRepresentationAttribute

--------------------
new : flags:CompilationRepresentationFlags -> CompilationRepresentationAttribute

CompilationRepresentationFlags.ModuleSuffix: CompilationRepresentationFlags = 4

val pack : value:'Fa -> App<'F,'a> (requires 'F :> HKT and member Assign)

Full name: Script.HKTModule.pack

val value : 'Fa

type unit = Unit

Full name: Microsoft.FSharp.Core.unit

val unpack : App<'F,'a> -> 'Fa (requires 'F :> HKT and member Assign)

Full name: Script.HKTModule.unpack

val value : obj

val app : App<'a,'b> (requires 'a :> HKT and member Assign)

type Pair =
interface HKT
static member Assign : App<Pair,'a,'b> * ('a * 'b) -> unit

Full name: Script.Pair

Multiple items
module HKT

from Script

--------------------
type HKT

Full name: Script.HKT

static member Pair.Assign : App<Pair,'a,'b> * ('a * 'b) -> unit

Full name: Script.Pair.Assign

val packed : App<Pair,string,int>

Full name: Script.packed

val unpacked : string * int

Full name: Script.unpacked

type Functor<'F (requires 'F :> Functor<'F> and value type)> =
  interface
    inherit HKT
    abstract member Fmap : ('a -> 'b) -> App<'F,'a> -> App<'F,'b>
  end

Full name: Script.Functor<_>

abstract member Functor.Fmap : ('a -> 'b) -> App<'F,'a> -> App<'F,'b>

Full name: Script.Functor`1.Fmap

val fmap : f:('a -> 'b) -> x:App<'F,'a> -> App<'F,'b> (requires 'F :> Functor<'F> and value type)

Full name: Script.fmap

val f : ('a -> 'b)

val x : App<'F,'a> (requires 'F :> Functor<'F> and value type)

module Unchecked

from Microsoft.FSharp.Core.Operators

val defaultof<'T> : 'T

Full name: Microsoft.FSharp.Core.Operators.Unchecked.defaultof

val incrementAndSquare : xs:App<'a,int> -> App<'a,int> (requires 'a :> Functor<'a> and value type)

Full name: Script.incrementAndSquare

val xs : App<'a,int> (requires 'a :> Functor<'a> and value type)

val i : int

Multiple items
type StructAttribute =
inherit Attribute
new : unit -> StructAttribute

Full name: Microsoft.FSharp.Core.StructAttribute

--------------------
new : unit -> StructAttribute

Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List =
  struct
    interface Functor<List>
    static member Assign : App<List,'a> * 'a list -> unit
  end

Full name: Script.List

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member GetSlice : startIndex:int option * endIndex:int option -> 'T list
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>

static member List.Assign : App<List,'a> * 'a list -> unit

Full name: Script.List.Assign

type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>

override List.Fmap : f:('a -> 'b) -> App<List,'a> -> App<List,'b>

Full name: Script.List.Fmap

active recognizer Unpack: App<'a,'b> -> 'c

Full name: Script.HKTModule.( |Unpack| )

val xs : 'a list

val map : mapping:('T -> 'U) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.map

val packedList : App<List,int>

Full name: Script.packedList

val packedList' : App<List,string>

Full name: Script.packedList'

System.Int32.ToString() : string
System.Int32.ToString(provider: System.IFormatProvider) : string
System.Int32.ToString(format: string) : string
System.Int32.ToString(format: string, provider: System.IFormatProvider) : string

val unpackedList' : string list

Full name: Script.unpackedList'

Previous Version Raw view Test code New version

More information

Link:	http://fssnip.net/7Wy
Posted:	5 years ago
Author:	Eirik Tsarpalis
Tags:	higher-kinded types