1 people like it.

Applying the Tagless-Final pattern in F# Generic Programs

Example that combines generic programming using tagless-final and typeshape for driving folding of arbitrary types.

HKT Encoding

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 

type App<'F, 't> = App of payload : obj

module HKT =

    // associate HKT encoding to underlying type using SRTPs
    let inline private assoc<'F, 'a, 'Fa when 'F : (static member Assign : App<'F, 'a> * 'Fa -> unit)> = ()

    // pack and unpack functions
    let inline pack (value : 'Fa) : App<'F, 'a> = assoc<'F, 'a, 'Fa> ; App value
    let inline unpack (App value : App<'F, 'a>) : 'Fa = assoc<'F, 'a, 'Fa> ; unbox value
        
    // helper active pattern
    let inline (|Unpack|) app = unpack app

Tagless-Final Generic Programming

 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: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 

type ITypeBuilder<'F> =
    // primitives
    abstract Bool : unit -> App<'F, bool>
    abstract Int : unit -> App<'F, int>
    abstract String : unit -> App<'F, string>
    // combinators
    abstract Option : App<'F, 't> -> App<'F, 't option>
    abstract List : App<'F, 't> -> App<'F, 't list>
    abstract Tuple : App<'F, 't1> -> App<'F, 't2> -> App<'F, 't1 * 't2>

let inline private inst() : 'F when 'F :> ITypeBuilder<'F> = new 'F()
let bool () = inst().Bool()
let int () = inst().Int()
let string () = inst().String()
let option t = inst().Option t
let list t = inst().List t
let tuple t = inst().Tuple t

let sample () = int () |> list |> option |> tuple (bool ())

//[snippet:TypeShape driven folding]
let rec fold<'F, 't when 'F :> ITypeBuilder<'F> and 'F : (new : unit -> 'F)> () : App<'F, 't> =
    let wrap (x : App<'F,_>) : App<'F, 't> = unbox x
    match shapeof<'t> with
    | Shape.Bool -> bool() |> wrap
    | Shape.Int32 -> int() |> wrap
    | Shape.String -> string() |> wrap
    | Shape.FSharpOption s ->
        s.Element.Accept {
            new ITypeVisitor<App<'F, 't>> with
                member __.Visit<'e> () =
                    let e = fold<'F, 'e>()
                    option e |> wrap
        }

    | Shape.FSharpList s ->
        s.Element.Accept {
            new ITypeVisitor<App<'F, 't>> with
                member __.Visit<'e> () =
                    let e = fold<'F, 'e>()
                    list e |> wrap
        }

    | Shape.Tuple s when s.Elements.Length = 2 ->
        let ls = s.Elements.[0].Member
        let rs = s.Elements.[1].Member
        ls.Accept {
            new ITypeVisitor<App<'F, 't>> with
                member __.Visit<'l> () =
                    rs.Accept {
                        new ITypeVisitor<App<'F, 't>> with
                            member __.Visit<'r>() =
                                let l = fold<'F, 'l>()
                                let r = fold<'F, 'r>()
                                tuple l r |> wrap
                    }
        }

    | _ -> failwithf "I do not know how to fold type %O" typeof<'t>

Example: Pretty printer

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 

[<Struct>]
type PrettyPrinter =
    static member Assign(_ : App<PrettyPrinter, 'a>, _ : 'a -> string) = ()

    interface ITypeBuilder<PrettyPrinter> with
        member __.Bool () = HKT.pack (function true -> "true" | false -> "false")
        member __.Int () = HKT.pack (fun i -> i.ToString())
        member __.String() = HKT.pack (sprintf "\"%s\"")

        member __.Option (HKT.Unpack ep) = HKT.pack(function None -> "None" | Some x -> sprintf "Some(%s)" (ep x))
        member __.List (HKT.Unpack ep) = HKT.pack(Seq.map ep >> String.concat "; " >> sprintf "[%s]")
        member __.Tuple (HKT.Unpack lp) (HKT.Unpack rp) = HKT.pack (fun (l,r) -> sprintf "(%s, %s)" (lp l) (rp r))

let mkPrinter (x : App<PrettyPrinter,_>) = HKT.unpack x

let p = sample() |> mkPrinter

p (false, Some [1;2])
Multiple items
union case App.App: payload: obj -> App<'F,'t>

--------------------
type App<'F,'t> = | App of payload: obj

Full name: Script.App<_,_>
type obj = System.Object

Full name: Microsoft.FSharp.Core.obj
val private assoc<'F,'a,'Fa (requires member Assign)> : unit

Full name: Script.HKT.assoc
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val pack : value:'Fa -> App<'F,'a> (requires member Assign)

Full name: Script.HKT.pack
val value : 'Fa
val unpack : App<'F,'a> -> 'Fa (requires member Assign)

Full name: Script.HKT.unpack
val value : obj
val unbox : value:obj -> 'T

Full name: Microsoft.FSharp.Core.Operators.unbox
val app : App<'a,'b> (requires member Assign)
type ITypeBuilder<'F> =
  interface
    abstract member Bool : unit -> App<'F,bool>
    abstract member Int : unit -> App<'F,int>
    abstract member List : App<'F,'t> -> App<'F,'t list>
    abstract member Option : App<'F,'t> -> App<'F,'t option>
    abstract member String : unit -> App<'F,string>
    abstract member Tuple : App<'F,'t1> -> App<'F,'t2> -> App<'F,('t1 * 't2)>
  end

Full name: Script.ITypeBuilder<_>
abstract member ITypeBuilder.Bool : unit -> App<'F,bool>

Full name: Script.ITypeBuilder`1.Bool
type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool
abstract member ITypeBuilder.Int : unit -> App<'F,int>

Full name: Script.ITypeBuilder`1.Int
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
Multiple items
abstract member ITypeBuilder.String : unit -> App<'F,string>

Full name: Script.ITypeBuilder`1.String

--------------------
module String

from Microsoft.FSharp.Core
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
Multiple items
abstract member ITypeBuilder.Option : App<'F,'t> -> App<'F,'t option>

Full name: Script.ITypeBuilder`1.Option

--------------------
module Option

from Microsoft.FSharp.Core
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
Multiple items
abstract member ITypeBuilder.List : App<'F,'t> -> App<'F,'t list>

Full name: Script.ITypeBuilder`1.List

--------------------
module List

from Microsoft.FSharp.Collections

--------------------
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<_>
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
abstract member ITypeBuilder.Tuple : App<'F,'t1> -> App<'F,'t2> -> App<'F,('t1 * 't2)>

Full name: Script.ITypeBuilder`1.Tuple
val private inst : unit -> 'F (requires 'F :> ITypeBuilder<'F> and default constructor)

Full name: Script.inst
Multiple items
val bool : unit -> App<'a,bool> (requires 'a :> ITypeBuilder<'a> and default constructor)

Full name: Script.bool

--------------------
type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool
Multiple items
val int : unit -> App<'a,int> (requires 'a :> ITypeBuilder<'a> and default constructor)

Full name: Script.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
Multiple items
val string : unit -> App<'a,string> (requires 'a :> ITypeBuilder<'a> and default constructor)

Full name: Script.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
module String

from Microsoft.FSharp.Core
Multiple items
val option : t:App<'a,'b> -> App<'a,'b option> (requires 'a :> ITypeBuilder<'a> and default constructor)

Full name: Script.option

--------------------
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
val t : App<'a,'b> (requires 'a :> ITypeBuilder<'a> and default constructor)
module Option

from Microsoft.FSharp.Core
Multiple items
val list : t:App<'a,'b> -> App<'a,'b list> (requires 'a :> ITypeBuilder<'a> and default constructor)

Full name: Script.list

--------------------
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
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<_>
val tuple : t:App<'a,'b> -> (App<'a,'c> -> App<'a,('b * 'c)>) (requires 'a :> ITypeBuilder<'a> and default constructor)

Full name: Script.tuple
val sample : unit -> App<'a,(bool * int list option)> (requires 'a :> ITypeBuilder<'a> and default constructor)

Full name: Script.sample
val fold : unit -> App<'F,'t> (requires 'F :> ITypeBuilder<'F> and default constructor)

Full name: Script.fold
val wrap : (App<'F,'a> -> App<'F,'t>) (requires 'F :> ITypeBuilder<'F> and default constructor)
val x : App<'F,'a> (requires 'F :> ITypeBuilder<'F> and default constructor)
val failwithf : format:Printf.StringFormat<'T,'Result> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.failwithf
val typeof<'T> : System.Type

Full name: Microsoft.FSharp.Core.Operators.typeof
Multiple items
type StructAttribute =
  inherit Attribute
  new : unit -> StructAttribute

Full name: Microsoft.FSharp.Core.StructAttribute

--------------------
new : unit -> StructAttribute
type PrettyPrinter =
  struct
    interface ITypeBuilder<PrettyPrinter>
    static member Assign : App<PrettyPrinter,'a> * ('a -> string) -> unit
  end

Full name: Script.PrettyPrinter
static member PrettyPrinter.Assign : App<PrettyPrinter,'a> * ('a -> string) -> unit

Full name: Script.PrettyPrinter.Assign
override PrettyPrinter.Bool : unit -> App<PrettyPrinter,bool>

Full name: Script.PrettyPrinter.Bool
module HKT

from Script
val __ : byref<PrettyPrinter>
override PrettyPrinter.Int : unit -> App<PrettyPrinter,int>

Full name: Script.PrettyPrinter.Int
val i : int
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
Multiple items
override PrettyPrinter.String : unit -> App<PrettyPrinter,string>

Full name: Script.PrettyPrinter.String

--------------------
module String

from Microsoft.FSharp.Core
val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
Multiple items
override PrettyPrinter.Option : App<PrettyPrinter,'d> -> App<PrettyPrinter,'d option>

Full name: Script.PrettyPrinter.Option

--------------------
module Option

from Microsoft.FSharp.Core
active recognizer Unpack: App<'a,'b> -> 'c

Full name: Script.HKT.( |Unpack| )
val ep : ('d -> string)
union case Option.None: Option<'T>
union case Option.Some: Value: 'T -> Option<'T>
val x : 'd
Multiple items
override PrettyPrinter.List : App<PrettyPrinter,'c> -> App<PrettyPrinter,'c list>

Full name: Script.PrettyPrinter.List

--------------------
module List

from Microsoft.FSharp.Collections

--------------------
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<_>
val ep : ('c -> string)
module Seq

from Microsoft.FSharp.Collections
val map : mapping:('T -> 'U) -> source:seq<'T> -> seq<'U>

Full name: Microsoft.FSharp.Collections.Seq.map
val concat : sep:string -> strings:seq<string> -> string

Full name: Microsoft.FSharp.Core.String.concat
override PrettyPrinter.Tuple : App<PrettyPrinter,'a> -> App<PrettyPrinter,'b> -> App<PrettyPrinter,('a * 'b)>

Full name: Script.PrettyPrinter.Tuple
val lp : ('a -> string)
val rp : ('b -> string)
val l : 'a
val r : 'b
val mkPrinter : x:App<PrettyPrinter,'a> -> ('a -> string)

Full name: Script.mkPrinter
val x : App<PrettyPrinter,'a>
val p : (bool * int list option -> string)

Full name: Script.p
Raw view Test code New version

More information

Link:http://fssnip.net/7WJ
Posted:5 years ago
Author:Eirik Tsarpalis
Tags: generic programming , tagless-final

This web site is created using F# and Suave web server. It is hosted on Azure and the source code is on GitHub. Contributions are welcome!

The first version of fssnip.net has been created by @tomaspetricek back in 2010. This web site is a new, open-source and contribution-friendly version.