From 41dd9224fc280bada60abaa5c35e2ae947ee8198 Mon Sep 17 00:00:00 2001 From: Jand42 Date: Fri, 10 Feb 2017 14:30:03 +0100 Subject: [PATCH] Fix #642 F# generic inner functions compile if no macro needs local type parameter --- .../WebSharper.Compiler.FSharp/CodeReader.fs | 7 ++-- .../ProjectReader.fs | 7 +++- .../WebSharper.Compiler/Translator.fs | 18 +++++++-- src/compiler/WebSharper.Core/ASTTypes.fs | 16 +++++++- src/compiler/WebSharper.Core/Macros.fs | 7 ++-- src/sitelets/WebSharper.Web/ClientSideJson.fs | 39 ++++++++++--------- src/stdlib/WebSharper.Main/Macro.fs | 11 +++--- tests/WebSharper.Tests/Basis.fs | 12 ++++++ tests/WebSharper.Tests/Ref.fs | 4 ++ 9 files changed, 83 insertions(+), 38 deletions(-) diff --git a/src/compiler/WebSharper.Compiler.FSharp/CodeReader.fs b/src/compiler/WebSharper.Compiler.FSharp/CodeReader.fs index 15609223d..72f969840 100644 --- a/src/compiler/WebSharper.Compiler.FSharp/CodeReader.fs +++ b/src/compiler/WebSharper.Compiler.FSharp/CodeReader.fs @@ -329,13 +329,11 @@ type SymbolReader(comp : WebSharper.Compiler.Compilation) as self = member this.ReadTypeSt markStaticTP (tparams: Map) (t: FSharpType) = if t.IsGenericParameter then - match tparams.TryFind t.GenericParameter.Name with | Some i -> if markStaticTP && t.GenericParameter.IsSolveAtCompileTime then StaticTypeParameter i else TypeParameter i | _ -> - parsefailf "Failed to resolve generic parameter: %s, found: %s" - t.GenericParameter.Name (tparams |> Map.toSeq |> Seq.map fst |> String.concat ", ") + LocalTypeParameter else let t = getOrigType t let getFunc() = @@ -997,7 +995,8 @@ let rec transformExpression (env: Environment) (expr: FSharpExpr) = ) Lambda (args, transformExpression env body) | _ -> failwith "Failed to translate delegate creation" - | P.TypeLambda (gen, expr) -> tr expr + | P.TypeLambda (gen, expr) -> + tr expr | P.Quote expr -> tr expr | P.BaseValue _ -> Base | P.ILAsm("[I_ldelema (NormalAddress,false,ILArrayShape [(Some 0, null)],TypeVar 0us)]", _, [ arr; i ]) -> diff --git a/src/compiler/WebSharper.Compiler.FSharp/ProjectReader.fs b/src/compiler/WebSharper.Compiler.FSharp/ProjectReader.fs index 0b1eb428f..9a42a3906 100644 --- a/src/compiler/WebSharper.Compiler.FSharp/ProjectReader.fs +++ b/src/compiler/WebSharper.Compiler.FSharp/ProjectReader.fs @@ -104,8 +104,11 @@ let isAugmentedFSharpType (e: FSharpEntity) = (e.IsFSharpRecord || e.IsFSharpUnion || e.IsFSharpExceptionDeclaration) && not ( e.Attributes |> Seq.exists (fun a -> - a.AttributeType.FullName = "Microsoft.FSharp.Core.DefaultAugmentationAttribute" - && not (snd a.ConstructorArguments.[0] :?> bool) + let res = + a.AttributeType.FullName = "Microsoft.FSharp.Core.DefaultAugmentationAttribute" + && not (snd a.ConstructorArguments.[0] :?> bool) + if res then printfn "found DefaultAugmentation(false) on %s" e.FullName + res ) ) diff --git a/src/compiler/WebSharper.Compiler/Translator.fs b/src/compiler/WebSharper.Compiler/Translator.fs index bd69c1125..d26dc9675 100644 --- a/src/compiler/WebSharper.Compiler/Translator.fs +++ b/src/compiler/WebSharper.Compiler/Translator.fs @@ -624,6 +624,16 @@ type DotNetToJavaScript private (comp: Compilation, ?inProgress) = // printfn "curried %A: %s" currying (Debug.PrintExpression res) // res + member this.HandleMacroNeedsResolvedTypeArg(t, macroName) = + match t with + | TypeParameter i + | StaticTypeParameter i -> + this.Error(sprintf "Macro '%s' requires a resolved type argument for type parameter index %d. Mark the member with the Inline attribute." macroName i) + | LocalTypeParameter -> + this.Error(sprintf "Macro '%s' would use a local type parameter. Make the inner function non-generic or move it to module level and mark it with the Inline attribute" macroName) + | _ -> + this.Error(sprintf "Macro '%s' erroneusly reported MacroNeedsResolvedTypeArg on not a type parameter." macroName) + member this.CompileCall (info, opts: M.Optimizations, expr, thisObj, typ, meth, args, ?baseCall) = match thisObj with | Some (IgnoreSourcePos.Base as tv) -> @@ -709,13 +719,13 @@ type DotNetToJavaScript private (comp: Compilation, ?inProgress) = match fallback with | None -> this.Error(sprintf "No macro fallback found for '%s'" macro.Value.FullName) | Some f -> this.CompileCall (f, opts, expr, thisObj, typ, meth, args) - | MacroNeedsResolvedTypeArg -> + | MacroNeedsResolvedTypeArg t -> if currentIsInline then hasDelayedTransform <- true let typ = Generic (comp.FindProxied typ.Entity) typ.Generics Call(trThisObj, typ, meth, args |> List.map this.TransformExpression) else - this.Error(sprintf "Macro '%s' requires a resolved type argument." macro.Value.FullName) + this.HandleMacroNeedsResolvedTypeArg(t, macro.Value.FullName) getExpr macroResult | M.Remote (kind, handle, rh) -> let name, mnode = @@ -924,13 +934,13 @@ type DotNetToJavaScript private (comp: Compilation, ?inProgress) = match fallback with | None -> this.Error(sprintf "No macro fallback found for '%s'" macro.Value.FullName) | Some f -> this.CompileCtor (f, opts, expr, typ, ctor, args) - | MacroNeedsResolvedTypeArg -> + | MacroNeedsResolvedTypeArg t -> if currentIsInline then hasDelayedTransform <- true let typ = Generic (comp.FindProxied typ.Entity) typ.Generics Ctor(typ, ctor, trArgs()) else - this.Error(sprintf "Macro '%s' requires a resolved type argument." macro.Value.FullName) + this.HandleMacroNeedsResolvedTypeArg(t, macro.Value.FullName) getExpr macroResult | _ -> this.Error("Invalid metadata for constructor.") diff --git a/src/compiler/WebSharper.Core/ASTTypes.fs b/src/compiler/WebSharper.Core/ASTTypes.fs index 8a218239f..cc8009f5b 100644 --- a/src/compiler/WebSharper.Core/ASTTypes.fs +++ b/src/compiler/WebSharper.Core/ASTTypes.fs @@ -247,6 +247,8 @@ and Type = | VoidType /// used for F# statically resolved type parameters | StaticTypeParameter of int + /// used for F# inner generics + | LocalTypeParameter override this.ToString() = match this with @@ -262,6 +264,14 @@ and Type = | ByRefType t -> "byref<" + string t + ">" | VoidType -> "unit" | StaticTypeParameter i -> "^T" + string i + | LocalTypeParameter -> "'?" + + member this.IsParameter = + match this with + | TypeParameter _ + | StaticTypeParameter _ + | LocalTypeParameter -> true + | _ -> false member this.AssemblyQualifiedName = let combine (n, a) = n + ", " + a @@ -295,19 +305,21 @@ and Type = "Microsoft.FSharp.Core.FSharpFunc`2[[" + a.AssemblyQualifiedName + "],[" + r.AssemblyQualifiedName + "]]", "FSharp.Core" | ByRefType t -> getNameAndAsm t | VoidType -> "Microsoft.FSharp.Core.Unit", "FSharp.Core" + | LocalTypeParameter -> "$?", "" getNameAndAsm this |> combine member this.TypeDefinition = match this with | ConcreteType t -> t.Entity | StaticTypeParameter _ + | LocalTypeParameter | TypeParameter _ -> invalidOp "Generic parameter has no TypeDefinition" | ArrayType _ -> invalidOp "Array type has no TypeDefinition" | TupleType _ -> invalidOp "Tuple type has no TypeDefinition" | FSharpFuncType _ -> invalidOp "FSharpFunc type has no TypeDefinition" | ByRefType t -> t.TypeDefinition | VoidType -> invalidOp "Void type has no TypeDefinition" - + member this.SubstituteGenerics (gs : Type[]) = match this with | ConcreteType t -> ConcreteType { t with Generics = t.Generics |> List.map (fun p -> p.SubstituteGenerics gs) } @@ -318,6 +330,7 @@ and Type = | ByRefType t -> ByRefType (t.SubstituteGenerics gs) | VoidType -> VoidType | StaticTypeParameter i -> StaticTypeParameter i + | LocalTypeParameter -> LocalTypeParameter member this.SubstituteGenericsToSame(o : Type) = match this with @@ -329,6 +342,7 @@ and Type = | ByRefType t -> ByRefType (t.SubstituteGenericsToSame(o)) | VoidType -> VoidType | StaticTypeParameter i -> StaticTypeParameter i + | LocalTypeParameter -> LocalTypeParameter type MethodInfo = { diff --git a/src/compiler/WebSharper.Core/Macros.fs b/src/compiler/WebSharper.Core/Macros.fs index 835bbf7d2..08133ebad 100644 --- a/src/compiler/WebSharper.Core/Macros.fs +++ b/src/compiler/WebSharper.Core/Macros.fs @@ -58,10 +58,11 @@ type MacroResult = | MacroError of string /// Add code dependencies to the member containing the call for the macroed member. | MacroDependencies of list * MacroResult - /// Revert to next in chain tranlation stratedy for the call. + /// Revert to next in chain tranlation strategy for the call. | MacroFallback - /// - | MacroNeedsResolvedTypeArg + /// Report that the macro needs concrete type information. + /// Delays compilation of inlined calls until type resolution. + | MacroNeedsResolvedTypeArg of Type static member Map f m = match m with diff --git a/src/sitelets/WebSharper.Web/ClientSideJson.fs b/src/sitelets/WebSharper.Web/ClientSideJson.fs index 722be2fd2..91998b7e6 100644 --- a/src/sitelets/WebSharper.Web/ClientSideJson.fs +++ b/src/sitelets/WebSharper.Web/ClientSideJson.fs @@ -272,7 +272,7 @@ module Macro = let m = comp.GetClassInfo(providerType).Value.Methods.Keys |> Seq.find (fun m -> m.Value.MethodName = "Id") Call(None, NonGeneric providerType, NonGeneric m, []) - type EncodeResult = Choice + type EncodeResult = Choice let (>>=) (x: EncodeResult) (f: Expression -> EncodeResult) = match x with @@ -280,10 +280,15 @@ module Macro = | _ -> x let ok x = Choice1Of3 x : EncodeResult let fail x = Choice2Of3 x : EncodeResult - let generic = Choice3Of3 () : EncodeResult + let generic t = Choice3Of3 t : EncodeResult + + let mapOk f x = + match x with + | Choice1Of3 x -> Choice1Of3 (f x) + | _ -> x /// Returns None if MacroNeedsResolvedTypeArg. - let getEncoding name isEnc param (t: Type) : option = + let getEncoding name isEnc param (t: Type) : EncodeResult = let warn msg = param.Warnings.Add msg let addTypeDep td = param.Dependencies.Add (M.TypeNode td) let comp = param.Compilation @@ -358,7 +363,7 @@ module Macro = fail (name + ": Cannot de/serialize a byref value.") | StaticTypeParameter _ | TypeParameter _ -> - generic + generic t // Encode a type that might be recursively defined and encRecType t targs args = match comp.GetCustomTypeInfo t.TypeDefinition with @@ -529,27 +534,23 @@ module Macro = <| [] | _ -> fail (name + ": Type not supported: " + t.TypeDefinition.Value.FullName) - match encode t with - | Choice1Of3 x -> - Some x - | Choice2Of3 msg -> failwithf "%A: %s" t msg - | Choice3Of3 () -> None + encode t let encodeLambda name param t = getEncoding name true param t - |> Option.map (fun x -> Application(x, [], true, Some 0)) + |> mapOk (fun x -> Application(x, [], true, Some 0)) let encode name param t arg = encodeLambda name param t - |> Option.map (fun x -> Application(x, [arg], true, Some 1)) + |> mapOk (fun x -> Application(x, [arg], true, Some 1)) let decodeLambda name param t = getEncoding name false param t - |> Option.map (fun x -> Application(x, [], true, Some 0)) + |> mapOk (fun x -> Application(x, [], true, Some 0)) let decode name param t arg = decodeLambda name param t - |> Option.map (fun x -> Application(x, [arg], true, Some 1)) + |> mapOk (fun x -> Application(x, [arg], true, Some 1)) let Encode param t arg = // ENCODE()(arg) @@ -562,11 +563,11 @@ module Macro = let Serialize param t arg = // JSON.stringify(ENCODE()(arg)) encode "Serialize" param t arg - |> Option.map (fun x -> mJson param.Compilation "Stringify" [x]) + |> mapOk (fun x -> mJson param.Compilation "Stringify" [x]) let SerializeLambda param t = encodeLambda "SerializeLambda" param t - |> Option.map (fun x -> + |> mapOk (fun x -> let enc = Id.New(mut = false) let arg = Id.New(mut = false) // let enc = ENCODE() in fun arg -> JSON.stringify(enc(arg)) @@ -588,7 +589,7 @@ module Macro = let DeserializeLambda param t = decodeLambda "DeserializeLambda" param t - |> Option.map (fun x -> + |> mapOk (fun x -> let dec = Id.New(mut = false) let arg = Id.New(mut = false) // let dec = DECODE() in fun arg -> dec(JSON.parse(arg)) @@ -620,9 +621,9 @@ module Macro = } let res = match f param c.Method.Generics.Head (last c.Arguments) with - | Some x -> - WebSharper.Core.MacroOk x - | None -> WebSharper.Core.MacroNeedsResolvedTypeArg + | Choice1Of3 x -> WebSharper.Core.MacroOk x + | Choice2Of3 e -> WebSharper.Core.MacroError e + | Choice3Of3 t -> WebSharper.Core.MacroNeedsResolvedTypeArg t let resWithWarnings = if param.Warnings.Count > 0 then param.Warnings |> Seq.fold (fun res msg -> diff --git a/src/stdlib/WebSharper.Main/Macro.fs b/src/stdlib/WebSharper.Main/Macro.fs index 45653046e..68d4c0723 100644 --- a/src/stdlib/WebSharper.Main/Macro.fs +++ b/src/stdlib/WebSharper.Main/Macro.fs @@ -976,8 +976,8 @@ type EqualityComparer() = } static member GetDefault(comp: M.ICompilation, t: Type) = + if t.IsParameter then MacroNeedsResolvedTypeArg t else match t with - | TypeParameter _ | StaticTypeParameter _ -> MacroNeedsResolvedTypeArg | ConcreteType ct -> match isImplementing comp ct.Entity ieqTy with | Some isEquatable -> @@ -1022,8 +1022,8 @@ type Comparer() = } static member GetDefault(comp: M.ICompilation, t: Type) = + if t.IsParameter then MacroNeedsResolvedTypeArg t else match t with - | TypeParameter _ | StaticTypeParameter _ -> MacroNeedsResolvedTypeArg | ConcreteType ct -> match isImplementing comp ct.Entity icmpTy with | Some isEquatable -> @@ -1055,7 +1055,9 @@ type DefaultOf() = inherit Macro() override __.TranslateCall(c) = - match c.Method.Generics.[0] with + let t = c.Method.Generics.[0] + if t.IsParameter then MacroNeedsResolvedTypeArg t else + match t with | ConcreteType td when (td.Entity.Value.Assembly.StartsWith "mscorlib" && match td.Entity.Value.FullName with @@ -1074,7 +1076,6 @@ type DefaultOf() = | "System.TimeSpan" -> true | _ -> false) -> MacroOk (Value (Int 0)) - | TypeParameter _ | StaticTypeParameter _ -> MacroNeedsResolvedTypeArg | ConcreteType td -> match c.Compilation.GetCustomTypeInfo td.Entity with | M.StructInfo -> @@ -1210,5 +1211,5 @@ type StringFormat() = defaultArg warningRes (MacroOk result) - | _ -> if c.IsInline then MacroNeedsResolvedTypeArg else MacroFallback + | _ -> MacroFallback | _ -> MacroError "proxy is for System.String.Format" \ No newline at end of file diff --git a/tests/WebSharper.Tests/Basis.fs b/tests/WebSharper.Tests/Basis.fs index 792bd356f..9340a14e4 100644 --- a/tests/WebSharper.Tests/Basis.fs +++ b/tests/WebSharper.Tests/Basis.fs @@ -89,6 +89,18 @@ type private T1 [] () = [] let private isNaN (x: double) = System.Double.IsNaN x +[] +let InnerGenerics pred l = + let rec loop l cont = + match l with + | [] -> ([],[]) + | x::[] when pred x -> + (cont l, []) + | x::xs when not (pred x) -> (cont [], l) + | x::xs when pred x -> loop xs (fun rest -> cont (x::rest)) + | _ -> failwith "Unrecognized pattern" + loop l id + [] let Tests = TestCategory "Basis" { diff --git a/tests/WebSharper.Tests/Ref.fs b/tests/WebSharper.Tests/Ref.fs index 34d2c4188..99db5aaa6 100644 --- a/tests/WebSharper.Tests/Ref.fs +++ b/tests/WebSharper.Tests/Ref.fs @@ -42,4 +42,8 @@ let Tests = r.contents <- 4 equal r.contents 4 } + + Test "Does not have prototype" { + jsEqual ((ref 1).JS.Constructor) (JS.Global?Array) + } }