Using untyped F# quotations to copy an array without knowing the type
-
20-12-2019 - |
Question
I'm working on a small project to using quotations to clone trees of some basic record types and I have it working in most cases, the big problem I'm having is with arrays.
module FSharpType =
/// predicate for testing types to see if they are generic option types
let IsOption (stype: System.Type) = stype.Name = "FSharpOption`1"
/// predicate for testing types to see if they are generic F# lists
let IsList (stype: System.Type) = stype.Name = "FSharpList`1"
module RecordCloning =
let inline application prms expr = Expr.Application(expr, prms)
let inline coerse typ expr = Expr.Coerce(expr, typ)
let (|IsMapType|_|) (t: Type) =
if t.IsGenericType && t.GetGenericTypeDefinition() = typedefof<Map<_,_>> 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<String> -> <@@ id @@>
| _ when mtype.IsArray -> genArrayCopier mtype
| IsMapType t -> <@@ id @@>
| _ when mtype = typeof<System.Object> -> <@@ id @@>
| _ -> failwithf "Unexpected Type: %s" (mtype.ToString())
and genRecordCopier (rtype: Type) : Expr =
let arg = Var("x", typeof<obj>, false)
let argExpr = Expr.Var(arg)
let useArg = Expr.Coerce(argExpr, rtype)
let fields = FSharpType.GetRecordFields(rtype)
let members = [ for field in fields -> genFieldCopy useArg field ]
let newrec = Expr.Coerce(Expr.NewRecord(rtype, members),typeof<obj>)
Expr.Lambda(arg, newrec)
and genFieldCopy argExpr (field: PropertyInfo) : Expr =
let pval = Expr.PropertyGet(argExpr, field)
let convfun = copyThing field.PropertyType
let applied = Expr.Application (convfun, Expr.Coerce(pval, typeof<obj>))
Expr.Coerce(applied, field.PropertyType)
and castToType (atype : Type) : Expr =
let arg = Var("x", typeof<obj>, false)
let argExpr = Expr.Var(arg)
Expr.Lambda(arg, Expr.Coerce(argExpr, atype))
and coerseLambda (outterType: Type) (lambda: Expr) : Expr =
let arg = Var("x", outterType, false)
let argExpr = Expr.Var(arg)
let wrappedLambda =
lambda
|> application (argExpr |> coerse typeof<obj>)
|> coerse outterType
Expr.Lambda(arg, wrappedLambda)
and genArrayCopier (atype : Type) : Expr =
let etype = atype.GetElementType()
let copyfun = copyThing etype
let arg = Var("arr", typeof<obj>, false)
let argExpr = Expr.Var(arg) |> coerse atype
let wrappedLambda = coerseLambda etype copyfun
let func = <@@ Array.map (%%wrappedLambda) (%%argExpr) @@>
Expr.Lambda(arg, func)
and genOptionCopier (otype: Type) : Expr =
let etype = otype.GetGenericArguments().[0]
let copyfun = copyThing etype
<@@ fun (inobj: obj) ->
let x = inobj :?> Option<'t>
match x with
| Some v -> Some <| (%%copyfun) (box v)
| None -> None
|> box
@@>
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", typeof<obj>, false)
let argExpr = Expr.Var(arg)
let useArg = Expr.Coerce(argExpr, utype)
let genCaseTest case = Expr.UnionCaseTest (useArg, case)
let makeCopyCtor (ci: UnionCaseInfo) =
let copiedMembers = [ for field in ci.GetFields() -> genFieldCopy useArg field ]
Expr.Coerce(Expr.NewUnionCase(ci, copiedMembers), typeof<obj>)
let genIf ifCase thenCase elseCase = Expr.IfThenElse(ifCase, thenCase, elseCase)
let nestedIfs =
cases
|> Array.map (fun case -> genIf (genCaseTest case) (makeCopyCtor case))
|> Array.foldBack (fun iff st -> iff st) <| <@@ failwith "Unexpected Case Condition" @@>
let newunion = Expr.Coerce(nestedIfs,typeof<obj>)
Expr.Lambda(arg, newunion)
let wrapInType<'I,'O> (lambdaExpr: Expr) : Expr<'I -> 'O> =
<@ fun (v : 'I) -> (%%lambdaExpr : obj -> obj) (box v) :?> 'O @>
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<Func<'I,'O>>(lambda.Body, lambda.Parameters)
let genrateRecordDeepCopyFunction<'T> () : ('T -> 'T) =
let expr = genRecordCopier typeof<'T>
let castExpr : Expr<obj -> obj> = expr |> Expr.Cast
let compiledExpr = (castExpr |> toLinq).Compile()
fun (v : 'T) -> compiledExpr.Invoke(box v) :?> 'T
I've tried several approaches, but I always get complaints about wanting (string -> string) but getting (obj -> obj) or wanting (object [] -> object []) but getting (string [] -> string []). Any ideas?
Here's a simple test case.
type SimpleArrayRecord = { Names: string array }
[<Fact>]
let ``record cloning should be able to clone a record with a simple array`` () =
let sr = { Names = [|"Rick"; "David"; "Mark"; "Paul"; "Pete"|] }
let func = RecordCloning.genrateRecordDeepCopyFunction<SimpleArrayRecord>()
let res = func sr
Assert.Equal(sr, res)
Here's the method that has gotten me the furthest. The issue seems to be that I can't get it to make the array typed, and so it always fails on the cast when trying to build the record. Adding a cast in the comprehension doesn't help.
and genArrayCopier (atype : Type) : Expr =
let etype = atype.GetElementType()
let copyfun = copyThing etype
let arg = Var("arr", typeof<obj>, false)
let argExpr = Expr.Var(arg) |> coerse atype
<@@ fun (inobj: obj) ->
let arr = inobj :?> obj[] in
[| for i = 0 to arr.Length - 1 do yield (%%copyfun) (Array.get arr i) |] |> box @@>
Toyvo's solution below works for the example above but not for arrays of records:
type SimpleRecord = { Name: string; Age: int }
type LotsOfRecords = { People: SimpleRecord [] }
[<Fact>]
let ``record cloning should be able to clone a record with an array of records`` () =
let sr = { People = [|{Name = "Rick"; Age = 33 }; { Name = "Paul"; Age = 55 }|] }
let func = RecordCloning.genrateRecordDeepCopyFunction<LotsOfRecords>()
let res = func sr
Assert.Equal(sr, res)
For those who come later, here's the working code. I removed Option and haven't taken the time to clean it up but it's otherwise pretty decent.
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<Map<_,_>> 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<String> -> getIdFunc mtype
| _ when mtype.IsArray -> genArrayCopier mtype
| IsMapType t -> getIdFunc mtype
| _ when mtype = typeof<System.Object> -> 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) //|> coerse rtype
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)
Now it actually works with unions as well. Cheers!
Solution
If you do this, make sure you understand generics and how to generate them. You are in LISP land, type system won't help you, since it cannot reason about itself - you are manipulating F# terms with F#.
and getMethod q =
match q with
| Patterns.Call (_, m, _) ->
if m.IsGenericMethod then
m.GetGenericMethodDefinition()
else
m
| _ -> failwith "getMethod"
and X<'T> : 'T =
Unchecked.defaultof<'T>
and genArrayCopier (atype : Type) : Expr =
let etype = atype.GetElementType()
let copyfun = copyThing etype
let arg = Var("arr", typeof<obj>, false)
let argExpr = Expr.Var(arg) |> coerse atype
let wrappedLambda = coerseLambda etype copyfun
let func =
let m = getMethod <@ Array.map X X @> // obtained (forall 'X 'Y, 'X[] -> 'Y[])
let m = m.MakeGenericMethod([| etype; etype |]) // specialized to 'E[] -> 'E[]
Expr.Call(m, [wrappedLambda; argExpr]) // now this type-checks
Expr.Lambda(arg, func)