#r "System.Data.Linq" open System open System.Reflection open System.ComponentModel open System.Linq.Expressions open Microsoft.FSharp.Reflection open Microsoft.FSharp.Quotations module FSharpType = let IsOption (stype: System.Type) = stype.Name = "FSharpOption`1" module RecordCloning = let inline application prms expr = Expr.Application(expr, prms) let inline coerse typ expr = Expr.Coerce(expr, typ) let inline newrec typ args = Expr.NewRecord(typ, args) let (|IsMapType|_|) (t: Type) = if t.IsGenericType && t.GetGenericTypeDefinition() = typedefof> then Some t else None let rec copyThing (mtype: Type) : Expr = match mtype with | _ when FSharpType.IsRecord mtype -> genRecordCopier mtype | _ when FSharpType.IsUnion mtype -> genUnionCopier mtype | _ when mtype.IsValueType || mtype = typeof -> getIdFunc mtype | _ when mtype.IsArray -> genArrayCopier mtype | IsMapType t -> getIdFunc mtype | _ when mtype = typeof -> getIdFunc mtype | _ -> failwithf "Unexpected Type: %s" (mtype.ToString()) and X<'T> : 'T = Unchecked.defaultof<'T> and getMethod = function | Patterns.Call (_, m, _) when m.IsGenericMethod -> m.GetGenericMethodDefinition() | Patterns.Call (_, m, _) -> m | _ -> failwith "Incorrect getMethod Pattern" and getIdFunc itype = let arg = Var("x", itype, false) let argExpr = Expr.Var(arg) let func = let m = (getMethod <@ id X @>).MakeGenericMethod([|itype|]) Expr.Call(m, [argExpr]) Expr.Lambda(arg, func) and genRecordCopier (rtype: Type) : Expr = let arg = Var("x", rtype, false) let argExpr = Expr.Var(arg) let newrec = FSharpType.GetRecordFields(rtype) |> Array.toList |> List.map (fun field -> genFieldCopy argExpr field) |> newrec rtype Expr.Lambda(arg, newrec) and genFieldCopy argExpr (field: PropertyInfo) : Expr = let pval = Expr.PropertyGet(argExpr, field) copyThing field.PropertyType |> application pval and genArrayCopier (atype : Type) : Expr = let etype = atype.GetElementType() let copyfun = copyThing etype let arg = Var("arr", atype, false) let argExpr = Expr.Var(arg) let func = let m = (getMethod <@ Array.map X X @>).MakeGenericMethod([|etype; etype|]) Expr.Call(m, [copyfun; argExpr]) Expr.Lambda(arg, func) and genUnionCopier (utype: Type) : Expr = let cases = FSharpType.GetUnionCases utype // if - union case - then - copy each field into new case - else - next case let arg = Var("x", utype, false) let useArg = Expr.Var(arg) let genCaseTest case = Expr.UnionCaseTest (useArg, case) let makeCopyCtor (ci: UnionCaseInfo) = let copiedMembers = [ for field in ci.GetFields() -> genFieldCopy useArg field ] Expr.NewUnionCase(ci, copiedMembers) let genIf ifCase thenCase elseCase = Expr.IfThenElse(ifCase, thenCase, elseCase) let typedFail (str: string) = let m = (getMethod <@ failwith str @>).MakeGenericMethod([|utype|]) Expr.Call(m, [ <@ str @> ]) let nestedIfs = cases |> Array.map (fun case -> genIf (genCaseTest case) (makeCopyCtor case)) |> Array.foldBack (fun iff st -> iff st) <| (typedFail "Unexpected Case in Union") Expr.Lambda(arg, nestedIfs) let toLinq<'I,'O> (expr: Expr<'I -> 'O>) = let linq = Microsoft.FSharp.Linq.RuntimeHelpers.LeafExpressionConverter.QuotationToExpression expr let call = linq :?> MethodCallExpression let lambda = call.Arguments.[0] :?> LambdaExpression Expression.Lambda>(lambda.Body, lambda.Parameters) let genrateRecordDeepCopyFunction<'T> () : ('T -> 'T) = let expr = genRecordCopier typeof<'T> let castExpr : Expr<'T -> 'T> = expr |> Expr.Cast let compiledExpr = (castExpr |> toLinq).Compile() fun (v : 'T) -> compiledExpr.Invoke(v)