0 people like it.

Generic Projections & Isomorphisms

TypeShape-driven structural projection and isomorphism generation

  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: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
open System
open TypeShape
open TypeShape_Utils

//----------------------------------------------
// Generic Isomorphism and Projection derivation

type Iso<'a, 'b> = Iso of ('a -> 'b) * ('b -> 'a)
and Proj<'a, 'b> = Proj of ('a -> 'b)


let refl = Iso(id,id)
let sym (Iso(f,g)) = Iso(g,f)
let trans (Iso(f,g)) (Iso(f',g')) = Iso(f' << f, g << g')

let convert1 (Iso (f,_)) x = f x
let convert2 (Iso (_,g)) y = g y
let project (Proj f) x = f x

//----------------------------------
// TypeShape - driven iso generation

let rec mkIso<'a, 'b> () : Iso<'a, 'b> =
    let (Proj f), (Proj g) = mkProj<'a, 'b> (), mkProj<'b, 'a> ()
    Iso(f,g)

and mkProj<'a, 'b> () : Proj<'a, 'b> =
    use ctx = new RecTypeManager()
    mkProjCached<'a, 'b> ctx

and private mkProjCached<'a, 'b> (ctx : RecTypeManager) : Proj<'a, 'b> =
    match ctx.TryFind<Proj<'a, 'b>>() with
    | Some r -> r
    | None ->
        let _ = ctx.CreateUninitialized<Proj<'a, 'b>> (fun c -> Proj(fun a -> let (Proj c) = c.Value in c a))
        let p = mkProjAux<'a, 'b> ctx
        ctx.Complete p

