From 3ea717c9f9de008cbac6d30895bbfa72bc80570c Mon Sep 17 00:00:00 2001 From: Jand42 Date: Sat, 18 Feb 2017 11:32:46 +0100 Subject: [PATCH] WIP #660 Erased Union types --- .../WebSharper.Compiler.FSharp/CodeReader.fs | 8 +++-- .../WebSharper.Compiler/Translator.fs | 19 +++++++++-- .../WebSharper.Compiler/WIGCompile.fs | 2 +- src/compiler/WebSharper.Core/ASTHelpers.fs | 11 +++++++ src/compiler/WebSharper.Core/Interop.fs | 33 +++++++++++++++++++ src/compiler/WebSharper.Core/Json.fs | 1 - src/compiler/WebSharper.Core/genInterop.fsx | 7 +++- .../WebSharper.InterfaceGenerator/Type.fs | 8 +---- tests/WebSharper.Collections.Tests/Interop.fs | 3 ++ tests/WebSharper.Tests/WIG.fs | 20 +++++------ tests/WebSharper.Web.Tests/ClientSideJson.fs | 2 +- 11 files changed, 89 insertions(+), 25 deletions(-) diff --git a/src/compiler/WebSharper.Compiler.FSharp/CodeReader.fs b/src/compiler/WebSharper.Compiler.FSharp/CodeReader.fs index ec9c6378b..0b424af60 100644 --- a/src/compiler/WebSharper.Compiler.FSharp/CodeReader.fs +++ b/src/compiler/WebSharper.Compiler.FSharp/CodeReader.fs @@ -776,8 +776,12 @@ let rec transformExpression (env: Environment) (expr: FSharpExpr) = else NewUnionCase(t, case.CompiledName, exprs |> List.map tr) | P.UnionCaseGet (expr, typ, case, field) -> - let i = case.UnionCaseFields |> Seq.findIndex (fun f -> f = field) - ItemGet(tr expr, Value (String ("$" + string i))) + let td = sr.ReadTypeDefinition typ.TypeDefinition + if erasedUnions.Contains td then + tr expr + else + let i = case.UnionCaseFields |> Seq.findIndex (fun f -> f = field) + ItemGet(tr expr, Value (String ("$" + string i))) | P.UnionCaseTest (expr, typ, case) -> let t = match sr.ReadType env.TParams typ with diff --git a/src/compiler/WebSharper.Compiler/Translator.fs b/src/compiler/WebSharper.Compiler/Translator.fs index 29f0f7ffc..0be3c02aa 100644 --- a/src/compiler/WebSharper.Compiler/Translator.fs +++ b/src/compiler/WebSharper.Compiler/Translator.fs @@ -970,6 +970,11 @@ type DotNetToJavaScript private (comp: Compilation, ?inProgress) = override this.TransformNewUnionCase(typ, case, args) = let t = typ.Entity + if erasedUnions.Contains t then + match args with + | [ a ] -> this.TransformExpression a + | _ -> this.Error("Erased union constructor expects a single argument") + else match comp.GetCustomType typ.Entity with | M.FSharpUnionInfo u -> let i, c = u.Cases |> Seq.indexed |> Seq.find (fun (i, c) -> c.Name = case) @@ -986,6 +991,14 @@ type DotNetToJavaScript private (comp: Compilation, ?inProgress) = | _ -> this.Error("Failed to translate union case creation.") override this.TransformUnionCaseTest(expr, typ, case) = + if erasedUnions.Contains typ.Entity then + let i = int case.[5] - 49 // int '1' is 49 + try + this.TransformTypeCheck(expr, typ.Generics.[i]) + with e -> + this.Error(sprintf "Translating erased union test failed, case: %s, generics: %A" + case (typ.Generics |> List.map (fun t -> t.AssemblyQualifiedName))) + else match comp.GetCustomType typ.Entity with | M.FSharpUnionInfo u -> let i, c = u.Cases |> Seq.indexed |> Seq.find (fun (i, c) -> c.Name = case) @@ -1003,6 +1016,7 @@ type DotNetToJavaScript private (comp: Compilation, ?inProgress) = | _ -> this.Error("Failed to translate union case test.") override this.TransformUnionCaseTag(expr, typ) = + // Todo: tag for erased union match comp.GetCustomType typ.Entity with | M.FSharpUnionInfo u -> let constantCases = @@ -1234,7 +1248,7 @@ type DotNetToJavaScript private (comp: Compilation, ?inProgress) = typeof "function" | tname -> if not (List.isEmpty gs) then - this.Warning ("Generic type check is ignoring erased type parameter.") + this.Warning ("Type test in JavaScript translation is ignoring erased type parameter.") match comp.TryLookupClassInfo t with | Some c -> match c.Address with @@ -1252,7 +1266,8 @@ type DotNetToJavaScript private (comp: Compilation, ?inProgress) = let i = Id.New (mut = false) Let (i, trE, this.TransformTypeCheck(Var i, ConcreteType uTyp) ^&& this.TransformUnionCaseTest(Var i, uTyp, c.Name)) | M.DelegateInfo _ -> - this.Error("Type tests do not support delegate type, check against WebSharper.JavaScript.Function.") + this.Warning("Type test JavaScript translation is ignoring the signature of the delegate.") + typeof "function" | _ -> this.Error(sprintf "Failed to compile a type check for type '%s'" tname) | TypeParameter _ | StaticTypeParameter _ -> diff --git a/src/compiler/WebSharper.Compiler/WIGCompile.fs b/src/compiler/WebSharper.Compiler/WIGCompile.fs index 0036a3ba1..73d341e0a 100644 --- a/src/compiler/WebSharper.Compiler/WIGCompile.fs +++ b/src/compiler/WebSharper.Compiler/WIGCompile.fs @@ -359,7 +359,7 @@ type TypeBuilder(aR: IAssemblyResolver, out: AssemblyDefinition, fsCoreFullName: createTuple (Array.ofSeq ts) member b.Choice(ts: seq) = - commonType fscore "Microsoft.FSharp.Core" "FSharpChoice" ts + commonType wsCore "WebSharper.JavaScript" "Union" ts member b.Option t = genericInstance optionType [t] diff --git a/src/compiler/WebSharper.Core/ASTHelpers.fs b/src/compiler/WebSharper.Core/ASTHelpers.fs index 77d5f4a9d..706cdb380 100644 --- a/src/compiler/WebSharper.Core/ASTHelpers.fs +++ b/src/compiler/WebSharper.Core/ASTHelpers.fs @@ -183,3 +183,14 @@ let (|UnaryOpName|_|) = function | "op_UnaryNegation" -> Some UnaryOperator.``-`` | "op_OnesComplement" -> Some UnaryOperator.``~`` | _ -> None + +let erasedUnions = + System.Collections.Generic.HashSet ( + seq { + for i in 2 .. 7 -> + TypeDefinition { + Assembly = "WebSharper.Core" + FullName = "WebSharper.JavaScript.Union`" + string i + } + } + ) \ No newline at end of file diff --git a/src/compiler/WebSharper.Core/Interop.fs b/src/compiler/WebSharper.Core/Interop.fs index 1a12f57ec..6d0149b29 100644 --- a/src/compiler/WebSharper.Core/Interop.fs +++ b/src/compiler/WebSharper.Core/Interop.fs @@ -295,4 +295,37 @@ type ThisParamsFunc<'TThis, 'T1, 'T2, 'T3, 'T4, 'T5, 'T6, 'TParams, 'TResult> = new (del: System.Func<'TThis, 'T1, 'T2, 'T3, 'T4, 'T5, 'T6, 'TParams, 'TResult>) = { } member this.Bind(thisArg: 'TThis) = X> member this.Call(thisArg: 'TThis, arg1: 'T1, arg2: 'T2, arg3: 'T3, arg4: 'T4, arg5: 'T5, arg6: 'T6, [] rest: 'TParams[]) = X<'TResult> +type Union<'T1, 'T2> = + | Union1Of2 of 'T1 + | Union2Of2 of 'T2 +type Union<'T1, 'T2, 'T3> = + | Union1Of3 of 'T1 + | Union2Of3 of 'T2 + | Union3Of3 of 'T3 +type Union<'T1, 'T2, 'T3, 'T4> = + | Union1Of4 of 'T1 + | Union2Of4 of 'T2 + | Union3Of4 of 'T3 + | Union4Of4 of 'T4 +type Union<'T1, 'T2, 'T3, 'T4, 'T5> = + | Union1Of5 of 'T1 + | Union2Of5 of 'T2 + | Union3Of5 of 'T3 + | Union4Of5 of 'T4 + | Union5Of5 of 'T5 +type Union<'T1, 'T2, 'T3, 'T4, 'T5, 'T6> = + | Union1Of6 of 'T1 + | Union2Of6 of 'T2 + | Union3Of6 of 'T3 + | Union4Of6 of 'T4 + | Union5Of6 of 'T5 + | Union6Of6 of 'T6 +type Union<'T1, 'T2, 'T3, 'T4, 'T5, 'T6, 'T7> = + | Union1Of7 of 'T1 + | Union2Of7 of 'T2 + | Union3Of7 of 'T3 + | Union4Of7 of 'T4 + | Union5Of7 of 'T5 + | Union6Of7 of 'T6 + | Union7Of7 of 'T7 // }} diff --git a/src/compiler/WebSharper.Core/Json.fs b/src/compiler/WebSharper.Core/Json.fs index fa6eea101..52f7d3bee 100644 --- a/src/compiler/WebSharper.Core/Json.fs +++ b/src/compiler/WebSharper.Core/Json.fs @@ -585,7 +585,6 @@ let serializers = | x -> raise (DecoderException(x, typeof)) add encChar decChar d let decString = function - | Null -> null | String x -> x | x -> raise (DecoderException(x, typeof)) add EncodedString decString d diff --git a/src/compiler/WebSharper.Core/genInterop.fsx b/src/compiler/WebSharper.Core/genInterop.fsx index 8fe7c7e7f..dfc2de85c 100644 --- a/src/compiler/WebSharper.Core/genInterop.fsx +++ b/src/compiler/WebSharper.Core/genInterop.fsx @@ -40,7 +40,7 @@ let code = let inline cprintfn x = Printf.kprintf code.Add x for i = 0 to maxArgCount do - cprintfn "type FuncWithRest<'TRest, %s'TResult> =" (tArgs i |> concatE ", ") + cprintfn "type FuncWithRest<%s'TRest, 'TResult> =" (tArgs i |> concatE ", ") cprintfn " inherit Function" cprintfn " new (func: %s'TRest[] -> 'TResult) = { }" (tArgs i |> concatE " * ") cprintfn " member this.Call (%s[] rest: 'TRest[]) = X<'TResult>" (args i |> concatE ", ") @@ -62,6 +62,11 @@ let code = cprintfn " member this.Bind(thisArg: 'TThis) = X<%s%s%s>" (if pars then "Params" else "System.") del (toTypArgs (List.tail t)) cprintfn " member this.Call(%s) = X<%s>" (a |> String.concat ", ") (if ret then "'TResult" else "unit") + for i = 2 to 7 do + cprintfn "type Union<%s> =" (tArgs i |> String.concat ", ") + for j = 1 to i do + cprintfn " | Union%dOf%d of 'T%d" j i j + code.ToArray() let allCode = diff --git a/src/compiler/WebSharper.InterfaceGenerator/Type.fs b/src/compiler/WebSharper.InterfaceGenerator/Type.fs index 5125687b0..16e8587a6 100644 --- a/src/compiler/WebSharper.InterfaceGenerator/Type.fs +++ b/src/compiler/WebSharper.InterfaceGenerator/Type.fs @@ -575,12 +575,6 @@ module Type = | _ -> fun x -> "function(args) { return (" + x + ").apply(null, args.slice(0, " + string i + ").concat(args[ " + string i + "])); }" } - - let private unionTransform optional typeStrings = - { - In = fun x -> x + ".$0" - Out = fun x -> sprintf "$wsruntime.UnionByType([%s], %s%s)" (String.concat ", " typeStrings) x (if optional then ", true" else "") - } let (|UnionOf|_|) t = let rec getTypes t = @@ -693,7 +687,7 @@ module Type = if List.length tts = List.length ts then let ts, tts = (ts, tts) ||> List.zip |> List.sortBy snd |> List.unzip - InteropType (ChoiceType ts, unionTransform opt tts) + ChoiceType ts else t | _ -> t diff --git a/tests/WebSharper.Collections.Tests/Interop.fs b/tests/WebSharper.Collections.Tests/Interop.fs index 7448971b1..e4e71fcf7 100644 --- a/tests/WebSharper.Collections.Tests/Interop.fs +++ b/tests/WebSharper.Collections.Tests/Interop.fs @@ -97,6 +97,9 @@ module Module = let mutable ValueB = 2 + let ErasedUnion1 = JavaScript.Union.Union1Of2 42 + let ErasedUnion2 = JavaScript.Union.Union2Of2 "hi" + [] type GenericClass<'T>() = member this.GenericMethod<'U>(x: 'U) = x \ No newline at end of file diff --git a/tests/WebSharper.Tests/WIG.fs b/tests/WebSharper.Tests/WIG.fs index 74ac0edb8..af9b0f73b 100644 --- a/tests/WebSharper.Tests/WIG.fs +++ b/tests/WebSharper.Tests/WIG.fs @@ -68,7 +68,7 @@ let Tests = Test "Functions with ParamArray" { let doNotRun() = (WIGtest.TestCurriedSig(0).Invoke("") : obj) |> ignore - (WIGtest.TestIntOrStringReturned() : Choice) |> ignore + (WIGtest.TestIntOrStringReturned() : Union) |> ignore (WIGtest.TestWithNoInterop : FuncWithArgs -> obj) |> ignore equal (WIGtest.Sum(1)) 1 @@ -115,11 +115,11 @@ let Tests = Test "Choice property" { let x = WIGtest.Instance - equal (x.StringOrInt) (Choice1Of2 0) - x.StringOrInt <- Choice2Of2 "hi" - equal (x.StringOrInt) (Choice2Of2 "hi") - x.StringOrInt <- Choice1Of2 1 - equal (x.StringOrInt) (Choice1Of2 1) + equal (x.StringOrInt) (Union1Of2 0) + x.StringOrInt <- Union2Of2 "hi" + equal (x.StringOrInt) (Union2Of2 "hi") + x.StringOrInt <- Union1Of2 1 + equal (x.StringOrInt) (Union1Of2 1) } Test "Option property" { @@ -134,12 +134,12 @@ let Tests = Test "Optional choice property" { let x = WIGtest.Instance equal (x.OptionalStringOrFunction) None - x.OptionalStringOrFunction <- Some (Choice2Of2 "hi") - equal (x.OptionalStringOrFunction) (Some (Choice2Of2 "hi")) - x.OptionalStringOrFunction <- Some (Choice1Of2 (System.Func<_,_,_>(fun a b -> a + b))) + x.OptionalStringOrFunction <- Some (Union2Of2 "hi") + equal (x.OptionalStringOrFunction) (Some (Union2Of2 "hi")) + x.OptionalStringOrFunction <- Some (Union1Of2 (System.Func<_,_,_>(fun a b -> a + b))) equal ( match x.OptionalStringOrFunction with - | Some (Choice1Of2 f) -> f.Invoke(1, 2) + | Some (Union1Of2 f) -> f.Invoke(1, 2) | _ -> 0 ) 3 x.OptionalStringOrFunction <- None diff --git a/tests/WebSharper.Web.Tests/ClientSideJson.fs b/tests/WebSharper.Web.Tests/ClientSideJson.fs index 37be6db9b..13c16d5f7 100644 --- a/tests/WebSharper.Web.Tests/ClientSideJson.fs +++ b/tests/WebSharper.Web.Tests/ClientSideJson.fs @@ -338,7 +338,7 @@ module ClientSideJson = JQuery.AjaxSettings( Url = url, Type = JQuery.RequestType.POST, - ContentType = Choice.Choice2Of2("application/json"), + ContentType = Union2Of2("application/json"), DataType = JQuery.DataType.Json, Data = serializedArg, Success = (fun data _ _ -> ok (decode data)),