0 people like it.

Staged Generic Hashcodes

Staged generic hashcode generation 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: 
118: 
119: 
120: 
121: 
open TypeShape
open TypeShape_StagingExtensions
open Swensen.Unquote
open FSharp.Quotations

type HashExpr<'T> = Expr<'T> -> Expr<int>

let rec stageHasher<'T> () : HashExpr<'T> =
    let wrap (cmp : HashExpr<'a>) = unbox<HashExpr<'T>> cmp

    let combineHash (h1 : Expr<int>) (h2 : Expr<int>) =
        <@ let h1 = %h1 in let h2 = %h2 in ((h1 <<< 5) + h1) ||| h2 @>

    let stageMemberHash (shape : IShapeMember<'DeclaringType>) =
        shape.Accept { new IMemberVisitor<'DeclaringType, HashExpr<'DeclaringType>> with
            member __.Visit (shape : ShapeMember<'DeclaringType, 'FieldType>) =
                let fhash = stageHasher<'FieldType>()
                fun dt -> fhash(shape.ProjectExpr dt) }

    match shapeof<'T> with
    | Shape.Unit -> wrap(fun (_: Expr<unit>) -> <@ 0 @>)
    | Shape.Bool -> wrap(fun (b: Expr<bool>) -> <@ if %b then 1 else 0 @>)
    | Shape.Int32 -> wrap(fun (n: Expr<int>) -> <@ %n @>)
    | Shape.Double -> wrap(fun (d: Expr<double>) -> <@ hash %d @>)
    | Shape.String -> wrap(fun (s: Expr<string>) -> <@ hash %s @>)
    | Shape.Array s when s.Rank = 1 ->
        s.Accept { new IArrayVisitor<HashExpr<'T>> with
            member __.Visit<'t> _ =
                wrap(fun (ts : Expr<'t []>) ->
                    let eh = stageHasher<'t>()
                    <@
                        match %ts with
                        | null -> 0
                        | ts ->
                            let mutable agg = 0
                            for t in ts do
                                let th = (% Expr.lam eh) t
                                agg <- (% Expr.lam2 combineHash) agg th
                            agg
                    @> )}

    | Shape.FSharpOption s ->
        s.Accept { new IFSharpOptionVisitor<HashExpr<'T>> with
            member __.Visit<'t> () =
                wrap(fun topt ->
                    let eh = stageHasher<'t> ()
                    <@
                        match %topt with
                        | None -> 0
                        | Some t -> 
                            let th = (% Expr.lam eh) t
                            (% Expr.lam2 combineHash) 1 th
                    @> )}

    | Shape.FSharpList s ->
        s.Accept { new IFSharpListVisitor<HashExpr<'T>> with
            member __.Visit<'t> () =
                wrap(fun (ts : Expr<'t list>) ->
                    let eh = stageHasher<'t> ()
                    <@
                        let mutable agg = 0
                        for t in %ts do
                            let th = (% Expr.lam eh) t
                            agg <- (% Expr.lam2 combineHash) agg th

                        agg
                    @> ) }

    | Shape.Tuple (:? ShapeTuple<'T> as shape) ->
        fun (tuple : Expr<'T>) ->
            let mkElementHasher tuple =
                shape.Elements
                |> Array.map (fun e -> stageMemberHash e tuple)
                |> Array.map (fun eh agg -> combineHash eh agg)
                |> Expr.update ("agg", <@ 0 @>)

            <@
                let tuple = %tuple
                (% Expr.lam mkElementHasher) tuple
            @>

    | Shape.FSharpRecord (:? ShapeFSharpRecord<'T> as shape) ->
        fun (record : Expr<'T>) ->
            let mkFieldHasher record =
                shape.Fields
                |> Array.map (fun e -> stageMemberHash e record)
                |> Array.map (fun eh agg -> combineHash eh agg)
                |> Expr.update ("agg", <@ 0 @>)
                    
            <@
                let record = %record
                (% Expr.lam mkFieldHasher) record
            @>

    | Shape.FSharpUnion (:? ShapeFSharpUnion<'T> as shape) ->
        fun (u : Expr<'T>) ->
            let stageUnionCaseHasher 
                (union : Expr<'T>) (tag : Expr<int>)
                (case : ShapeFSharpUnionCase<'T>) =
            
                case.Fields
                |> Array.map (fun c -> stageMemberHash c union)
                |> Array.map (fun fh agg -> combineHash fh agg)
                |> Expr.update ("agg", tag)

            let stageUnionCaseHashers (u : Expr<'T>) (tag : Expr<int>) =
                shape.UnionCases
                |> Array.map (stageUnionCaseHasher u tag)
                |> Expr.switch tag

            <@
                let union = %u
                let tag = (% Expr.lam shape.GetTagExpr) union
                (% Expr.lam2 stageUnionCaseHashers) union tag  
            @>

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

let mkHashCodeExpr<'T>() = stageHasher<'T>() |> Expr.lam |> Expr.cleanup
let mkHasher<'T> () = mkHashCodeExpr<'T>() |> eval
let decompileHasher<'T> () = mkHashCodeExpr<'T>() |> decompile

Examples

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

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

decompileHasher<int * (string * bool)>()
//fun t -> 
//    let mutable agg = 0 
//    agg <- let h1 = t.m_Item1 in (h1 <<< 5) + h1 ||| agg
//    agg <- 
//        let h1 = 
//            let tuple = t.m_Item2 
//            let mutable agg = 0 
//            agg <- let h1 = hash tuple.m_Item1 in (h1 <<< 5) + h1 ||| agg
//            agg <- let h1 = if tuple.m_Item2 then 1 else 0 in (h1 <<< 5) + h1 ||| agg
//            agg 
//        (h1 <<< 5) + h1 ||| agg 
//    agg
   
type Foo = { A : int ; B : string }

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

let hasher' = mkHasher<Bar>()

hasher' (UC { A = 12 ; B = "test" })

decompileHasher<Bar list>()
//fun t -> 
//    let tag = t.Tag 
//    if tag = 0 then tag 
//    elif tag = 1 then 
//        let mutable agg = tag 
//        agg <- let h1 = hash t._foo in (h1 <<< 5) + h1 ||| agg
//        agg 
//    elif tag = 2 then 
//        let mutable agg = tag 
//        agg <- 
//            let h1 = 
//                let record = t.item 
//                let mutable agg = 0 
//                agg <- let h1 = record.A@ in (h1 <<< 5) + h1 ||| agg
//                agg <- let h1 = record.B@.GetHashCode() in (h1 <<< 5) + h1 ||| agg
//                agg 
//            (h1 <<< 5) + h1 ||| agg
//        agg 
//    else invalidOp "invalid tag"
module TypeShape
module TypeShape_StagingExtensions
namespace Swensen
namespace Swensen.Unquote
namespace Microsoft.FSharp
namespace Microsoft.FSharp.Quotations
type HashExpr<'T> = Expr<'T> -> Expr<int>

Full name: Script.HashExpr<_>
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<_>
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 stageHasher : unit -> HashExpr<'T>

Full name: Script.stageHasher
val wrap : (HashExpr<'a> -> Expr<'T> -> Expr<int>)
val cmp : HashExpr<'a>
val unbox : value:obj -> 'T

Full name: Microsoft.FSharp.Core.Operators.unbox
val combineHash : (Expr<int> -> Expr<int> -> Expr<int>)
val h1 : Expr<int>
val h2 : Expr<int>
val h1 : int
val h2 : int
val stageMemberHash : (IShapeMember<'DeclaringType> -> HashExpr<'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 fhash : (Expr<'a> -> Expr<int>)
val dt : Expr<'DeclaringType>
member ShapeMember.ProjectExpr : instance:Expr<'DeclaringType> -> Expr<'MemberType>
val shapeof<'T> : TypeShape<'T>

Full name: TypeShape.shapeof
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>
type bool = System.Boolean

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

Full name: TypeShape.Shape.( |Int32|_| )
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 hash : obj:'T -> int (requires equality)

Full name: Microsoft.FSharp.Core.Operators.hash
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
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 ts : Expr<'t []>
val eh : (Expr<'t> -> Expr<int>)
val ts : 't []
val mutable agg : int
val t : 't
val th : int
val lam : f:(Expr<'T> -> Expr<'S>) -> Expr<('T -> 'S)>

Full name: TypeShape_StagingExtensions.Expr.lam
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>
union case Option.None: Option<'T>
union case Option.Some: Value: 'T -> Option<'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>
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.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 tuple : Expr<'T>
val mkElementHasher : (Expr<'T> -> Expr<int>)
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 e : IShapeWriteMember<'T>
val eh : Expr<int>
val agg : Expr<int>
val update : varName:string * init:Expr<'T> -> comps:(Expr<'T> -> Expr<'T>) [] -> Expr<'T>

Full name: TypeShape_StagingExtensions.Expr.update
val tuple : 'T
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 record : Expr<'T>
val mkFieldHasher : (Expr<'T> -> Expr<int>)
property ShapeFSharpRecord.Fields: IShapeWriteMember<'T> []
val record : '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 u : Expr<'T>
val stageUnionCaseHasher : (Expr<'T> -> Expr<int> -> ShapeFSharpUnionCase<'T> -> Expr<int>)
val union : Expr<'T>
val tag : Expr<int>
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 c : IShapeWriteMember<'T>
val fh : Expr<int>
val stageUnionCaseHashers : (Expr<'T> -> Expr<int> -> Expr<int>)
property ShapeFSharpUnion.UnionCases: ShapeFSharpUnionCase<'T> []
val switch : tag:Expr<int> -> cases:Expr<'T> [] -> Expr<'T>

Full name: TypeShape_StagingExtensions.Expr.switch
val union : 'T
val tag : int
member ShapeFSharpUnion.GetTagExpr : union:Expr<'U> -> Expr<int>
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 mkHashCodeExpr : unit -> Expr<('T -> int)>

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

Full name: TypeShape_StagingExtensions.Expr.cleanup
val mkHasher : unit -> ('T -> int)

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

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

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

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

Full name: Script.hasher
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 hasher' : (Bar -> int)

Full name: Script.hasher'

More information

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