1 people like it.

Staged Generic Equality

Staged generic equality comparer using TypeShape.

Implementation

  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: 
open TypeShape
open TypeShape_StagingExtensions
open Swensen.Unquote
open FSharp.Quotations

type CmpExpr<'T> = Expr<'T> -> Expr<'T> -> Expr<bool>

let rec stageCmp<'T> () : CmpExpr<'T> =
    let wrap (cmp : CmpExpr<'a>) = unbox<CmpExpr<'T>> cmp

    let stageMemberCmp (shape : IShapeMember<'DeclaringType>) =
        shape.Accept { new IMemberVisitor<'DeclaringType, CmpExpr<'DeclaringType>> with
            member __.Visit (shape : ShapeMember<'DeclaringType, 'FieldType>) =
                let fcmp = stageCmp<'FieldType>()
                fun dt dt' ->
                    fcmp (shape.ProjectExpr dt) 
                         (shape.ProjectExpr dt') }

    match TypeShape.Create<'T> () with
    | Shape.Unit -> wrap(fun (_: Expr<unit>) _ -> <@ true @>)
    | Shape.Bool -> wrap(fun (b: Expr<bool>) b' -> <@ %b = %b' @>)
    | Shape.Int32 -> wrap(fun (n: Expr<int>) n' -> <@ %n = %n' @>)
    | Shape.Double -> wrap(fun (d: Expr<double>) d' -> <@ %d = %d' @>)
    | Shape.String -> wrap(fun (s: Expr<string>) s' -> <@ %s = %s' @>)
    | Shape.Array s when s.Rank = 1 ->
        s.Accept { new IArrayVisitor<CmpExpr<'T>> with
            member __.Visit<'t> _ =
                let ec = stageCmp<'t>()
                wrap(fun (ts : Expr<'t []>) ts' ->
                    <@
                        match %ts, %ts' with
                        | null, null -> true
                        | null, _ | _, null -> false
                        | ts, ts' when ts.Length <> ts'.Length -> false
                        | ts, ts' ->
                            let mutable i = 0
                            let mutable areEqual = true
                            while areEqual && i < ts.Length do
                                areEqual <- (% Expr.lam2 ec) ts.[i] ts'.[i]
                            areEqual
                    @> )}

    | Shape.FSharpOption s ->
        s.Accept { new IFSharpOptionVisitor<CmpExpr<'T>> with
            member __.Visit<'t> () =
                let ec = stageCmp<'t> ()
                wrap(fun topt topt' ->
                    <@
                        match %topt, %topt' with
                        | None, None -> true
                        | None, _ | _, None -> false
                        | Some t, Some t' -> (% Expr.lam2 ec) t t'
                    @> )}

    | Shape.FSharpList s ->
        s.Accept { new IFSharpListVisitor<CmpExpr<'T>> with
            member __.Visit<'t> () =
                let ec = stageCmp<'t> ()
                wrap(fun ts ts' ->
                    <@
                        let rec aux ts ts' =
                            match ts, ts' with
                            | [], [] -> true
                            | t :: tl, t' :: tl' when (% Expr.lam2 ec) t t' -> aux tl tl'
                            | _ -> false

                        aux %ts %ts'
                    @> ) }

    | Shape.Tuple (:? ShapeTuple<'T> as shape) ->
        let elemCmps = shape.Elements |> Array.map stageMemberCmp
        fun t1 t2 ->
            <@
                let t1 = %t1
                let t2 = %t2
                (% Expr.lam2 (fun t1 t2 ->
                    elemCmps 
                    |> Array.map (fun ec -> ec t1 t2)
                    |> Expr.forall)) t1 t2 @>

    | Shape.FSharpRecord (:? ShapeFSharpRecord<'T> as shape) ->
        let fldCmps = shape.Fields |> Array.map stageMemberCmp
        fun r1 r2 ->
            <@
                let r1 = %r1
                let r2 = %r2
                (% Expr.lam2 (fun r1 r2 ->
                    fldCmps
                    |> Array.map (fun ec -> ec r1 r2)
                    |> Expr.forall)) r1 r2 @>

    | Shape.FSharpUnion (:? ShapeFSharpUnion<'T> as shape) ->
        let stageUnionCaseCmp (case : ShapeFSharpUnionCase<'T>) =
            let fldCmps = case.Fields |> Array.map stageMemberCmp
            fun u1 u2 ->
                fldCmps
                |> Array.map (fun ec -> ec u1 u2)
                |> Expr.forall

        let unionCaseCmps = shape.UnionCases |> Array.map stageUnionCaseCmp

        fun u1 u2 ->
            let caseCmps = unionCaseCmps |> Array.map (fun cmp -> cmp u1 u2)
            <@
                let u1 = %u1
                let u2 = %u2
                let tag1 = (% Expr.lam shape.GetTagExpr) u1
                let tag2 = (% Expr.lam shape.GetTagExpr) u2
                if tag1 <> tag2 then false else
                (% Expr.lam (fun tag -> Expr.switch tag caseCmps)) tag1
            @>

    | _ -> failwithf "Unsupported shape %O" typeof<'T>

let mkComparerExpr<'T>() = stageCmp<'T>() |> Expr.lam2 |> Expr.cleanup
let mkComparer<'T> () = mkComparerExpr<'T>() |> eval
let decompileCmp<'T> () = mkComparerExpr<'T>() |> decompile

Sample

 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: 
let cmp = mkComparer<int list * string option>()

cmp ([1 .. 100], Some "42") ([1 .. 100], Some "42")

decompileCmp<int * (int * int)>()
// fun t1 t2 -> 
//     t1.m_Item1 = t2.m_Item1 && 
//     let t1 = t1.m_Item2 
//     let t2 = t2.m_Item2 
//     t1.m_Item1 = t2.m_Item1 && t1.m_Item2 = t2.m_Item2
   
type Foo = { A : int ; B : string }

type Bar =
    | UA
    | UB of foo:string
    | UC of Foo

let cmp' = mkComparer<Bar>()

cmp' UA UA
cmp' (UC { A = 12 ; B = "test" })
     (UC { A = 12 ; B = "test2" })

decompileCmp<Bar>()
//fun t1 t2 -> 
//    let tag1 = t1.Tag 
//    let tag2 = t2.Tag 
//    if tag1 <> tag2 then false else 
//    tag1 = 0 || 
//    if tag1 = 1 then t1._foo = t2._foo 
//    else if tag1 = 2 then 
//        let r1 = t1.item 
//        let r2 = t2.item 
//        r1.A@ = r2.A@ && r1.B@ = r2.B@ 
//    else invalidOp "invalid tag"
module TypeShape
module TypeShape_StagingExtensions
namespace Swensen
namespace Swensen.Unquote
namespace Microsoft.FSharp
namespace Microsoft.FSharp.Quotations
type CmpExpr<'T> = Expr<'T> -> Expr<'T> -> Expr<bool>

Full name: Script.CmpExpr<_>
Multiple items
module Expr

from TypeShape_StagingExtensions

--------------------
type Expr =
  override Equals : obj:obj -> bool
  member GetFreeVars : unit -> seq<Var>
  member Substitute : substitution:(Var -> Expr option) -> Expr
  member ToString : full:bool -> string
  member CustomAttributes : Expr list
  member Type : Type
  static member AddressOf : target:Expr -> Expr
  static member AddressSet : target:Expr * value:Expr -> Expr
  static member Application : functionExpr:Expr * argument:Expr -> Expr
  static member Applications : functionExpr:Expr * arguments:Expr list list -> Expr
  ...

Full name: Microsoft.FSharp.Quotations.Expr

--------------------
type Expr<'T> =
  inherit Expr
  member Raw : Expr

Full name: Microsoft.FSharp.Quotations.Expr<_>
type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool
val stageCmp : unit -> CmpExpr<'T>

Full name: Script.stageCmp
val wrap : (CmpExpr<'a> -> Expr<'T> -> Expr<'T> -> Expr<bool>)
val cmp : CmpExpr<'a>
val unbox : value:obj -> 'T

Full name: Microsoft.FSharp.Core.Operators.unbox
val stageMemberCmp : (IShapeMember<'DeclaringType> -> CmpExpr<'DeclaringType>)
val shape : IShapeMember<'DeclaringType>
Multiple items
type IShapeMember =
  interface
    abstract member IsPublic : bool
    abstract member IsStructMember : bool
    abstract member Label : string
    abstract member MemberInfo : MemberInfo
    abstract member MemberType : Type
  end

Full name: TypeShape.IShapeMember

--------------------
type IShapeMember<'DeclaringType> =
  interface
    inherit IShapeMember
    abstract member Accept : IMemberVisitor<'DeclaringType,'R> -> 'R
  end

Full name: TypeShape.IShapeMember<_>
abstract member IShapeMember.Accept : IMemberVisitor<'DeclaringType,'R> -> 'R
type IMemberVisitor<'DeclaringType,'R> =
  interface
    abstract member Visit : ShapeMember<'DeclaringType,'MemberType> -> 'R
  end

Full name: TypeShape.IMemberVisitor<_,_>
val shape : ShapeMember<'DeclaringType,'a>
type ShapeMember<'DeclaringType,'MemberType> =
  interface IShapeMember<'DeclaringType>
  private new : label:string * memberInfo:MemberInfo * path:MemberInfo [] -> ShapeMember<'DeclaringType,'MemberType>
  member Project : instance:'DeclaringType -> 'MemberType
  member ProjectExpr : instance:Expr<'DeclaringType> -> Expr<'MemberType>
  member IsPublic : bool
  member IsStructMember : bool
  member Label : string
  member MemberInfo : MemberInfo

Full name: TypeShape.ShapeMember<_,_>
val fcmp : (Expr<'a> -> Expr<'a> -> Expr<bool>)
val dt : Expr<'DeclaringType>
val dt' : Expr<'DeclaringType>
member ShapeMember.ProjectExpr : instance:Expr<'DeclaringType> -> Expr<'MemberType>
Multiple items
module TypeShape

--------------------
type TypeShape =
  private new : unit -> TypeShape
  abstract member Accept : ITypeShapeVisitor<'R> -> 'R
  abstract member ShapeInfo : TypeShapeInfo
  abstract member Type : Type
  override ToString : unit -> string
  static member Create : unit -> TypeShape<'T>
  static member Create : typ:Type -> TypeShape

Full name: TypeShape.TypeShape

--------------------
type TypeShape<'T> =
  inherit TypeShape
  new : unit -> TypeShape<'T>
  override Accept : v:ITypeShapeVisitor<'a1> -> 'a1
  override Equals : o:obj -> bool
  override GetHashCode : unit -> int
  override ShapeInfo : TypeShapeInfo
  override Type : Type

Full name: TypeShape.TypeShape<_>

--------------------
new : unit -> TypeShape<'T>
static member TypeShape.Create : unit -> TypeShape<'T>
static member TypeShape.Create : typ:System.Type -> TypeShape
module Shape

from TypeShape
active recognizer Unit: TypeShape -> unit option

Full name: TypeShape.Shape.( |Unit|_| )
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
active recognizer Bool: TypeShape -> unit option

Full name: TypeShape.Shape.( |Bool|_| )
val b : Expr<bool>
val b' : Expr<bool>
active recognizer Int32: TypeShape -> unit option

Full name: TypeShape.Shape.( |Int32|_| )
val n : Expr<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<_>
val n' : Expr<int>
active recognizer Double: TypeShape -> unit option

Full name: TypeShape.Shape.( |Double|_| )
val d : Expr<double>
Multiple items
val double : value:'T -> double (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.double

--------------------
type double = System.Double

Full name: Microsoft.FSharp.Core.double
val d' : Expr<double>
active recognizer String: TypeShape -> unit option

Full name: TypeShape.Shape.( |String|_| )
val s : Expr<string>
Multiple items
val string : value:'T -> string

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

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

Full name: Microsoft.FSharp.Core.string
val s' : Expr<string>
active recognizer Array: TypeShape -> IShapeArray option

Full name: TypeShape.Shape.( |Array|_| )
val s : IShapeArray
property IShapeArray.Rank: int
abstract member IShapeArray.Accept : IArrayVisitor<'R> -> 'R
type IArrayVisitor<'R> =
  interface
    abstract member Visit : rank:int -> 'R
  end

Full name: TypeShape.IArrayVisitor<_>
val ec : (Expr<'t> -> Expr<'t> -> Expr<bool>)
val ts : Expr<'t []>
val ts' : Expr<'t []>
val ts : 't []
val ts' : 't []
property System.Array.Length: int
val mutable i : int
val mutable areEqual : bool
val lam2 : f:(Expr<'T1> -> Expr<'T2> -> Expr<'S>) -> Expr<('T1 -> 'T2 -> 'S)>

Full name: TypeShape_StagingExtensions.Expr.lam2
active recognizer FSharpOption: TypeShape -> IShapeFSharpOption option

Full name: TypeShape.Shape.( |FSharpOption|_| )
val s : IShapeFSharpOption
abstract member IShapeFSharpOption.Accept : IFSharpOptionVisitor<'R> -> 'R
type IFSharpOptionVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.IFSharpOptionVisitor<_>
val topt : Expr<'t option>
val topt' : Expr<'t option>
union case Option.None: Option<'T>
union case Option.Some: Value: 'T -> Option<'T>
val t : 't
val t' : 't
active recognizer FSharpList: TypeShape -> IShapeFSharpList option

Full name: TypeShape.Shape.( |FSharpList|_| )
val s : IShapeFSharpList
abstract member IShapeFSharpList.Accept : IFSharpListVisitor<'R> -> 'R
type IFSharpListVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.IFSharpListVisitor<_>
val ts : Expr<'t list>
val ts' : Expr<'t list>
val aux : ('t list -> 't list -> bool)
val ts : 't list
val ts' : 't list
val tl : 't list
val tl' : 't list
active recognizer Tuple: TypeShape -> IShapeTuple option

Full name: TypeShape.Shape.( |Tuple|_| )
type ShapeTuple<'Tuple> =
  interface IShapeTuple
  private new : unit -> ShapeTuple<'Tuple>
  member CreateUninitialized : unit -> 'Tuple
  member CreateUninitializedExpr : unit -> Expr<'Tuple>
  member Elements : IShapeWriteMember<'Tuple> []

Full name: TypeShape.ShapeTuple<_>
val shape : ShapeTuple<'T>
val elemCmps : (Expr<'T> -> Expr<'T> -> Expr<bool>) []
property ShapeTuple.Elements: IShapeWriteMember<'T> []
Multiple items
union case TypeShapeInfo.Array: element: System.Type * rank: int -> TypeShapeInfo

--------------------
module Array

from Microsoft.FSharp.Collections
val map : mapping:('T -> 'U) -> array:'T [] -> 'U []

Full name: Microsoft.FSharp.Collections.Array.map
val t1 : Expr<'T>
val t2 : Expr<'T>
val t1 : 'T
val t2 : 'T
val ec : (Expr<'T> -> Expr<'T> -> Expr<bool>)
val forall : fs:Expr<bool> [] -> Expr<bool>

Full name: TypeShape_StagingExtensions.Expr.forall
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 shape : ShapeFSharpRecord<'T>
val fldCmps : (Expr<'T> -> Expr<'T> -> Expr<bool>) []
property ShapeFSharpRecord.Fields: IShapeWriteMember<'T> []
val r1 : Expr<'T>
val r2 : Expr<'T>
val r1 : 'T
val r2 : 'T
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 shape : ShapeFSharpUnion<'T>
val stageUnionCaseCmp : (ShapeFSharpUnionCase<'T> -> Expr<'T> -> Expr<'T> -> Expr<bool>)
val case : ShapeFSharpUnionCase<'T>
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 ShapeFSharpUnionCase.Fields: IShapeWriteMember<'T> []
val u1 : Expr<'T>
val u2 : Expr<'T>
val unionCaseCmps : (Expr<'T> -> Expr<'T> -> Expr<bool>) []
property ShapeFSharpUnion.UnionCases: ShapeFSharpUnionCase<'T> []
val caseCmps : Expr<bool> []
val cmp : (Expr<'T> -> Expr<'T> -> Expr<bool>)
val u1 : 'T
val u2 : 'T
val tag1 : int
val lam : f:(Expr<'T> -> Expr<'S>) -> Expr<('T -> 'S)>

Full name: TypeShape_StagingExtensions.Expr.lam
member ShapeFSharpUnion.GetTagExpr : union:Expr<'U> -> Expr<int>
val tag2 : int
val tag : Expr<int>
val switch : tag:Expr<int> -> cases:Expr<'T> [] -> Expr<'T>

Full name: TypeShape_StagingExtensions.Expr.switch
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
val mkComparerExpr : unit -> Expr<('T -> 'T -> bool)>

Full name: Script.mkComparerExpr
val cleanup : expr:Expr<'T> -> Expr<'T>

Full name: TypeShape_StagingExtensions.Expr.cleanup
val mkComparer : unit -> ('T -> 'T -> bool)

Full name: Script.mkComparer
val eval : expr:Expr<'a> -> 'a

Full name: Swensen.Unquote.Operators.eval
val decompileCmp<'T> : unit -> string

Full name: Script.decompileCmp
val decompile : expr:Expr -> string

Full name: Swensen.Unquote.Operators.decompile
val cmp : (int list * string option -> int list * string option -> bool)

Full name: Script.cmp
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
type 'T option = Option<'T>

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

Full name: Script.Foo
Foo.A: int
Foo.B: string
type Bar =
  | UA
  | UB of foo: string
  | UC of Foo

Full name: Script.Bar
union case Bar.UA: Bar
union case Bar.UB: foo: string -> Bar
union case Bar.UC: Foo -> Bar
val cmp' : (Bar -> Bar -> bool)

Full name: Script.cmp'

More information

Link:http://fssnip.net/7Ry
Posted:7 years ago
Author:Eirik Tsarpalis
Tags: generic programming , staging , typeshape