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>() with | Some r -> r | None -> let _ = ctx.CreateUninitialized> (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() let h = mkProj() 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() 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() project pProj1 twenty type P2 = Zero | Succ of pred:P2 * int let pProj2 = mkProj() 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