and private mkProjAux<'a, 'b> (ctx : RecTypeManager) : Proj<'a,'b> =
    let notProj() = failwithf "Type '%O' is not projectable to '%O'" typeof<'a> typeof<'b>

    let mkMemberProj (candidates : IShapeWriteMember<'a>[]) (target : IShapeWriteMember<'b>) =
        match candidates |> Array.tryFind (fun c -> c.Label = target.Label) with
        | None -> notProj()
        | Some source ->
            source.Accept { new IWriteMemberVisitor<'a, ('a -> 'b -> 'b)> with
              member __.Visit (src : ShapeWriteMember<'a, 'F>) =
                target.Accept { new IWriteMemberVisitor<'b, ('a -> 'b -> 'b)> with
                  member __.Visit (tgt : ShapeWriteMember<'b, 'G>) =
                    let (Proj conv) = mkProjCached<'F, 'G> ctx
                    fun (a:'a) (b:'b) -> 
                        let f = src.Project a
                        tgt.Inject b (conv f) } }

    match shapeof<'a>, shapeof<'b> with
    | s, s' when s.Type = s'.Type -> Proj(unbox<'a -> 'b> (fun (a:'a) -> a))
    | Shape.FSharpRecord (:? ShapeFSharpRecord<'a> as ar), 
      Shape.FSharpRecord (:? ShapeFSharpRecord<'b> as br) ->
        let memberProjs = br.Fields |> Array.map (mkMemberProj ar.Fields)
        fun (a:'a) ->
            let mutable b = br.CreateUninitialized()
            for m in memberProjs do b <- m a b
            b
        |> Proj

    | Shape.FSharpUnion (:? ShapeFSharpUnion<'a> as ar),
      Shape.FSharpUnion (:? ShapeFSharpUnion<'b> as br) ->

        let mkUnionCaseProj (source : ShapeFSharpUnionCase<'a>) =
            match br.UnionCases |> Array.tryFind (fun candidate -> candidate.CaseInfo.Name = source.CaseInfo.Name) with
            | Some target -> target.Fields |> Array.map (mkMemberProj source.Fields)
            | None -> notProj()

        let unionCaseMappers = ar.UnionCases |> Array.map mkUnionCaseProj

        fun (a:'a) ->
            let tag = ar.GetTag a
            let mutable b = br.UnionCases.[tag].CreateUninitialized()
            for m in unionCaseMappers.[tag] do b <- m a b
            b
        |> Proj

    | _ -> notProj()


//----------------------------------
// examples

type Foo = { A : int ; B : string option }

type Foo2 = { B : string option ; A : int }

type Bar = { A : int ; B : string option ; C : int }

let f = mkIso<Foo, Foo2>()
let h = mkProj<Bar, Foo>()

convert1 f { A = 2 ; B = Some "foo" }
convert2 f { A = 2 ; B = Some "foo" }
project h { A = 2 ; B = Some "foo" ; C = 32 }


//--------------------------------
// Recursive type support

type Peano = Zero | Succ of pred:Peano
type Peano' = Succ of pred:Peano' | Zero

let pIso = mkIso<Peano', Peano>()

let twenty : Peano =
    let rec int2P = function 0 -> Peano.Zero | n -> Peano.Succ(int2P (n-1)) in
    int2P 20

convert2 pIso twenty

type P1 = Zero | Succ of pred:P1 | SomethingElse of int
let pProj1 = mkProj<Peano, P1>()

project pProj1 twenty


type P2 = Zero | Succ of pred:P2 * int
let pProj2 = mkProj<P2, Peano>()

project pProj2 (Succ (Zero, 42))
namespace System
module TypeShape
module TypeShape_Utils
Multiple items
union case Iso.Iso: ('a -> 'b) * ('b -> 'a) -> Iso<'a,'b>

--------------------
type Iso<'a,'b> = | Iso of ('a -> 'b) * ('b -> 'a)

Full name: Script.Iso<_,_>
type Proj<'a,'b> = | Proj of ('a -> 'b)

Full name: Script.Proj<_,_>
Multiple items
union case Proj.Proj: ('a -> 'b) -> Proj<'a,'b>

--------------------
type Proj<'a,'b> = | Proj of ('a -> 'b)

Full name: Script.Proj<_,_>
val refl : Iso<'a,'a>

Full name: Script.refl
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val sym : Iso<'a,'b> -> Iso<'b,'a>

Full name: Script.sym
val f : ('a -> 'b)
val g : ('b -> 'a)
val trans : Iso<'a,'b> -> Iso<'b,'c> -> Iso<'a,'c>

Full name: Script.trans
val f' : ('b -> 'c)
val g' : ('c -> 'b)
val convert1 : Iso<'a,'b> -> x:'a -> 'b

Full name: Script.convert1
val x : 'a
val convert2 : Iso<'a,'b> -> y:'b -> 'a

Full name: Script.convert2
val y : 'b
val project : Proj<'a,'b> -> x:'a -> 'b

Full name: Script.project
val mkIso : unit -> Iso<'a,'b>

Full name: Script.mkIso
val mkProj : unit -> Proj<'a,'b>

Full name: Script.mkProj
val ctx : RecTypeManager
Multiple items
type RecTypeManager =
  interface IDisposable
  new : unit -> RecTypeManager
  private new : parentCache:TypeCache option -> RecTypeManager
  member Complete : value:'T -> 'T
  member CreateUninitialized : delay:(Cell<'T> -> 'T) -> 'T
  member private GetGeneratedValues : unit -> (Type * obj) []
  member TryFind : unit -> 'T option
  member TryFind : t:Type -> obj option
  member TryGetValue : result:byref<'T> -> bool
  member TryGetValue : t:Type * result:byref<obj> -> bool
  ...

Full name: TypeShape_Utils.RecTypeManager

--------------------
new : unit -> RecTypeManager
val private mkProjCached : ctx:RecTypeManager -> Proj<'a,'b>

Full name: Script.mkProjCached
member RecTypeManager.TryFind : unit -> 'T option
member RecTypeManager.TryFind : t:Type -> obj option
union case Option.Some: Value: 'T -> Option<'T>
val r : Proj<'a,'b>
union case Option.None: Option<'T>
member RecTypeManager.CreateUninitialized : delay:(Cell<'T> -> 'T) -> 'T
val c : Cell<Proj<'a,'b>>
val a : 'a
val c : ('a -> 'b)
val p : Proj<'a,'b>
val private mkProjAux : ctx:RecTypeManager -> Proj<'a,'b>

Full name: Script.mkProjAux
member RecTypeManager.Complete : value:'T -> 'T
val notProj : (unit -> 'a)
val failwithf : format:Printf.StringFormat<'T,'Result> -> 'T

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

Full name: Microsoft.FSharp.Core.Operators.typeof
val mkMemberProj : (IShapeWriteMember<'a> [] -> IShapeWriteMember<'b> -> 'a -> 'b -> 'b)
val candidates : IShapeWriteMember<'a> []
type IShapeWriteMember<'Record> =
  interface
    inherit IShapeMember<'Record>
    abstract member Accept : IWriteMemberVisitor<'Record,'R> -> 'R
  end

Full name: TypeShape.IShapeWriteMember<_>
val target : IShapeWriteMember<'b>
Multiple items
union case TypeShapeInfo.Array: element: Type * rank: int -> TypeShapeInfo

--------------------
type Array =
  member Clone : unit -> obj
  member CopyTo : array:Array * index:int -> unit + 1 overload
  member GetEnumerator : unit -> IEnumerator
  member GetLength : dimension:int -> int
  member GetLongLength : dimension:int -> int64
  member GetLowerBound : dimension:int -> int
  member GetUpperBound : dimension:int -> int
  member GetValue : [<ParamArray>] indices:int[] -> obj + 7 overloads
  member Initialize : unit -> unit
  member IsFixedSize : bool
  ...

Full name: System.Array
val tryFind : predicate:('T -> bool) -> array:'T [] -> 'T option

Full name: Microsoft.FSharp.Collections.Array.tryFind
val c : IShapeWriteMember<'a>
property IShapeMember.Label: string
val source : IShapeWriteMember<'a>
abstract member IShapeMember.Accept : IMemberVisitor<'DeclaringType,'R> -> 'R
abstract member IShapeWriteMember.Accept : IWriteMemberVisitor<'Record,'R> -> 'R
type IWriteMemberVisitor<'TRecord,'R> =
  interface
    abstract member Visit : ShapeWriteMember<'TRecord,'Field> -> 'R
  end

Full name: TypeShape.IWriteMemberVisitor<_,_>
val src : ShapeWriteMember<'a,'b>
type ShapeWriteMember<'DeclaringType,'MemberType> =
  inherit ShapeMember<'DeclaringType,'MemberType>
  interface IShapeWriteMember<'DeclaringType>
  private new : label:string * memberInfo:MemberInfo * path:MemberInfo [] -> ShapeWriteMember<'DeclaringType,'MemberType>
  member Inject : instance:'DeclaringType -> field:'MemberType -> 'DeclaringType
  member InjectExpr : instance:Expr<'DeclaringType> -> field:Expr<'MemberType> -> Expr<'DeclaringType>

Full name: TypeShape.ShapeWriteMember<_,_>
val __ : IWriteMemberVisitor<'a,('a -> 'b -> 'b)>
abstract member IWriteMemberVisitor.Visit : ShapeWriteMember<'TRecord,'Field> -> 'R
val tgt : ShapeWriteMember<'b,'a>
val conv : ('a -> 'b)
val b : 'b
val f : 'a
member ShapeMember.Project : instance:'DeclaringType -> 'MemberType
member ShapeWriteMember.Inject : instance:'DeclaringType -> field:'MemberType -> 'DeclaringType
val shapeof<'T> : TypeShape<'T>

Full name: TypeShape.shapeof
val s : TypeShape<'a>
val s' : TypeShape<'b>
type Type =
  inherit MemberInfo
  member Assembly : Assembly
  member AssemblyQualifiedName : string
  member Attributes : TypeAttributes
  member BaseType : Type
  member ContainsGenericParameters : bool
  member DeclaringMethod : MethodBase
  member DeclaringType : Type
  member Equals : o:obj -> bool + 1 overload
  member FindInterfaces : filter:TypeFilter * filterCriteria:obj -> Type[]
  member FindMembers : memberType:MemberTypes * bindingAttr:BindingFlags * filter:MemberFilter * filterCriteria:obj -> MemberInfo[]
  ...

Full name: System.Type
property TypeShape.Type: Type
val unbox : value:obj -> 'T

Full name: Microsoft.FSharp.Core.Operators.unbox
module Shape

from TypeShape
active recognizer FSharpRecord: TypeShape -> IShapeFSharpRecord option

Full name: TypeShape.Shape.( |FSharpRecord|_| )
type ShapeFSharpRecord<'Record> =
  interface IShapeFSharpRecord
  private new : unit -> ShapeFSharpRecord<'Record>
  member CreateUninitialized : unit -> 'Record
  member CreateUninitializedExpr : unit -> Expr<'Record>
  member Fields : IShapeWriteMember<'Record> []

Full name: TypeShape.ShapeFSharpRecord<_>
val ar : ShapeFSharpRecord<'a>
val br : ShapeFSharpRecord<'b>
val memberProjs : ('a -> 'b -> 'b) []
property ShapeFSharpRecord.Fields: IShapeWriteMember<'b> []
val map : mapping:('T -> 'U) -> array:'T [] -> 'U []

Full name: Microsoft.FSharp.Collections.Array.map
property ShapeFSharpRecord.Fields: IShapeWriteMember<'a> []
val mutable b : 'b
member ShapeFSharpRecord.CreateUninitialized : unit -> 'Record
val m : ('a -> 'b -> 'b)
active recognizer FSharpUnion: TypeShape -> IShapeFSharpUnion option

Full name: TypeShape.Shape.( |FSharpUnion|_| )
type ShapeFSharpUnion<'U> =
  interface IShapeFSharpUnion
  private new : unit -> ShapeFSharpUnion<'U>
  member GetTag : caseName:string -> int
  member GetTag : union:'U -> int
  member GetTagExpr : union:Expr<'U> -> Expr<int>
  member UnionCases : ShapeFSharpUnionCase<'U> []

Full name: TypeShape.ShapeFSharpUnion<_>
val ar : ShapeFSharpUnion<'a>
val br : ShapeFSharpUnion<'b>
val mkUnionCaseProj : (ShapeFSharpUnionCase<'a> -> ('a -> 'b -> 'b) [])
val source : ShapeFSharpUnionCase<'a>
type ShapeFSharpUnionCase<'Union> =
  interface IShapeFSharpUnionCase
  private new : uci:UnionCaseInfo -> ShapeFSharpUnionCase<'Union>
  member CreateUninitialized : unit -> 'Union
  member CreateUninitializedExpr : unit -> Expr<'Union>
  member CaseInfo : UnionCaseInfo
  member Fields : IShapeWriteMember<'Union> []

Full name: TypeShape.ShapeFSharpUnionCase<_>
property ShapeFSharpUnion.UnionCases: ShapeFSharpUnionCase<'b> []
val candidate : ShapeFSharpUnionCase<'b>
property ShapeFSharpUnionCase.CaseInfo: Reflection.UnionCaseInfo
property Reflection.UnionCaseInfo.Name: string
val target : ShapeFSharpUnionCase<'b>
property ShapeFSharpUnionCase.Fields: IShapeWriteMember<'b> []
property ShapeFSharpUnionCase.Fields: IShapeWriteMember<'a> []
val unionCaseMappers : ('a -> 'b -> 'b) [] []
property ShapeFSharpUnion.UnionCases: ShapeFSharpUnionCase<'a> []
val tag : int
member ShapeFSharpUnion.GetTag : caseName:string -> int
member ShapeFSharpUnion.GetTag : union:'U -> int
type Foo =
  {A: int;
   B: string option;}

Full name: Script.Foo
Foo.A: 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<_>
Foo.B: string option
Multiple items
val string : value:'T -> string

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

--------------------
type string = String

Full name: Microsoft.FSharp.Core.string
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
type Foo2 =
  {B: string option;
   A: int;}

Full name: Script.Foo2
Foo2.B: string option
Foo2.A: int
type Bar =
  {A: int;
   B: string option;
   C: int;}

Full name: Script.Bar
Bar.A: int
Bar.B: string option
Bar.C: int
val f : Iso<Foo,Foo2>

Full name: Script.f
val h : Proj<Bar,Foo>

Full name: Script.h
type Peano =
  | Zero
  | Succ of pred: Peano

Full name: Script.Peano
union case Peano.Zero: Peano
union case Peano.Succ: pred: Peano -> Peano
type Peano' =
  | Succ of pred: Peano'
  | Zero

Full name: Script.Peano'
union case Peano'.Succ: pred: Peano' -> Peano'
union case Peano'.Zero: Peano'
val pIso : Iso<Peano',Peano>

Full name: Script.pIso
val twenty : Peano

Full name: Script.twenty
val int2P : (int -> Peano)
val n : int
type P1 =
  | Zero
  | Succ of pred: P1
  | SomethingElse of int

Full name: Script.P1
union case P1.Zero: P1
union case P1.Succ: pred: P1 -> P1
union case P1.SomethingElse: int -> P1
val pProj1 : Proj<Peano,P1>

Full name: Script.pProj1
type P2 =
  | Zero
  | Succ of pred: P2 * int

Full name: Script.P2
union case P2.Zero: P2
union case P2.Succ: pred: P2 * int -> P2
val pProj2 : Proj<P2,Peano>

Full name: Script.pProj2

More information

Link:http://fssnip.net/7Sj
Posted:7 years ago
Author:Eirik Tsarpalis
Tags: typeshape