Skip to content

Instantly share code, notes, and snippets.

@thinkbeforecoding
Last active August 29, 2015 14:02
Show Gist options
  • Star 2 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save thinkbeforecoding/dd49fd8fce8dc3100cd1 to your computer and use it in GitHub Desktop.
Save thinkbeforecoding/dd49fd8fce8dc3100cd1 to your computer and use it in GitHub Desktop.
This creates a hash code of a F# Expr. The hash code changes when the code change
open Microsoft.FSharp.Quotations
open Microsoft.FSharp.Quotations.Patterns
open System.Reflection
let hashList f seed = List.fold (fun h v -> h * 37 + f v) seed
let (<+) x y = x * 37 + y
let (!<) f x y = x <+ f y
let rec hashC funcs =
let hashc e = hashC funcs e
function
| Lambda(v, body) -> hashV v <+ hashc body <+ 11
| Call(target, m, args) ->
match Expr.TryGetReflectedDefinition m, Set.contains m.Name funcs with
| Some f, false ->
let hashc e = hashC (Set.add m.Name funcs) e
args |> hashList hashc (hashOpt hashc target <+ hashc f) <+ 13
| _ -> args |> hashList hashc (hashOpt hashc target <+ hash m.Name) <+ 17
| Var v -> hashV v <+ 19
| IfThenElse(cond,t,f) -> hashc cond <+ hashc t <+ hashc f <+ 23
| UnionCaseTest(e, caseInfo) -> hashc e <+ hash caseInfo.Name <+ 29
| Let(v, e, body) -> hashV v <+ hashc e <+ hashc body <+ 31
| PropertyGet(target, prop, args) -> args |> hashList hashc (hashOpt hashc target <+ hashP prop) <+ 37
| TupleGet(e, i) -> hashc e <+ hash i <+ 41
| AddressOf e -> hashc e <+ 43
| AddressSet(e1, e2) -> hashc e1 <+ hashc e2 <+ 47
| Application(e1, e2) -> hashc e1 <+ hashc e2 <+ 53
| Coerce(e,t) -> hashc e <+ hashT t <+ 59
| DefaultValue(t) -> hashT t <+ 61
| FieldGet(target, field) -> hashOpt hashc target <+ hashF field <+ 67
| FieldSet(target, field, v) -> hashOpt hashc target <+ hashF field <+ hashc v <+ 71
| ForIntegerRangeLoop(v, s, e, st) -> hashV v <+ hashc s <+ hashc e <+ hashc st <+ 73
| LetRecursive(bindings, body) -> bindings |> hashList (hashB funcs) (hashc body) <+ 79
| NewArray(t, args) -> args |> hashList hashc (hashT t) <+ 83
| NewDelegate(t, args, e) -> args |> hashList hashV (hashT t <+ hashc e) <+ 83
| NewObject(c, args) -> args |> hashList hashc (hashCst c) <+ 89
| NewRecord(t, args) -> args |> hashList hashc (hashT t) <+ 97
| NewTuple(args) -> args |> hashList hashc 101
| NewUnionCase(case, args) -> args |> hashList hashc (hashCse case) <+ 103
| PropertySet(target, prop, args, v) -> args |> hashList hashc (hashOpt hashc target <+ hashP prop <+ hashc v) <+ 107
| Quote(e) -> hashc e <+ 109
| Sequential(f,s) -> hashc f <+ hashc s <+ 113
| TryFinally(body, f) -> hashc body <+ hashc f <+ 127
| TryWith(body, v, e, v2, e2) -> hashc body <+ hashV v <+ hashc e <+ hashV v2 <+ hashc e2 <+ 131
| TypeTest(e, t) -> hashc e <+ hashT t <+ 137
| UnionCaseTest(e, case) -> hashc e <+ hashCse case <+ 139
| Value(v, t) -> hash v <+ hashT t <+ 149
| VarSet(v, e) -> hashV v <+ hashc e <+ 151
| WhileLoop(cond, body) -> hashc cond <+ hashc body <+ 157
| e -> failwithf "Unsupported expression %A" e
and hashV v =
hash v.Name <+ hash v.IsMutable <+ hashT v.Type
and hashT t =
let rec recHashT types (t: System.Type) =
if t.IsPrimitive || t = typeof<string> then
hash t.FullName
else
t.GetFields(BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.GetField) |> Seq.fold (!< (fun f ->
if Set.contains f.FieldType.FullName types
then hash f.Name
else recHashT (Set.add f.FieldType.FullName types) f.FieldType <+ hash f.Name) ) (hash t.FullName)
recHashT Set.empty t
and hashP p =
hash p.Name <+ hashT p.PropertyType
and hashF f =
hash f.Name <+ hashT f.FieldType
and hashOpt f o =
match o with
| Some e -> f e
| None -> 0
and hashB funcs (v,e) = hashV v <+ hashC funcs e
and hashCst c = hash c.Name
and hashCse c = hash c.Name
let rec codeHash =
function
| Lambda(v, Call(None, m, _)) ->
match Expr.TryGetReflectedDefinition(m) with
| Some f -> hashC Set.empty f
| None -> failwithf "The function %s definition cannot be found" m.Name
| Lambda(v1, (Lambda _ as l)) ->
codeHash l
| _ -> failwith "A simple quotation of the function to hash should be provided"
type Lst =
| End
| Next of int * Lst
[<ReflectedDefinition>]
let rec fold f seed =
function
| End -> seed
| Next(v, next) -> fold f (f seed v) next
let hashcode = Siriona.Library.CodeHash.codeHash <@ fold @>
printfn "%d" hashcode
@thinkbeforecoding
Copy link
Author

It's really usefull to invalidate projection/snapshots automatically in event sourcing:
Save your snapshots as:
(projectionHash, version, state)
when loading the snapshot, ditch it if projectionHash has changed...

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment