diff --git a/src/Fable.Cli/Parser.fs b/src/Fable.Cli/Parser.fs index a1cd75867c..8a03bafcd0 100644 --- a/src/Fable.Cli/Parser.fs +++ b/src/Fable.Cli/Parser.fs @@ -60,6 +60,7 @@ let toCompilerOptions (msg: Message): CompilerOptions = debugMode = Array.contains "DEBUG" msg.define verbosity = GlobalParams.Singleton.Verbosity outputPublicInlinedFunctions = Array.contains "FABLE_REPL_LIB" msg.define + quotations = Array.contains "FABLE_QUOTATIONS" msg.define precompiledLib = None } diff --git a/src/Fable.Transforms/AST/AST.Fable.fs b/src/Fable.Transforms/AST/AST.Fable.fs index c6c6b984ae..89fea9bb94 100644 --- a/src/Fable.Transforms/AST/AST.Fable.fs +++ b/src/Fable.Transforms/AST/AST.Fable.fs @@ -15,6 +15,7 @@ type Type = | Char | String | Regex + | Expr of gen : Option | Number of NumberKind | Enum of FSharpEntity | Option of genericArg: Type @@ -29,7 +30,7 @@ type Type = member this.Generics = match this with - | Option gen | Array gen | List gen -> [gen] + | Expr (Some gen) | Option gen | Array gen | List gen -> [gen] | FunctionType(LambdaType argType, returnType) -> [argType; returnType] | FunctionType(DelegateType argTypes, returnType) -> argTypes @ [returnType] | Tuple gen -> gen @@ -38,6 +39,7 @@ type Type = | _ -> [] member this.ReplaceGenerics(newGen: Type list) = match this with + | Expr (Some _) -> Expr (Some newGen.Head) | Option _ -> Option newGen.Head | Array _ -> Array newGen.Head | List _ -> List newGen.Head @@ -52,6 +54,32 @@ type Type = | DeclaredType(ent,_) -> DeclaredType(ent,newGen) | t -> t + +type ParameterInfo = + { + Name : string + Type : Type + } + +type MemberInfoKind = + | Property of name : string * typ : Type * fsharp : bool * isStatic : bool * get : Option * set : Option + | Field of name : string * typ : Type * isStatic : bool * get : Option + | Method of genericParameters : string[] * name : string * parameters : ParameterInfo[] * returnType : Type * isStatic : bool * invoke : Option + | Constructor of parameters : ParameterInfo[] * invoke : Expr + | UnionCaseConstructor of tag : int * name : string * parameters : array * mangledName : string * mangledTypeName : string + +type MemberInfo = + { + Kind : MemberInfoKind + Attributes : array + } + +type UnionCaseInfo = + { + Name : string + Fields : MemberInfo[] + } + type ValueDeclarationInfo = { Name: string IsPublic: bool @@ -63,6 +91,7 @@ type ValueDeclarationInfo = type ClassImplicitConstructorInfo = { Name: string Entity: FSharpEntity + Members : MemberInfo[] EntityName: string IsEntityPublic: bool IsConstructorPublic: bool @@ -74,11 +103,13 @@ type ClassImplicitConstructorInfo = type UnionConstructorInfo = { Entity: FSharpEntity + Members : MemberInfo[] EntityName: string IsPublic: bool } type CompilerGeneratedConstructorInfo = { Entity: FSharpEntity + Members : MemberInfo[] EntityName: string IsPublic: bool } @@ -96,7 +127,8 @@ type Declaration = | ActionDeclaration of Expr | ValueDeclaration of Expr * ValueDeclarationInfo | AttachedMemberDeclaration of args: Ident list * body: Expr * AttachedMemberDeclarationInfo - | ConstructorDeclaration of ConstructorKind * SourceLocation option + | ConstructorDeclaration of declaringName : Option * ConstructorKind * SourceLocation option + | ModuleDeclaration of declaringName : Option * name : string * ent : FSharpEntity * mems : MemberInfo[] type File(sourcePath, decls, ?usedVarNames, ?inlineDependencies) = member __.SourcePath: string = sourcePath @@ -271,6 +303,24 @@ type DelayedResolutionKind = | AsPojo of Expr * caseRules: Expr | Curry of Expr * arity: int + +type VarData = + { name : string; typ : Type; isMutable : bool } + +type ValueData = + { name : string; typ : Type; expr : Expr } + +type ExprData = + { + typ : Type + variables : VarData[] + values : ValueData[] + literals : Expr[] + types : Type[] + members : array + data : byte[] + } + type Expr = | Value of ValueKind * SourceLocation option | IdentExpr of Ident @@ -300,8 +350,12 @@ type Expr = | TryCatch of body: Expr * catch: (Ident * Expr) option * finalizer: Expr option * range: SourceLocation option | IfThenElse of guardExpr: Expr * thenExpr: Expr * elseExpr: Expr * range: SourceLocation option + | Quote of typed : bool * data : ExprData * range : SourceLocation option + member this.Type = match this with + | Quote(true, value, _) -> Expr(Some value.typ) + | Quote(false, _, _) -> Expr None | Test _ -> Boolean | Value(kind,_) -> kind.Type | IdentExpr id -> id.Type @@ -320,10 +374,11 @@ type Expr = | Import _ | DelayedResolution _ | ObjectExpr _ | Sequential _ | Let _ | DecisionTree _ | DecisionTreeSuccess _ -> None - + | Function(_,e,_) | TypeCast(e,_) -> e.Range | IdentExpr id -> id.Range + | Quote(_,_,r) | Value(_,r) | IfThenElse(_,_,_,r) | TryCatch(_,_,_,r) | Debugger r | Test(_,_,r) | Operation(_,_,r) | Get(_,_,_,r) | Throw(_,_,r) | Set(_,_,_,r) | Loop(_,r) -> r diff --git a/src/Fable.Transforms/FSharp2Fable.Util.fs b/src/Fable.Transforms/FSharp2Fable.Util.fs index d41b46b3ae..118b7a25b2 100644 --- a/src/Fable.Transforms/FSharp2Fable.Util.fs +++ b/src/Fable.Transforms/FSharp2Fable.Util.fs @@ -22,7 +22,7 @@ type Context = InlinePath: (string * (SourceLocation option)) list CaptureBaseConsCall: (FSharpEntity * (Fable.Expr * Fable.Expr -> unit)) option } - static member Create(enclosingEntity) = + static member Create(enclosingEntity:Option) = { Scope = [] ScopeInlineValues = [] GenericArgs = Map.empty @@ -104,6 +104,18 @@ module Helpers = (getEntityMangledName com true ent, Naming.NoMemberPart) ||> Naming.sanitizeIdent (fun _ -> false) + let getModuleReflectionName (com: ICompiler) (ent : FSharpEntity) = + if ent.IsFSharpModule then + let name = + (getEntityMangledName com true ent, Naming.NoMemberPart) + ||> Naming.sanitizeIdent (fun _ -> false) + if name = "" then + Some "" + else + Some name + else + None + let isUnit (typ: FSharpType) = let typ = nonAbbreviatedType typ if typ.HasTypeDefinition @@ -144,6 +156,7 @@ module Helpers = | Naming.StaticMemberPart(_, overloadSuffix) -> String.IsNullOrEmpty(overloadSuffix) |> not | Naming.NoMemberPart -> false + | Naming.ReflectionMemberPart -> false sanitizedName, hasOverloadSuffix /// Used to identify members uniquely in the inline expressions dictionary diff --git a/src/Fable.Transforms/FSharp2Fable.fs b/src/Fable.Transforms/FSharp2Fable.fs index a24c828681..eb3cc90bf8 100644 --- a/src/Fable.Transforms/FSharp2Fable.fs +++ b/src/Fable.Transforms/FSharp2Fable.fs @@ -27,7 +27,7 @@ let private checkArgumentsPassedByRef com ctx (args: FSharpExpr list) = |> addWarning com ctx.InlinePath (makeRangeFrom arg) | _ -> () -let private transformBaseConsCall com ctx r baseEnt (baseCons: FSharpMemberOrFunctionOrValue) genArgs baseArgs = +let private transformBaseConsCall com (ctx : Context) r baseEnt (baseCons: FSharpMemberOrFunctionOrValue) genArgs baseArgs = let thisArg = ctx.BoundConstructorThis |> Option.map Fable.IdentExpr let baseArgs = transformExprList com ctx baseArgs |> run let genArgs = genArgs |> Seq.map (makeType com ctx.GenericArgs) @@ -55,7 +55,7 @@ let private transformBaseConsCall com ctx r baseEnt (baseCons: FSharpMemberOrFun let baseCons = makeCallFrom com ctx r Fable.Unit true genArgs thisArg baseArgs baseCons entityRefMaybeGlobalOrImported com baseEnt, baseCons -let private transformNewUnion com ctx r fsType +let private transformNewUnion com ctx r (fsType : FSharpType) (unionCase: FSharpUnionCase) (argExprs: Fable.Expr list) = match fsType with | ErasedUnion(_, genArgs) -> @@ -289,6 +289,258 @@ let rec private transformDecisionTargets (com: IFableCompiler) (ctx: Context) ac return! transformDecisionTargets com ctx ((idents, expr)::acc) tail } +let private skipAttribute (name : string) = + // TODO: skip all attributes where definiton not known??? + // name.StartsWith "Microsoft.FSharp.Core" || + // name.StartsWith "System.Reflection" || + // name.StartsWith "System.Runtime.CompilerServices" || + // name.StartsWith "System.ObsoleteAttribute" || + // name.StartsWith "System.Diagnostics" + false + +let private transformAttribute (com: IFableCompiler) (ctx : Context) (a : FSharpAttribute) = + match a.AttributeType.TryFullName with + | Some fullname when not (skipAttribute fullname) -> + + let types, args = a.ConstructorArguments |> Seq.toArray |> Array.unzip + let ctor = + a.AttributeType.MembersFunctionsAndValues |> Seq.tryPick (fun m -> + if m.IsConstructor then + let pars = m.CurriedParameterGroups |> Seq.concat |> Seq.map (fun p -> p.Type)|> Seq.toArray + if args.Length = pars.Length then + if FSharp.Collections.Array.forall2 (fun ta tp -> tp = ta) types pars then Some m + else None + else + None + else + None + ) + match ctor with + | Some ctor -> + let args = + a.ConstructorArguments |> Seq.toList |> List.map (fun (_,v) -> + match v with + | :? string as str -> Fable.Value(Fable.StringConstant str, None) + | :? int8 as v -> Fable.Value(Fable.NumberConstant(float v, NumberKind.Int8), None) + | :? uint8 as v -> Fable.Value(Fable.NumberConstant(float v, NumberKind.UInt8), None) + | :? int16 as v -> Fable.Value(Fable.NumberConstant(float v, NumberKind.Int16), None) + | :? uint16 as v -> Fable.Value(Fable.NumberConstant(float v, NumberKind.UInt16), None) + | :? int32 as v -> Fable.Value(Fable.NumberConstant(float v, NumberKind.Int32), None) + | :? uint32 as v -> Fable.Value(Fable.NumberConstant(float v, NumberKind.UInt32), None) + | :? float32 as v -> Fable.Value(Fable.NumberConstant(float v, NumberKind.Float32), None) + | :? float as v -> Fable.Value(Fable.NumberConstant(v, NumberKind.Float64), None) + | _ -> Fable.Value(Fable.StringConstant (string v), None) + ) + + + let typ = makeTypeFromDef com ctx.GenericArgs (System.Collections.Generic.List() :> IList<_>) a.AttributeType + try + let x = makeCallFrom com ctx None typ false [] None args ctor + match x with + | AST.Fable.Value(AST.Fable.Null AST.Fable.Any, None) -> + com.RemoveLastError() + None + | _ -> + Some (fullname,x) + with _ -> + None + | _ -> + None + | _ -> + None + +let private makeLambda (argType : Fable.Type) (body : Fable.Expr -> Fable.Expr) = + let target = { Fable.Ident.Name = "target"; Fable.Ident.Type = argType; Fable.Ident.Kind = Fable.IdentKind.CompilerGenerated; Fable.Ident.IsMutable = false; Fable.Ident.Range = None } + let body = body (Fable.IdentExpr target) + Fable.Function(Fable.FunctionKind.Lambda(target), body, None) + +let private makeLambda2 (a0 : Fable.Type) (a1 : Fable.Type) (body : Fable.Expr -> Fable.Expr -> Fable.Expr) = + let v0 = { Fable.Ident.Name = "arg0"; Fable.Ident.Type = a0; Fable.Ident.Kind = Fable.IdentKind.CompilerGenerated; Fable.Ident.IsMutable = false; Fable.Ident.Range = None } + let v1 = { Fable.Ident.Name = "arg1"; Fable.Ident.Type = a1; Fable.Ident.Kind = Fable.IdentKind.CompilerGenerated; Fable.Ident.IsMutable = false; Fable.Ident.Range = None } + let body = body (Fable.IdentExpr v0) (Fable.IdentExpr v1) + Fable.Function(Fable.FunctionKind.Delegate [v0; v1], body, None) + +let private makeLambda3 (a0 : Fable.Type) (a1 : Fable.Type) (a2 : Fable.Type) (body : Fable.Expr -> Fable.Expr -> Fable.Expr -> Fable.Expr) = + let v0 = { Fable.Ident.Name = "arg0"; Fable.Ident.Type = a0; Fable.Ident.Kind = Fable.IdentKind.CompilerGenerated; Fable.Ident.IsMutable = false; Fable.Ident.Range = None } + let v1 = { Fable.Ident.Name = "arg1"; Fable.Ident.Type = a1; Fable.Ident.Kind = Fable.IdentKind.CompilerGenerated; Fable.Ident.IsMutable = false; Fable.Ident.Range = None } + let v2 = { Fable.Ident.Name = "arg2"; Fable.Ident.Type = a2; Fable.Ident.Kind = Fable.IdentKind.CompilerGenerated; Fable.Ident.IsMutable = false; Fable.Ident.Range = None } + let body = body (Fable.IdentExpr v0) (Fable.IdentExpr v1) (Fable.IdentExpr v2) + Fable.Function(Fable.FunctionKind.Delegate [v0; v1; v2], body, None) + +let private makeLambda0 (body : Fable.Expr -> Fable.Expr) = + let target = { Fable.Ident.Name = "target"; Fable.Ident.Type = Fable.Type.Any; Fable.Ident.Kind = Fable.IdentKind.CompilerGenerated; Fable.Ident.IsMutable = false; Fable.Ident.Range = None } + let body = body (Fable.IdentExpr target) + Fable.Function(Fable.FunctionKind.Lambda(target), body, None) + + +let rec private (|Snoc|Nil|) (l : list<'a>) = + match l with + | [] -> Nil + | v :: Nil -> Snoc ([], v) + | a :: Snoc(h, t) -> Snoc(a :: h, t) + + +let private transformMemberInfo (com: IFableCompiler) ctx (m : FSharpMemberOrFunctionOrValue) = + if com.Options.quotations then + if m.IsEvent || m.IsEventAddMethod || m.IsEventRemoveMethod then + // TODO: support these? + None + elif m.IsValue then + + let get = + makeLambda2 Fable.Type.Any (Fable.Array Fable.Any) (fun t _ -> + if m.IsInstanceMember then + let ft = makeType com ctx.GenericArgs m.FullType + Fable.Get(t, Fable.FieldGet(m.CompiledName, m.IsMutable, ft), ft, None) + else + Util.makeValueFrom com ctx None m + ) |> Some + + let set = + if m.IsMutable then + makeLambda3 Fable.Type.Any (Fable.Array Fable.Any) Fable.Type.Any (fun t _ v -> + if m.IsInstanceMember then + let ft = makeType com ctx.GenericArgs m.FullType + Fable.Set(t, Fable.FieldSet(m.CompiledName, ft), v, None) + else + let ref = Util.memberRef com ctx None m + Fable.Set(ref, Fable.SetKind.VarSet, v, None) + ) |> Some + else + None + + + Some { + Fable.MemberInfo.Kind = Fable.Property(m.CompiledName, makeType com ctx.GenericArgs m.FullType, true, not m.IsInstanceMember, get, set) + Fable.Attributes = m.Attributes |> Seq.toArray |> Array.choose (transformAttribute com ctx) + } + elif m.IsProperty then + let ft = makeType com ctx.GenericArgs m.ReturnParameter.Type + + let get = + if m.HasGetterMethod && m.GetterMethod.GenericParameters.Count = 0 then + let decl = makeTypeFromDef com ctx.GenericArgs (System.Collections.Generic.List []) m.DeclaringEntity.Value + match m.GetterMethod.CurriedParameterGroups |> Seq.concat |> Seq.toList with + | [] -> + makeLambda decl (fun t -> + let callee = if m.IsInstanceMember then Some t else None + makeCallFrom com ctx None ft false [] callee [] m.GetterMethod + ) |> Some + | args -> + makeLambda2 decl (Fable.Type.Array Fable.Any) (fun t idx -> + let callee = if m.IsInstanceMember then Some t else None + let args = + args |> List.mapi (fun i a -> + let t = makeType com ctx.GenericArgs a.Type + let index = Fable.Value(Fable.ValueKind.NumberConstant(float i, NumberKind.Int32), None) + Fable.Get(idx, Fable.ExprGet index, t, None) + ) + makeCallFrom com ctx None ft false [] callee args m.GetterMethod + ) |> Some + else + None + let set = + if m.HasSetterMethod && m.SetterMethod.GenericParameters.Count = 0 then + let decl = makeTypeFromDef com ctx.GenericArgs (System.Collections.Generic.List []) m.DeclaringEntity.Value + + match m.SetterMethod.CurriedParameterGroups |> Seq.concat |> Seq.toList with + | Nil -> + None + | Snoc(idx, _val) -> + makeLambda3 decl (Fable.Array Fable.Any) Fable.Any (fun t ia value -> + let callee = if m.IsInstanceMember then Some t else None + let idx = + idx |> List.mapi (fun i a -> + let t = makeType com ctx.GenericArgs a.Type + let index = Fable.Value(Fable.ValueKind.NumberConstant(float i, NumberKind.Int32), None) + Fable.Get(ia, Fable.ExprGet index, t, None) + ) + makeCallFrom com ctx None ft false [] callee (idx @ [value]) m.SetterMethod + ) |> Some + + else + None + Some { + Fable.MemberInfo.Kind = Fable.Property(m.DisplayName, ft, false, not m.IsInstanceMember, get, set) + Fable.Attributes = m.Attributes |> Seq.toArray |> Array.choose (transformAttribute com ctx) + } + elif m.IsConstructor then + let pars = + m.CurriedParameterGroups |> Seq.concat |> Seq.toArray |> Array.map (fun p -> + { Fable.ParameterInfo.Name = p.DisplayName; Fable.Type = makeType com ctx.GenericArgs p.Type } + ) + + let invoke = + makeLambda (Fable.Array Fable.Any) (fun ip -> + let decl = makeTypeFromDef com ctx.GenericArgs (System.Collections.Generic.List []) m.DeclaringEntity.Value + let pars = m.CurriedParameterGroups |> Seq.concat |> Seq.toList + let args = pars |> List.mapi (fun i p -> + let t = makeType com ctx.GenericArgs p.Type + let index = Fable.Value(Fable.ValueKind.NumberConstant(float i, NumberKind.Int32), None) + Fable.Get(ip, Fable.ExprGet index, t, None) + ) + + let info = + { Fable.ThisArg = None + Fable.Args = args + Fable.SignatureArgTypes = Fable.SignatureKind.NoUncurrying + Fable.Spread = Fable.SpreadKind.NoSpread + Fable.IsBaseCall = false + Fable.IsSelfConstructorCall = false + } + + staticCall None decl info (makeValueFrom com ctx None m) + ) + + + //let mangledName = Helpers.getMemberDeclarationName com m + + Some { + Fable.MemberInfo.Kind = Fable.Constructor(pars, invoke) + Fable.Attributes = m.Attributes |> Seq.toArray |> Array.choose (transformAttribute com ctx) + } + + else + let pars = + m.CurriedParameterGroups |> Seq.concat |> Seq.toArray |> Array.choose (fun p -> + let t = makeType com ctx.GenericArgs p.Type + if t <> Fable.Type.Unit then + Some { Fable.ParameterInfo.Name = p.DisplayName; Fable.Type = t } + else + None + ) + + + let invoke = + if Helpers.isInline m then + None + else + makeLambda2 (Fable.Any) (Fable.Array Fable.Any) (fun target ip -> + let decl = makeTypeFromDef com ctx.GenericArgs (System.Collections.Generic.List []) m.DeclaringEntity.Value + let pars = m.CurriedParameterGroups |> Seq.concat |> Seq.toList + let args = pars |> List.mapi (fun i p -> + let t = makeType com ctx.GenericArgs p.Type + let index = Fable.Value(Fable.ValueKind.NumberConstant(float i, NumberKind.Int32), None) + Fable.Get(ip, Fable.ExprGet index, t, None) + ) + if m.IsInstanceMember then + makeCallFrom com ctx None decl false [] (Some target) args m + else + makeCallFrom com ctx None decl false [] (None) args m + ) |> Some + + + let ret = makeType com ctx.GenericArgs m.ReturnParameter.Type + let parNames = m.GenericParameters |> Seq.toArray |> Array.map (fun p -> p.Name) + Some { + Fable.MemberInfo.Kind = Fable.Method(parNames, m.CompiledName, pars, ret, not m.IsInstanceMember, invoke) + Fable.Attributes = m.Attributes |> Seq.toArray |> Array.choose (transformAttribute com ctx) + } + else + None + + + let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr = trampoline { match fsExpr with @@ -777,9 +1029,91 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr = return sprintf "Cannot compile ILFieldGet(%A, %s)" ownerTyp fieldName |> addErrorAndReturnNull com ctx.InlinePath (makeRangeFrom fsExpr) - | BasicPatterns.Quote _ -> - return "Quotes are not currently supported by Fable" - |> addErrorAndReturnNull com ctx.InlinePath (makeRangeFrom fsExpr) + + | BasicPatterns.Quote expr -> + if com.Options.quotations then + + //let! dummy = transformExpr com ctx expr + + let data = QuotationPickler.serialize com ctx expr + //data |> sprintf "%A" |> addWarning com ctx.InlinePath (makeRangeFrom fsExpr) + + let! values = + data.values |> Array.toList |> trampolineListMap (fun v -> + trampoline { + let! value = + trampoline { + if isInline v then + match ctx.ScopeInlineValues |> List.tryFind (fun (vi,_) -> obj.Equals(vi, v)) with + | Some (_,fsExpr) -> + + return! transformExpr com ctx fsExpr + | None -> + return "Cannot resolve locally inlined value: " + v.DisplayName + |> addErrorAndReturnNull com ctx.InlinePath None + else + return makeValueFrom com ctx None v + } + + + return { + Fable.ValueData.name = v.DisplayName + Fable.ValueData.typ = makeType com ctx.GenericArgs v.FullType + Fable.ValueData.expr = value + } + } + ) + + let fableData = + { + Fable.ExprData.typ = makeType com ctx.GenericArgs data.typ + Fable.variables = + data.variables |> Array.map (fun v -> + { + Fable.VarData.name = v.name; + Fable.VarData.typ = makeType com ctx.GenericArgs v.typ + Fable.VarData.isMutable = v.isMutable + } + ) + Fable.values = List.toArray values + + Fable.ExprData.types = + data.types |> Array.map (fun d -> + match d with + | Choice1Of2 t -> makeType com ctx.GenericArgs t + | Choice2Of2(d,targs) -> makeTypeFromDef com ctx.GenericArgs (System.Collections.Generic.List targs) d + ) + + Fable.ExprData.members = + data.members |> Array.map (fun m -> + match m with + | QuotationPickler.MemberDescription.Member (m, targs, margs) -> + let d = m.DeclaringEntity.Value + let t = makeTypeFromDef com ctx.GenericArgs (System.Collections.Generic.List(targs)) d + let mem = transformMemberInfo com ctx m |> Option.get + let margs = margs |> List.toArray |> Array.map (makeType com ctx.GenericArgs) + d, t, mem, margs + | QuotationPickler.MemberDescription.UnionCase (c, _targs) -> + let d = c.ReturnType.TypeDefinition + let t = makeType com ctx.GenericArgs c.ReturnType + let mem = transformUnionCaseAsMember com ctx c + d, t, mem, [||] + ) + + Fable.literals = + data.literals |> Array.map (fun (v,t) -> + let ft = makeType com ctx.GenericArgs t + Replacements.makeTypeConst (makeRangeFrom fsExpr) ft v + ) + + Fable.data = data.data + } + + + return Fable.Quote(false, fableData, makeRangeFrom fsExpr) + else + return "Quotes can be enabled by adding a define FABLE_QUOTATIONS to your fable-config " + |> addErrorAndReturnNull com ctx.InlinePath (makeRangeFrom fsExpr) // TODO: Ask. I see this when accessing Result types (all structs?) | BasicPatterns.AddressOf(expr) -> @@ -832,6 +1166,77 @@ let private checkAttachedMemberConflicts com isRecordLike (ent: FSharpEntity) = else attachedMembers) |> ignore +let private transformUnionCaseAsMember (com: IFableCompiler) ctx (c : FSharpUnionCase) = + let mangledName = Helpers.unionCaseCompiledName c |> Option.defaultValue c.Name + + if c.ReturnType.HasTypeDefinition then + let ent = c.ReturnType.TypeDefinition + let tag = ent.UnionCases |> Seq.findIndex (fun ci -> ci.Name = c.Name) + let mangledTypeName = getEntityDeclarationName com ent + let fields = c.UnionCaseFields |> Seq.toArray |> Array.map (fun f -> f.Name, makeType com ctx.GenericArgs f.FieldType) + { + Fable.MemberInfo.Kind = Fable.UnionCaseConstructor(tag, c.Name, fields, mangledName, mangledTypeName) + Fable.Attributes = c.Attributes |> Seq.toArray |> Array.choose (transformAttribute com ctx) + } + else + //let mangledTypeName = getEntityDeclarationName com ent + let fields = c.UnionCaseFields |> Seq.toArray |> Array.map (fun f -> f.Name, makeType com ctx.GenericArgs f.FieldType) + { + Fable.MemberInfo.Kind = Fable.UnionCaseConstructor(0, c.Name, fields, mangledName, mangledName) + Fable.Attributes = c.Attributes |> Seq.toArray |> Array.choose (transformAttribute com ctx) + } + +let private transformMemberReflectionInfos (com: FableCompiler) ctx (ent : FSharpEntity) = + let realMembers = + ent.TryGetMembersFunctionsAndValues |> Seq.choose (transformMemberInfo com ctx) + + let special = + if ent.IsFSharpRecord then + let fields = ent.FSharpFields |> Seq.toList + let parameters = fields |> List.map (fun f -> { Fable.ParameterInfo.Name = f.Name; Fable.Type = makeType com ctx.GenericArgs f.FieldType}) + // let ctor = "new " + getEntityDeclarationName com ent + let invoke = + makeLambda (Fable.Array Fable.Any) (fun ip -> + let args = + fields |> List.mapi (fun i a -> + let t = makeType com ctx.GenericArgs a.FieldType + let index = Fable.Value(Fable.ValueKind.NumberConstant(float i, NumberKind.Int32), None) + Fable.Get(ip, Fable.ExprGet index, t, None) + ) + Fable.Value(Fable.NewRecord(args, Fable.DeclaredRecord ent, []), None) + ) + Seq.concat [ + fields |> List.map (fun m -> + let ft = makeType com ctx.GenericArgs m.FieldType + { + Fable.MemberInfo.Kind = Fable.Property(m.Name, ft, true, false, None, None) + Fable.Attributes = m.PropertyAttributes |> Seq.toArray |> Array.choose (transformAttribute com ctx) + } + ) + + + List.singleton { + Fable.MemberInfo.Kind = Fable.Constructor(List.toArray parameters, invoke) + Fable.Attributes = [||] + } + + ] + elif ent.IsFSharpUnion then + //sprintf "%s: %A" ent.FullName ent.UnionCases.Count |> addWarning com [] None + ent.UnionCases |> Seq.mapi (fun i c -> + let mangledName = Helpers.unionCaseCompiledName c |> Option.defaultValue c.Name + let mangledTypeName = getEntityDeclarationName com ent + let fields = c.UnionCaseFields |> Seq.toArray |> Array.map (fun f -> f.Name, makeType com ctx.GenericArgs f.FieldType) + { + Fable.MemberInfo.Kind = Fable.UnionCaseConstructor(i, c.Name, fields, mangledName, mangledTypeName) + Fable.Attributes = c.Attributes |> Seq.toArray |> Array.choose (transformAttribute com ctx) + } + ) + else + Seq.empty + + Seq.append realMembers special |> Seq.toArray + let private transformImplicitConstructor com (ctx: Context) (memb: FSharpMemberOrFunctionOrValue) args (body: FSharpExpr) = match memb.DeclaringEntity with @@ -867,6 +1272,7 @@ let private transformImplicitConstructor com (ctx: Context) let info: Fable.ClassImplicitConstructorInfo = { Name = name Entity = ent + Members = transformMemberReflectionInfos com ctx ent EntityName = entityName IsEntityPublic = isPublicEntity ent IsConstructorPublic = isPublicMember memb @@ -877,8 +1283,9 @@ let private transformImplicitConstructor com (ctx: Context) Body = body } let r = getEntityLocation ent |> makeRange + let decl = ctx.EnclosingEntity |> Option.bind (Helpers.getModuleReflectionName com) checkAttachedMemberConflicts com false ent - [Fable.ConstructorDeclaration(Fable.ClassImplicitConstructor info, Some r)] + [Fable.ConstructorDeclaration(decl, Fable.ClassImplicitConstructor info, Some r)] /// When using `importMember`, uses the member display name as selector let private importExprSelector (memb: FSharpMemberOrFunctionOrValue) selector = @@ -1056,26 +1463,46 @@ let private transformDeclarations (com: FableCompiler) ctx rootDecls = let entityName = getEntityDeclarationName com ent com.AddUsedVarName(entityName) // TODO: Check Equality/Comparison attributes + let props = transformMemberReflectionInfos com ctx ent + let info: Fable.UnionConstructorInfo = { Entity = ent + Members = props EntityName = entityName IsPublic = isPublicEntity ent } let r = getEntityLocation ent |> makeRange + let decl = ctx.EnclosingEntity |> Option.bind (Helpers.getModuleReflectionName com) checkAttachedMemberConflicts com false ent - [Fable.ConstructorDeclaration(Fable.UnionConstructor info, Some r)] + [Fable.ConstructorDeclaration(decl, Fable.UnionConstructor info, Some r)] | _ when isRecordLike ent -> let entityName = getEntityDeclarationName com ent com.AddUsedVarName(entityName) // TODO: Check Equality/Comparison attributes + let props = transformMemberReflectionInfos com ctx ent let info: Fable.CompilerGeneratedConstructorInfo = { Entity = ent EntityName = entityName - IsPublic = isPublicEntity ent } + IsPublic = isPublicEntity ent + Members = props } let r = getEntityLocation ent |> makeRange + + let decl = ctx.EnclosingEntity |> Option.bind (Helpers.getModuleReflectionName com) checkAttachedMemberConflicts com true ent - [Fable.ConstructorDeclaration(Fable.CompilerGeneratedConstructor info, Some r)] + [Fable.ConstructorDeclaration(decl, Fable.CompilerGeneratedConstructor info, Some r)] + | _ when ent.IsFSharpModule -> + let declaring = ctx.EnclosingEntity |> Option.bind (Helpers.getModuleReflectionName com) + let name = Helpers.getModuleReflectionName com ent |> Option.get + let decl = + try Fable.ModuleDeclaration (declaring, name, ent, transformMemberReflectionInfos com ctx ent) |> Some + with e -> e |> sprintf "%A" |> addWarning com [] None; None + match decl with + | Some decl -> + decl :: transformDeclarationsInner com { ctx with EnclosingEntity = Some ent } sub + | None -> + transformDeclarationsInner com { ctx with EnclosingEntity = Some ent } sub | _ -> transformDeclarationsInner com { ctx with EnclosingEntity = Some ent } sub + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(meth, args, body) -> transformMemberDecl com ctx meth args body | FSharpImplementationFileDeclaration.InitAction fe -> @@ -1187,6 +1614,9 @@ type FableCompiler(com: ICompiler, implFiles: IDictionary + let ctx = Context.Create(None) + transformDeclarations fcom ctx [FSharpImplementationFileDeclaration.Entity(ent, rootDecls)] + | _ -> + let ctx = Context.Create(rootEnt) + transformDeclarations fcom ctx rootDecls Fable.File(com.CurrentFile, rootDecls, set fcom.UsedVarNames, set fcom.InlineDependencies) with | ex -> exn (sprintf "%s (%s)" ex.Message com.CurrentFile, ex) |> raise diff --git a/src/Fable.Transforms/Fable.Transforms.fsproj b/src/Fable.Transforms/Fable.Transforms.fsproj index 3127d20e70..5a2bf61b82 100644 --- a/src/Fable.Transforms/Fable.Transforms.fsproj +++ b/src/Fable.Transforms/Fable.Transforms.fsproj @@ -18,6 +18,7 @@ + @@ -29,7 +30,4 @@ - - + \ No newline at end of file diff --git a/src/Fable.Transforms/Fable2Babel.fs b/src/Fable.Transforms/Fable2Babel.fs index 4134e63a1f..cfbd7e1651 100644 --- a/src/Fable.Transforms/Fable2Babel.fs +++ b/src/Fable.Transforms/Fable2Babel.fs @@ -79,7 +79,7 @@ module Util = let rec isJsStatement ctx preferStatement (expr: Fable.Expr) = match expr with | Fable.Value _ | Fable.Import _ | Fable.DelayedResolution _ | Fable.Test _ | Fable.IdentExpr _ | Fable.Function _ - | Fable.ObjectExpr _ | Fable.Operation _ | Fable.Get _ | Fable.TypeCast _ -> false + | Fable.ObjectExpr _ | Fable.Operation _ | Fable.Get _ | Fable.TypeCast _ | Fable.Quote _ -> false | Fable.TryCatch _ | Fable.Debugger _ | Fable.Sequential _ | Fable.Let _ | Fable.Set _ @@ -306,6 +306,7 @@ module Util = let rec typeAnnotation com ctx typ: TypeAnnotationInfo = match typ with + | Fable.Expr _gen -> upcast AnyTypeAnnotation() | Fable.MetaType -> upcast AnyTypeAnnotation() | Fable.Any -> upcast AnyTypeAnnotation() | Fable.Unit -> upcast VoidTypeAnnotation() @@ -608,58 +609,173 @@ module Util = | Fable.AsPojo(expr, caseRule) -> com.TransformAsExpr(ctx, Replacements.makePojo com r caseRule expr) | Fable.Curry(expr, arity) -> com.TransformAsExpr(ctx, Replacements.curryExprAtRuntime arity expr) - let rec transformRecordReflectionInfo com ctx r (ent: FSharpEntity) generics = + let rec transformMemberReflectionInfosNew (com : IBabelCompiler) ctx r (self : Expression) (generics : Expression) (ent: FSharpEntity) (mems : Fable.MemberInfo[]) = + let genMap = ent.GenericParameters |> Seq.mapi (fun i x -> x.Name, i) |> Map.ofSeq + + let genMap (name : string) : Option = + match Map.tryFind name genMap with + | Some i -> + MemberExpression(generics, NumericLiteral(float i), true) :> Expression |> Some + | None -> + None + + let newUnionCase (self : Expression) (tag : int) (name : string) (attributes : ArrayExpression) (fields : array) (invoke : ArrowFunctionExpression) = + let info = coreValue com ctx "Reflection" "NUnionCaseInfo" + let fields = fields |> Array.map (fun (n,t) -> ArrayExpression [| StringLiteral n; transformTypeInfo com ctx r [||] genMap t |] :> Expression) + NewExpression(info, [|self; NumericLiteral(float tag); StringLiteral(name); attributes; ArrayExpression fields; invoke|]) :> Expression + + let newParameter (p : Fable.ParameterInfo) = + let par = coreValue com ctx "Reflection" "NParameterInfo" + NewExpression(par, [| StringLiteral p.Name; transformTypeInfo com ctx r [||] genMap p.Type |]) :> Expression + + let newConstructor (self : Expression) (attributes : ArrayExpression) (parameters : array) (invoke : Expression) = + let ctor = coreValue com ctx "Reflection" "NConstructorInfo" + let parameters = parameters |> Array.map newParameter + NewExpression(ctor, [|self; ArrayExpression parameters; invoke; attributes |]) :> Expression + + let newMethod (self : Expression) (genericParameters : string[]) (isStatic : bool) (ret : Fable.Type) (name : string) (attributes : ArrayExpression) (parameters : array) (invoke : Expression) = + let meth = coreValue com ctx "Reflection" "NMethodInfo" + let parameters = parameters |> Array.map newParameter + let ret = transformTypeInfo com ctx r [||] genMap ret + + let genPars = genericParameters |> Array.map (fun n -> coreLibCall com ctx None "Reflection" "getGenericParameter" [| StringLiteral n |]) |> ArrayExpression :> Expression + + NewExpression(meth, [|self; genPars; StringLiteral name; ArrayExpression parameters; ret; BooleanLiteral isStatic; invoke; attributes |]) :> Expression + + let newProperty (self : Expression) (isStatic : bool) (isFSharp : bool) (ret : Fable.Type) (name : string) (attributes : ArrayExpression) (get : Option) (set : Option) = + let prop = coreValue com ctx "Reflection" "NPropertyInfo" + let ret = transformTypeInfo com ctx r [||] genMap ret + + let args = [|self; StringLiteral name :> Expression; ret; BooleanLiteral isStatic :> Expression; BooleanLiteral isFSharp :> Expression; attributes :> Expression|] + + let args = + match get, set with + | Some get, Some set -> Array.append args [| get; set |] + | Some get, None -> Array.append args [| get |] + | None, Some set -> Array.append args [| NullLiteral() :> Expression; set |] + | None, None -> args + + NewExpression(prop, args) :> Expression + + let newField (self : Expression) (isStatic : bool) (ret : Fable.Type) (name : string) (attributes : ArrayExpression) (get : Option) = + let fld = coreValue com ctx "Reflection" "NFieldInfo" + let ret = transformTypeInfo com ctx r [||] genMap ret + match get with + | Some get -> + NewExpression(fld, [|self; StringLiteral name; ret; BooleanLiteral isStatic; attributes; get|]) :> Expression + | None -> + NewExpression(fld, [|self; StringLiteral name; ret; BooleanLiteral isStatic; attributes|]) :> Expression + + mems |> Array.map (fun x -> + let attributes = ArrayExpression (x.Attributes |> Array.map (fun (fullname, e) -> + let value = com.TransformAsExpr(ctx, e) + let typ = StringLiteral(fullname) //com.TransformAsExpr(ctx, Fable.Value(Fable.TypeInfo e.Type, None)) + + ObjectExpression [| + U3.Case1 (ObjectProperty(StringLiteral "AttributeType", typ)) + U3.Case1 (ObjectProperty(StringLiteral "AttributeValue", value)) + |] :> Expression + )) + + match x.Kind with + | Fable.MemberInfoKind.UnionCaseConstructor(tag, name, pars, mangledName, mangledTypeName) -> + let invoke = + let args = pars |> Array.mapi (fun i _ -> Identifier(sprintf "a%d" i)) + let allArgs = + Array.append + [| NumericLiteral(float tag) :> Expression; StringLiteral(mangledName) :> Expression |] + (Array.map (fun a -> a :> Expression) args) + + let body = NewExpression(Identifier(mangledTypeName), allArgs) :> Expression + ArrowFunctionExpression(Array.map toPattern args, U2.Case2 body) + newUnionCase self tag name attributes pars invoke + + | Fable.MemberInfoKind.Constructor(pars, invoke) -> + let invoke = com.TransformAsExpr(ctx, invoke) + newConstructor self attributes pars invoke + + | Fable.MemberInfoKind.Method(genericParameters, name, pars, ret, isStatic, invoke) -> + let invoke = + match invoke with + | Some invoke -> com.TransformAsExpr(ctx, invoke) + | _ -> + ArrowFunctionExpression([||], U2.Case1 (BlockStatement [| + ThrowStatement(NewExpression(Identifier "Error", [| StringLiteral "cannot invoke method" :> Expression |])) :> Statement + |])) :> Expression + + newMethod self genericParameters isStatic ret name attributes pars invoke + + | Fable.MemberInfoKind.Property(name, typ, fsharp, isStatic, get, set) -> + let get = get |> Option.map (fun g -> com.TransformAsExpr(ctx, g)) + let set = set |> Option.map (fun g -> com.TransformAsExpr(ctx, g)) + newProperty self isStatic fsharp typ name attributes get set + + | Fable.MemberInfoKind.Field(name, typ, isStatic, get) -> + let get = get |> Option.map (fun g -> com.TransformAsExpr(ctx, g)) + newField self isStatic typ name attributes get + ) + + and transformRecordReflectionInfo (com : IBabelCompiler) ctx r (ent: FSharpEntity) declaringName (mems : Fable.MemberInfo[]) generics = // TODO: Refactor these three bindings to reuse in transformUnionReflectionInfo let fullname = defaultArg ent.TryFullName Naming.unknown let fullnameExpr = StringLiteral fullname :> Expression - let genMap = - let genParamNames = ent.GenericParameters |> Seq.map (fun x -> x.Name) |> Seq.toArray - Array.zip genParamNames generics |> Map - let fields = - ent.FSharpFields |> Seq.map (fun fi -> - let typeInfo = - FSharp2Fable.TypeHelpers.makeType com Map.empty fi.FieldType - |> transformTypeInfo com ctx r genMap - (ArrayExpression [|StringLiteral fi.Name; typeInfo|] :> Expression)) - |> Seq.toArray - let fields = ArrowFunctionExpression([||], ArrayExpression fields :> Expression |> U2.Case2) :> Expression - [|fullnameExpr; upcast ArrayExpression generics; jsConstructor com ctx ent; fields|] - |> coreReflectionCall com ctx None "record" - - and transformUnionReflectionInfo com ctx r (ent: FSharpEntity) generics = - let fullname = defaultArg ent.TryFullName Naming.unknown - let fullnameExpr = StringLiteral fullname :> Expression - let genMap = - let genParamNames = ent.GenericParameters |> Seq.map (fun x -> x.Name) |> Seq.toArray - Array.zip genParamNames generics |> Map - let cases = - ent.UnionCases |> Seq.map (fun uci -> - let fieldInfos = - uci.UnionCaseFields - |> Seq.map (fun fi -> - let fieldType = - FSharp2Fable.TypeHelpers.makeType com Map.empty fi.FieldType - |> transformTypeInfo com ctx r genMap - ArrayExpression [| - fi.Name |> StringLiteral :> Expression - fieldType - |] :> Expression - ) - |> Seq.toArray - let caseInfo = - if fieldInfos.Length = 0 then - getUnionCaseName uci |> StringLiteral :> Expression - else - ArrayExpression [| - getUnionCaseName uci |> StringLiteral :> Expression - ArrayExpression fieldInfos :> Expression - |] :> Expression - caseInfo) |> Seq.toArray - let cases = ArrowFunctionExpression([||], ArrayExpression cases :> Expression |> U2.Case2) :> Expression - [|fullnameExpr; upcast ArrayExpression generics; jsConstructor com ctx ent; cases|] - |> coreReflectionCall com ctx None "union" - - and transformTypeInfo (com: IBabelCompiler) ctx r (genMap: Map) t: Expression = + let genParamNames = ent.GenericParameters |> Seq.map (fun x -> StringLiteral x.Name :> Expression) |> Seq.toArray |> ArrayExpression :> Expression + //let genMap = Array.zip genParamNames generics |> Map + + let self = Identifier "self" + let gen = Identifier "gen" + let nMembers = transformMemberReflectionInfosNew com ctx r self gen ent mems + let fields = FunctionExpression([|toPattern self; toPattern gen|], BlockStatement [| ReturnStatement(ArrayExpression nMembers) :> Statement |]) :> Expression + let decl = + match declaringName with + | Some decl -> + let reflName = decl + "$" + Naming.reflectionSuffix + CallExpression(Identifier reflName, [||]) :> Expression + | None -> + NullLiteral() :> Expression + + [|fullnameExpr; genParamNames; upcast ArrayExpression generics; fields; decl|] + |> coreLibCall com ctx None "Reflection" "ntype" + // let members = transformMemberReflectionInfos com ctx r ent mems generics + // //let fields = ArrowFunctionExpression([||], ArrayExpression members :> Expression |> U2.Case2) :> Expression + // let fields = FunctionExpression([||], BlockStatement [| ReturnStatement(ArrayExpression members) :> Statement |]) :> Expression + // [|fullnameExpr; genParamNames; upcast ArrayExpression generics; fields|] + // |> coreLibCall com ctx None "Reflection" "type" + + // and transformUnionReflectionInfo com ctx r (ent: FSharpEntity) (mems : Fable.MemberInfo[]) generics = + // let fullname = defaultArg ent.TryFullName Naming.unknown + // let fullnameExpr = StringLiteral fullname :> Expression + // let genMap = + // let genParamNames = ent.GenericParameters |> Seq.map (fun x -> x.Name) |> Seq.toArray + // Array.zip genParamNames generics |> Map + // let cases = + // ent.UnionCases |> Seq.map (fun uci -> + // let fieldInfos = + // uci.UnionCaseFields + // |> Seq.map (fun fi -> + // let fieldType = + // FSharp2Fable.TypeHelpers.makeType com Map.empty fi.FieldType + // |> transformTypeInfo com ctx r genMap + // ArrayExpression [| + // fi.Name |> StringLiteral :> Expression + // fieldType + // |] :> Expression + // ) + // |> Seq.toArray + // let caseInfo = + // if fieldInfos.Length = 0 then + // getUnionCaseName uci |> StringLiteral :> Expression + // else + // ArrayExpression [| + // getUnionCaseName uci |> StringLiteral :> Expression + // ArrayExpression fieldInfos :> Expression + // |] :> Expression + // caseInfo) |> Seq.toArray + // let cases = ArrowFunctionExpression([||], ArrayExpression cases :> Expression |> U2.Case2) :> Expression + // [|fullnameExpr; upcast ArrayExpression generics; jsConstructor com ctx ent; cases|] + // |> coreLibCall com ctx None "Reflection" "union" + + and transformTypeInfo (com: IBabelCompiler) ctx r (mems : Fable.MemberInfo[]) (genMap: string -> Option) t: Expression = let primitiveTypeInfo name = coreValue com ctx "Reflection" (name + "_type") let numberInfo kind = @@ -667,26 +783,25 @@ module Util = |> primitiveTypeInfo let nonGenericTypeInfo fullname = [| StringLiteral fullname :> Expression |] - |> coreReflectionCall com ctx None "class" + |> coreLibCall com ctx None "Reflection" "ntype" let resolveGenerics generics: Expression[] = - generics |> Array.map (transformTypeInfo com ctx r genMap) + generics |> Array.map (transformTypeInfo com ctx r [||] genMap) let genericTypeInfo name genArgs = - let resolved = resolveGenerics genArgs - coreReflectionCall com ctx None name resolved + let gen = genArgs |> Array.map (function Fable.GenericParam n -> coreLibCall com ctx None "Reflection" "getGenericParameter" [|StringLiteral n|] | t -> transformTypeInfo com ctx r [||] genMap t) + coreLibCall com ctx None "Reflection" name gen let genericEntity (ent: FSharpEntity) generics = let fullname = defaultArg ent.TryFullName Naming.unknown let fullnameExpr = StringLiteral fullname :> Expression - let args = if Array.isEmpty generics then [|fullnameExpr|] else [|fullnameExpr; ArrayExpression generics :> Expression|] - coreReflectionCall com ctx None "class" args + let genericNames = ent.GenericParameters |> Seq.map (fun p -> StringLiteral p.Name :> Expression) |> Seq.toArray |> ArrayExpression :> Expression + let args = if Array.isEmpty generics then [|fullnameExpr|] else [|fullnameExpr; genericNames; ArrayExpression generics :> Expression|] + coreLibCall com ctx None "Reflection" "ntype" args match t with | Fable.ErasedUnion _genArgs -> primitiveTypeInfo "obj" // TODO: Type info for ErasedUnion? | Fable.Any -> primitiveTypeInfo "obj" | Fable.GenericParam name -> - match Map.tryFind name genMap with + match genMap name with | Some t -> t - | None -> - Replacements.genericTypeInfoError name |> addError com [] r - NullLiteral () :> Expression + | None -> coreLibCall com ctx None "Reflection" "getGenericParameter" [|StringLiteral name|] | Fable.Unit -> primitiveTypeInfo "unit" | Fable.Boolean -> primitiveTypeInfo "bool" | Fable.Char -> primitiveTypeInfo "char" @@ -726,7 +841,9 @@ module Util = let genArgs = resolveGenerics (List.toArray genArgs) Array.zip fieldNames genArgs |> Array.map (fun (k, t) -> ArrayExpression [|StringLiteral k; t|] :> Expression) - |> coreReflectionCall com ctx None "anonRecord" + |> coreLibCall com ctx None "Reflection" "anonRecord" + | Fable.Expr None -> nonGenericTypeInfo "Expr" + | Fable.Expr (Some gen) -> genericTypeInfo "Expr" [|gen|] | Fable.DeclaredType(ent, generics) -> match ent, generics with | Replacements.BuiltinEntity kind -> @@ -742,58 +859,85 @@ module Util = | Replacements.BclBigInt -> genericEntity ent [||] | Replacements.BclHashSet gen | Replacements.FSharpSet gen -> - genericEntity ent [|transformTypeInfo com ctx r genMap gen|] + genericEntity ent [|transformTypeInfo com ctx r [||] genMap gen|] | Replacements.BclDictionary(key, value) | Replacements.BclKeyValuePair(key, value) | Replacements.FSharpMap(key, value) -> genericEntity ent [| - transformTypeInfo com ctx r genMap key - transformTypeInfo com ctx r genMap value + transformTypeInfo com ctx r [||] genMap key + transformTypeInfo com ctx r [||] genMap value |] | Replacements.FSharpResult(ok, err) -> - transformUnionReflectionInfo com ctx r ent [| - transformTypeInfo com ctx r genMap ok - transformTypeInfo com ctx r genMap err + let resultCases = + [| + { Fable.Kind = Fable.MemberInfoKind.UnionCaseConstructor(0, "Ok", [|"value", ok|], "Ok", "_Option.Result"); Fable.Attributes = [||] } + { Fable.Kind = Fable.MemberInfoKind.UnionCaseConstructor(1, "Error", [|"value", err|], "Error", "_Option.Result"); Fable.Attributes = [||] } + |] + transformRecordReflectionInfo com ctx r ent None resultCases [| + transformTypeInfo com ctx r [||] genMap ok + transformTypeInfo com ctx r [||] genMap err |] | Replacements.FSharpChoice gen -> - let gen = List.map (transformTypeInfo com ctx r genMap) gen - List.toArray gen |> transformUnionReflectionInfo com ctx r ent + let garr = List.toArray gen + let cases = + garr |> Array.mapi (fun i t -> + let name = sprintf "Choice%dOf%d" i garr.Length + { Fable.Kind = Fable.MemberInfoKind.UnionCaseConstructor(i, name, [|"value", t|], name, "_Option.Choice"); Fable.Attributes = [||] } + ) + + let gen = List.map (transformTypeInfo com ctx r [||] genMap) gen + List.toArray gen |> transformRecordReflectionInfo com ctx r ent None cases | Replacements.FSharpReference gen -> - transformRecordReflectionInfo com ctx r ent [|transformTypeInfo com ctx r genMap gen|] + transformRecordReflectionInfo com ctx r ent None mems [|transformTypeInfo com ctx r [||] genMap gen|] | _ -> - let generics = generics |> List.map (transformTypeInfo com ctx r genMap) |> List.toArray + let generics = generics |> List.map (transformTypeInfo com ctx r [||] genMap) |> List.toArray /// Check if the entity is actually declared in JS code if ent.IsInterface || FSharp2Fable.Util.isErasedEntity ent - // TODO!!! Get reflection info from types in precompiled libs || FSharp2Fable.Util.isReplacementCandidate ent then - genericEntity ent generics + + match t with + | Fable.DeclaredType(ent, args) -> + match ent.TryFullName with + | Some fullname -> + let args = args |> List.map (fun a -> Fable.Value(Fable.TypeInfo(a), None)) + let call = + com.Options.precompiledLib + |> Option.bind (fun tryLib -> tryLib fullname) + |> Option.map (Replacements.precompiledLibReflection r args) + + match call with + | Some call -> com.TransformAsExpr(ctx, call) + | None -> genericEntity ent generics + | _ -> + genericEntity ent generics + | _ -> + genericEntity ent generics else let reflectionMethodExpr = FSharp2Fable.Util.entityRefWithSuffix com ent Naming.reflectionSuffix let callee = com.TransformAsExpr(ctx, reflectionMethodExpr) CallExpression(callee, generics) :> Expression - let transformReflectionInfo com ctx r (ent: FSharpEntity) generics = - if ent.IsFSharpRecord then - transformRecordReflectionInfo com ctx r ent generics - elif ent.IsFSharpUnion then - transformUnionReflectionInfo com ctx r ent generics - else - let fullname = defaultArg ent.TryFullName Naming.unknown - [| - yield StringLiteral fullname :> Expression - match generics with - | [||] -> yield Undefined() :> Expression - | generics -> yield ArrayExpression generics :> _ - match tryJsConstructor com ctx ent with - | Some cons -> yield cons - | None -> () - |] - |> coreReflectionCall com ctx None "class" + let transformReflectionInfo com ctx r (ent: FSharpEntity) declaringName (mems : Fable.MemberInfo[]) generics = + transformRecordReflectionInfo com ctx r ent declaringName mems generics + // if ent.IsFSharpRecord then + // transformRecordReflectionInfo com ctx r ent mems generics + // elif ent.IsFSharpUnion then + // transformRecordReflectionInfo com ctx r ent mems generics + // else + // let fullname = defaultArg ent.TryFullName Naming.unknown + // let fullnameExpr = StringLiteral fullname :> Expression + + // let members = transformMemberReflectionInfos com ctx r ent mems generics + // let refl = ArrowFunctionExpression([||], ArrayExpression members :> Expression |> U2.Case2) :> Expression + + // let args = if Array.isEmpty generics then [|fullnameExpr; NullLiteral() :> Expression; refl|] else [|fullnameExpr; ArrayExpression generics :> Expression; refl|] + // coreLibCall com ctx None "Reflection" "type" args let transformValue (com: IBabelCompiler) (ctx: Context) r value: Expression = match value with - | Fable.TypeInfo t -> transformTypeInfo com ctx r Map.empty t + //| Fable.TypeDefInf + | Fable.TypeInfo t -> transformTypeInfo com ctx r [||] (fun _ -> None) t | Fable.Null _t -> // if com.Options.typescript // let ta = typeAnnotation com ctx t |> TypeAnnotation |> Some @@ -1156,7 +1300,13 @@ module Util = | Fable.FunctionType _ -> jsTypeof "function" expr | Fable.Array _ | Fable.Tuple _ -> coreLibCall com ctx None "Util" "isArrayLike" [|com.TransformAsExpr(ctx, expr)|] - | Fable.List _ -> jsInstanceof (coreValue com ctx "Types" "List") expr + | Fable.List _ -> + jsInstanceof (coreValue com ctx "Types" "List") expr + + | Fable.Expr _ -> + jsInstanceof (coreValue com ctx "Quotations" "FSharpExpr") expr + //coreLibCall com ctx None "ExprUtils" "isExpr" [| com.TransformAsExpr(ctx, expr) |] + | Replacements.Builtin kind -> match kind with | Replacements.BclGuid -> jsTypeof "string" expr @@ -1182,6 +1332,16 @@ module Util = upcast BooleanLiteral false | Fable.DeclaredType (ent, genArgs) -> match ent.TryFullName with + | Some "Microsoft.FSharp.Quotations.FSharpExpr" + | Some "Microsoft.FSharp.Quotations.FSharpExpr`1" -> jsInstanceof (coreValue com ctx "Quotations" "FSharpExpr") expr //coreLibCall com ctx None "ExprUtils" "isExpr" [| com.TransformAsExpr(ctx, expr) |] + | Some "System.Type" -> coreLibCall com ctx None "Reflection" "isType" [|com.TransformAsExpr(ctx, expr)|] + | Some "System.Reflection.MemberInfo" -> coreLibCall com ctx None "Reflection" "isMemberInfo" [|com.TransformAsExpr(ctx, expr)|] + | Some "System.Reflection.MethodBase" -> coreLibCall com ctx None "Reflection" "isMethodBase" [|com.TransformAsExpr(ctx, expr)|] + | Some "System.Reflection.MethodInfo" -> coreLibCall com ctx None "Reflection" "isMethodInfo" [|com.TransformAsExpr(ctx, expr)|] + | Some "System.Reflection.ConstructorInfo" -> coreLibCall com ctx None "Reflection" "isConstructorInfo" [|com.TransformAsExpr(ctx, expr)|] + | Some "System.Reflection.FieldInfo" -> coreLibCall com ctx None "Reflection" "isFieldInfo" [|com.TransformAsExpr(ctx, expr)|] + | Some "System.Reflection.PropertyInfo" -> coreLibCall com ctx None "Reflection" "isPropertyInfo" [|com.TransformAsExpr(ctx, expr)|] + | Some "Microsoft.FSharp.Reflection.UnionCaseInfo" -> coreLibCall com ctx None "Reflection" "isUnionCaseInfo" [|com.TransformAsExpr(ctx, expr)|] | Some Types.idisposable -> match expr.Type with // In F# AST this is coerced to obj, but the cast should have been removed @@ -1506,9 +1666,68 @@ module Util = | Fable.Debugger _ | Fable.Throw _ | Fable.Loop _ | Fable.TryCatch _ -> iife com ctx expr :> Expression + | Fable.Quote(_,data, r) -> + let obj (values : list) = + values |> List.toArray |> Array.map (fun (n,v) -> U3.Case1 (ObjectProperty(StringLiteral n, v))) |> ObjectExpression :> Expression + let values = + data.values |> Array.map (fun v -> + obj [ + "name", StringLiteral v.name :> Expression + "typ", transformAsExpr com ctx (Fable.Value(Fable.TypeInfo v.typ, None)) + "value", transformAsExpr com ctx v.expr + ] + ) + + let vars = data.variables |> Array.map (fun (v : Fable.VarData) -> + obj [ + "name", StringLiteral v.name :> Expression + "typ", transformAsExpr com ctx (Fable.Value(Fable.TypeInfo v.typ, None)) + "isMutable", BooleanLiteral v.isMutable :> Expression + ] + ) + + let types = data.types |> Array.map (fun t -> + transformAsExpr com ctx (Fable.Value(Fable.TypeInfo t, None)) + ) + + let members = data.members |> Array.map (fun (ent, t, m, margs) -> + let self = transformAsExpr com ctx (Fable.Value(Fable.TypeInfo t, None)) + let minst = margs |> Array.map (fun t -> transformAsExpr com ctx (Fable.Value(Fable.TypeInfo t, None))) + + let arr = transformMemberReflectionInfosNew com ctx None self (ArrayExpression [||]) ent [|m|] + let meth = arr.[0] + if margs.Length > 0 then + CallExpression(MemberExpression(meth, Identifier "MakeGenericMethod"), [| ArrayExpression minst |]) :> Expression + else + meth + + ) + + let literals = + data.literals |> Array.map (fun e -> + obj [ + "value", transformAsExpr com ctx e + "typ", transformAsExpr com ctx (Fable.Value(Fable.TypeInfo e.Type, None)) + ] + ) + + // let arrName = getTypedArrayName com NumberKind.UInt8 + // let expr = NewExpression(Identifier arrName, [| data.data |> Array.map (fun v -> NumericLiteral (float v) :> Expression) |> ArrayExpression |]) + coreLibCall com ctx r "ExprUtils" "deserialize" [| + ArrayExpression values + ArrayExpression vars + ArrayExpression types + ArrayExpression members + ArrayExpression literals + StringLiteral (System.Convert.ToBase64String data.data) + |] + let rec transformAsStatements (com: IBabelCompiler) ctx returnStrategy (expr: Fable.Expr): Statement array = match expr with + | Fable.Quote _ -> + [| transformAsExpr com ctx expr |> resolveExpr expr.Type returnStrategy |] + | Fable.TypeCast(e, t) -> [|transformCast com ctx t e |> resolveExpr t returnStrategy|] @@ -1882,14 +2101,14 @@ module Util = let classExpr = ClassExpression(classBody, ?superClass=Some baseRef, ?typeParameters=typeParamDecl, ?loc=r) classExpr |> declareModuleMember r isPublic name false - let declareType (com: IBabelCompiler) ctx r isPublic (ent: FSharpEntity) name (consArgs: Pattern[]) (consBody: BlockStatement) baseExpr: U2 list = + let declareType (com: IBabelCompiler) ctx r isPublic declaringName (mems: Fable.MemberInfo[]) (ent: FSharpEntity) name (consArgs: Pattern[]) (consBody: BlockStatement) baseExpr: U2 list = let typeDeclaration = if com.Options.classTypes then declareClassType com ctx r isPublic ent name consArgs consBody baseExpr else declareObjectType com ctx r isPublic ent name consArgs consBody baseExpr let reflectionDeclaration = let genArgs = Array.init ent.GenericParameters.Count (fun _ -> makeIdentUnique com "gen" |> typedIdent com ctx) - let body = transformReflectionInfo com ctx r ent (Array.map (fun x -> x :> _) genArgs) + let body = transformReflectionInfo com ctx r ent declaringName mems (Array.map (fun x -> x :> _) genArgs) let returnType = if com.Options.typescript then makeImportTypeAnnotation com ctx [] "Reflection" "TypeInfo" @@ -1969,7 +2188,7 @@ module Util = |> ExpressionStatement :> Statement |> U2<_,ModuleDeclaration>.Case1 |> List.singleton - let transformUnionConstructor (com: IBabelCompiler) ctx r (info: Fable.UnionConstructorInfo) = + let transformUnionConstructor (com: IBabelCompiler) ctx r (declaringName: Option) (info: Fable.UnionConstructorInfo) = let baseRef = coreValue com ctx "Types" "Union" let argId: Fable.Ident = { Name = ""; Type = Fable.Any; Kind = Fable.UserDeclared; IsMutable = false; Range = None } let tagId = { argId with Name = "tag"; Type = Fable.Number Int32 } @@ -1997,9 +2216,9 @@ module Util = | _ -> ident id :> Expression assign None left right |> ExpressionStatement :> Statement) |> BlockStatement - declareType com ctx r info.IsPublic info.Entity info.EntityName args body (Some baseRef) + declareType com ctx r info.IsPublic declaringName info.Members info.Entity info.EntityName args body (Some baseRef) - let transformCompilerGeneratedConstructor (com: IBabelCompiler) ctx r (info: Fable.CompilerGeneratedConstructorInfo) = + let transformCompilerGeneratedConstructor (com: IBabelCompiler) ctx r (declaringName: Option) (info: Fable.CompilerGeneratedConstructorInfo) = let fieldIds = getEntityFieldsAsIdents com info.Entity let args = fieldIds |> Array.map ident let body = @@ -2021,9 +2240,9 @@ module Util = else None let typedPattern = typedIdent com ctx >> toPattern let args = fieldIds |> Array.map typedPattern - declareType com ctx r info.IsPublic info.Entity info.EntityName args body baseExpr + declareType com ctx r info.IsPublic declaringName info.Members info.Entity info.EntityName args body baseExpr - let transformImplicitConstructor (com: IBabelCompiler) ctx r (info: Fable.ClassImplicitConstructorInfo) = + let transformImplicitConstructor (com: IBabelCompiler) ctx r (declaringName : Option) (info: Fable.ClassImplicitConstructorInfo) = let boundThis = Some("this", info.BoundConstructorThis) let consIdent = Identifier(info.EntityName) :> Expression let args, body, returnType, typeParamDecl = getMemberArgsAndBody com ctx None boundThis info.Arguments info.HasSpread info.Body @@ -2077,7 +2296,7 @@ module Util = | None when info.Entity.IsValueType -> coreValue com ctx "Types" "Record" |> Some | None -> None [ - yield! declareType com ctx r info.IsEntityPublic info.Entity info.EntityName args body baseExpr + yield! declareType com ctx r info.IsEntityPublic declaringName info.Members info.Entity info.EntityName args body baseExpr yield declareModuleMember r info.IsConstructorPublic info.Name false exposedCons ] @@ -2106,15 +2325,15 @@ module Util = [declareModuleMember info.Range info.IsPublic info.Name info.IsMutable value] |> List.append transformed |> transformDeclarations com ctx restDecls - | Fable.ConstructorDeclaration(kind, r) -> + | Fable.ConstructorDeclaration(declaringName, kind, r) -> let consDecls = match kind with | Fable.ClassImplicitConstructor info -> - transformImplicitConstructor com ctx r info + transformImplicitConstructor com ctx r declaringName info | Fable.UnionConstructor info -> - transformUnionConstructor com ctx r info + transformUnionConstructor com ctx r declaringName info | Fable.CompilerGeneratedConstructor info -> - transformCompilerGeneratedConstructor com ctx r info + transformCompilerGeneratedConstructor com ctx r declaringName info consDecls |> List.append transformed |> transformDeclarations com ctx restDecls @@ -2137,6 +2356,15 @@ module Util = | _ -> transformOverrideMethod com ctx info args body, restDecls List.append transformed newDecls |> transformDeclarations com ctx restDecls + | Fable.ModuleDeclaration(declaringName, name, ent, mems) -> + //sprintf "module %s" name |> addWarning com [] None + //transformed |> transformDeclarations com ctx restDecls + let reflectionDeclaration = + let body = transformRecordReflectionInfo com ctx None ent declaringName mems [||] + makeFunctionExpression None ([||], U2.Case2 body, None, None) + |> declareModuleMember None true (Naming.appendSuffix name Naming.reflectionSuffix) false + List.append transformed [reflectionDeclaration] + |> transformDeclarations com ctx restDecls let transformImports (imports: Import seq): U2 list = imports |> Seq.map (fun import -> @@ -2238,6 +2466,8 @@ module Compiler = member __.GetOrAddInlineExpr(fullName, generate) = com.GetOrAddInlineExpr(fullName, generate) member __.AddLog(msg, severity, ?range, ?fileName:string, ?tag: string) = com.AddLog(msg, severity, ?range=range, ?fileName=fileName, ?tag=tag) + member __.RemoveLastError() = + com.RemoveLastError() let makeCompiler com = BabelCompiler(com) diff --git a/src/Fable.Transforms/FableTransforms.fs b/src/Fable.Transforms/FableTransforms.fs index 2123e24d1d..8618c8bd19 100644 --- a/src/Fable.Transforms/FableTransforms.fs +++ b/src/Fable.Transforms/FableTransforms.fs @@ -7,6 +7,7 @@ open FSharp.Compiler.SourceCodeServices // TODO: Use trampoline here? let visit f e = match e with + | Quote(b, e, r) -> Quote(b, { e with values = e.values |> Array.map (fun v -> { v with expr = f v.expr }) }, r) | IdentExpr _ | Debugger _ -> e | TypeCast(e, t) -> TypeCast(f e, t) | Import(e1, e2, kind, t, r) -> Import(f e1, f e2, kind, t, r) @@ -106,6 +107,7 @@ let rec visitFromOutsideIn (f: Expr->Expr option) e = visit (visitFromOutsideIn f) e let getSubExpressions = function + | Quote(_, data, _) -> data.values |> Array.toList |> List.map (fun v -> v.expr) | IdentExpr _ | Debugger _ -> [] | TypeCast(e,_) -> [e] | Import(e1,e2,_,_,_) -> [e1;e2] @@ -356,7 +358,7 @@ module private Transforms = // For function arguments check if the arity of their own function arguments is expected or not // TODO: Do we need to do this recursively, and check options and delegates too? - let checkSubArguments com expectedType (expr: Expr) = + let checkSubArguments _com expectedType (expr: Expr) = match expectedType, expr with | NestedLambdaType(expectedArgs,_), ExprType(NestedLambdaType(actualArgs,_)) -> let actualArgs = List.truncate expectedArgs.Length actualArgs @@ -567,11 +569,13 @@ let optimizeExpr (com: ICompiler) e = List.fold (fun e f -> f com e) e optimizations let rec optimizeDeclaration (com: ICompiler) = function + | ModuleDeclaration(decl, name, ent, mems) -> + ModuleDeclaration(decl, name, ent, mems) | ActionDeclaration expr -> ActionDeclaration(optimizeExpr com expr) | ValueDeclaration(value, info) -> ValueDeclaration(optimizeExpr com value, info) - | ConstructorDeclaration(kind, r) -> + | ConstructorDeclaration(decl, kind, r) -> let kind = match kind with | ClassImplicitConstructor info -> @@ -587,7 +591,7 @@ let rec optimizeDeclaration (com: ICompiler) = function info.Arguments, info.Body ClassImplicitConstructor { info with Arguments = args; Body = body } | kind -> kind - ConstructorDeclaration(kind, r) + ConstructorDeclaration(decl, kind, r) | AttachedMemberDeclaration(args, body, info) -> AttachedMemberDeclaration(args, optimizeExpr com body, info) diff --git a/src/Fable.Transforms/Global/Compiler.fs b/src/Fable.Transforms/Global/Compiler.fs index bfad2cb519..3c4dbfae99 100644 --- a/src/Fable.Transforms/Global/Compiler.fs +++ b/src/Fable.Transforms/Global/Compiler.fs @@ -16,6 +16,7 @@ type CompilerOptions = /// Meant for precompiled libraries (like the Repl Lib) /// to make public inlined functions part of the JS outputPublicInlinedFunctions: bool + quotations: bool /// Mainly intended for the REPL to compile REPL lib calls precompiledLib: (string -> (string*string) option) option } @@ -42,3 +43,4 @@ type ICompiler = abstract GetOrAddInlineExpr: string * (unit->InlineExpr) -> InlineExpr abstract AddLog: msg:string * severity: Severity * ?range:SourceLocation * ?fileName:string * ?tag: string -> unit + abstract RemoveLastError : unit -> unit diff --git a/src/Fable.Transforms/Global/Prelude.fs b/src/Fable.Transforms/Global/Prelude.fs index 8a3f7b98ab..91be0e5ff5 100644 --- a/src/Fable.Transforms/Global/Prelude.fs +++ b/src/Fable.Transforms/Global/Prelude.fs @@ -243,6 +243,7 @@ module Naming = check 0 type MemberPart = + | ReflectionMemberPart | InstanceMemberPart of string * overloadSuffix: string | StaticMemberPart of string * overloadSuffix: string | NoMemberPart @@ -264,6 +265,7 @@ module Naming = let private buildName sanitize name part = (sanitize name) + (match part with + | ReflectionMemberPart -> "$" + reflectionSuffix | InstanceMemberPart(s, i) -> printPart sanitize "$$" s i | StaticMemberPart(s, i) -> printPart sanitize "$$$" s i | NoMemberPart -> "") diff --git a/src/Fable.Transforms/QuotationPickler.fs b/src/Fable.Transforms/QuotationPickler.fs new file mode 100644 index 0000000000..8cb5ce410e --- /dev/null +++ b/src/Fable.Transforms/QuotationPickler.fs @@ -0,0 +1,700 @@ +module Fable.Transforms.FSharp2Fable.QuotationPickler + +open Fable.Transforms +open FSharp.Compiler.SourceCodeServices +open Fable.Transforms.FSharp2Fable.Helpers + +type MemberDescription = + | Member of FSharpMemberOrFunctionOrValue * list * list + | UnionCase of FSharpUnionCase * list + + +type BinaryWriter() = + + static let nextPowerOfTwo (v : int) = + let mutable x = v - 1 + x <- x ||| (x >>> 1) + x <- x ||| (x >>> 2) + x <- x ||| (x >>> 4) + x <- x ||| (x >>> 8) + x <- x ||| (x >>> 16) + x + 1 + + let mutable arr : byte[] = Array.zeroCreate 16 + let mutable position = 0 + + member x.Write(bytes : byte[], offset : int, length : int) = + let len = position + length + if len > arr.Length then + let cap = nextPowerOfTwo len + let n = Array.zeroCreate cap + for i in 0 .. position - 1 do n.[i] <- arr.[i] + arr <- n + + let mutable i = offset + let mutable o = position + for c in 0 .. length - 1 do + arr.[o] <- bytes.[i] + o <- o + 1 + i <- i + 1 + position <- len + + member x.Write(bytes : byte[]) = + x.Write(bytes, 0, bytes.Length) + + member x.Write(i : uint8) = x.Write [| i |] + member x.Write(i : int8) = x.Write [| uint8 i |] + member x.Write(i : uint16) = x.Write (System.BitConverter.GetBytes i) + member x.Write(i : int16) = x.Write (System.BitConverter.GetBytes i) + member x.Write(i : uint32) = x.Write (System.BitConverter.GetBytes i) + member x.Write(i : int32) = x.Write (System.BitConverter.GetBytes i) + member x.Write(i : uint64) = x.Write (System.BitConverter.GetBytes i) + member x.Write(i : int64) = x.Write (System.BitConverter.GetBytes i) + member x.Write(i : float32) = x.Write (System.BitConverter.GetBytes i) + member x.Write(i : float) = x.Write (System.BitConverter.GetBytes i) + member x.Write(i : string) = x.Write (System.Text.Encoding.UTF8.GetBytes i) + + member x.ToByteArray() = arr.[0..position-1] + +type PicklerState = + { + varId : int + variables : list + + valueId : int + values : list + + literalId : int + literals : list + + memberId : int + members : list + + typeId : int + types : list> * int> + + cases : list * FSharpExpr>> + + debug : bool + com : IFableCompiler + ctx : Context + err : bool + + writer : BinaryWriter + } + +type State<'s, 'a> = ref<'s> -> 'a + +//type State<'s, 'a> = { run : 's -> 's * 'a } +module State = + let inline get<'s> : State<'s, 's> = fun s -> !s + let inline put (n : 's) : State<'s, unit> = fun s -> s := n + let inline modify (f : 's -> 's) : State<'s, unit> = fun s -> s := f !s + + let inline map (f : 'a -> 'b) (m : State<'s, 'a>) : State<'s, 'b> = + fun s -> f (m s) + let inline bind (f : 'a -> State<'s, 'b>) (m : State<'s, 'a>) : State<'s, 'b> = + fun s -> f (m s) s + + let inline value (v : 'a) : State<'s, 'a> = fun _ -> v + + type StateBuilder() = + member inline x.Bind(m : State<'s, 'a>, f : 'a -> State<'s, 'b>) = bind f m + member inline x.Return v = value v + member inline x.ReturnFrom(s : State<'s, 'a>) = s + member inline x.Zero() = value () + member inline x.Delay (f : unit -> State<'s, 'a>) = fun s -> f () s + member inline x.Combine(l : State<'s, unit>, r : State<'s, 'a>) = l |> bind (fun () -> r) + member inline x.For(seq : seq<'a>, action : 'a -> State<'s, unit>) = + fun s -> + for e in seq do + action e s + + member inline x.While(guard : unit -> bool, body : State<'s, unit>) = + fun s -> + while guard() do + body s + + +let state = State.StateBuilder() + +module List = + let rec mapS (f : 'a -> State<'s, 'b>) (l : list<'a>) = + match l with + | [] -> State.value [] + | h :: t -> + f h |> State.bind (fun h -> mapS f t |> State.map (fun t -> h :: t)) + +module Pickler = + let inline newVar (l : FSharpMemberOrFunctionOrValue) : State = + fun (s : ref) -> + let o = !s + s := + { o with + varId = o.varId + 1 + variables = (l, o.varId) :: o.variables + } + o.varId + + let inline tryGetVar (l : FSharpMemberOrFunctionOrValue) = + State.get |> State.map (fun s -> + s.variables |> List.tryPick (fun (m, i) -> if m = l then Some i else None) + ) + + let inline getVar (l : FSharpMemberOrFunctionOrValue) = + tryGetVar l |> State.map Option.get + + let inline useValue (l : FSharpMemberOrFunctionOrValue) : State = + fun s -> + let o = !s + let res = o.values |> List.tryPick (fun (v,i) -> if v = l then Some i else None) + match res with + | Some res -> + res + | None -> + let id = o.valueId + s := { o with valueId = id + 1; values = (l, id) :: o.values } + id + let inline useType (t : FSharpType) : State = + fun s -> + let o = !s + let res = o.types |> List.tryPick (function (Choice1Of2 v,i) when v = t -> Some i | _ -> None) + match res with + | Some res -> + res + | None -> + let id = o.typeId + s := { o with typeId = id + 1; types = (Choice1Of2 t, id) :: o.types } + id + let inline useTypeDef (t : FSharpEntity) (targs : list) : State= + fun s -> + let o = !s + let res = o.types |> List.tryPick (function (Choice2Of2(v,ta),i) when v = t && ta = targs -> Some i | _ -> None) + match res with + | Some res -> + res + | None -> + let id = o.typeId + s := { o with typeId = id + 1; types = (Choice2Of2(t, targs), id) :: o.types } + id + let inline useMember (mem : FSharpMemberOrFunctionOrValue) (targs : list) (margs : list) : State = + fun s -> + let o = !s + let res = o.members |> List.tryPick (function (Member(v,t,m),i) when v = mem && t = targs && m = margs -> Some i | _ -> None) + match res with + | Some res -> + res + | None -> + let id = o.memberId + s := { o with memberId = id + 1; members = (Member (mem, targs, margs), id) :: o.members } + id + + let inline useUnionCase (case : FSharpUnionCase) (targs : list) : State = + fun s -> + let o = !s + let res = o.members |> List.tryPick (function (UnionCase(c,t),i) when c = case && t = targs -> Some i | _ -> None) + match res with + | Some res -> + res + | None -> + let id = o.memberId + s := { o with memberId = id + 1; members = (UnionCase(case,targs), id) :: o.members } + id + + + let inline useLiteral (v : obj) (t : FSharpType) : State = + fun s -> + let o = !s + let res = o.literals |> List.tryPick (fun (vi,ti,i) -> if vi = v && ti = t then Some i else None) + match res with + | Some res -> + res + | None -> + let id = o.literalId + s := { o with literalId = id + 1; literals = (v, t, id) :: o.literals } + id + //let writeByte (b : byte) = fun (s : ref) -> s.Value.writer.Write b + let writeInt (b : int) = fun (s : ref) -> s.Value.writer.Write b + + let writeString (v : string) = + fun (s : ref) -> + let bytes = System.Text.Encoding.UTF8.GetBytes v + s.Value.writer.Write(bytes.Length) + s.Value.writer.Write bytes + + + let writeStringArray (v : string[]) = + state { + do! writeInt v.Length + for s in v do do! writeString s + + } + + let writeIntArray (vs : seq) = + fun (s : ref) -> + let vs = Seq.toArray vs + s.Value.writer.Write vs.Length + for v in vs do s.Value.writer.Write v + + let writeOpCode (range : Option) (code : byte)= + fun (s : ref) -> + let s = !s + if s.debug then + match range with + | Some l -> + s.writer.Write (128uy + code) + s.writer.Write(l.start.line) + s.writer.Write(l.start.column) + s.writer.Write(l.``end``.line) + s.writer.Write(l.``end``.column) + | None -> + s.writer.Write (code) + else + s.writer.Write (code) + + + + let inline pushCases (cs : array * FSharpExpr>) = + State.modify (fun s -> { s with cases = cs :: s.cases }) + + let popCases = + State.modify (fun s -> + match s.cases with + | _ :: cs -> { s with cases = cs } + | _ -> s + ) + + let inline getCase (i : int) = + State.get |> State.map (fun s -> + match s.cases with + | h :: _ -> h.[i] + | _ -> failwith "invalid case" + ) + + + let inline addError r msg = + fun (s : ref) -> + addError s.Value.com s.Value.ctx.InlinePath r msg + s := { !s with err = true } + + + let inline addWarning r msg = + State.get |> State.map (fun s -> + addWarning s.com s.ctx.InlinePath r msg + ) +let rec propertyGetS (loc : Option) (tid : int) (target : Option) (name : string) (index : list) (ret : int) = + state { + match target with + | Some target -> + do! Pickler.writeOpCode loc 18uy + do! Pickler.writeInt tid + do! Pickler.writeString name + do! Pickler.writeInt index.Length + for i in index do do! serializeS i + do! Pickler.writeInt ret + do! serializeS target + | None -> + do! Pickler.writeOpCode loc 19uy + do! Pickler.writeInt tid + do! Pickler.writeString name + do! Pickler.writeInt index.Length + for i in index do do! serializeS i + do! Pickler.writeInt ret + } + +and propertySetS (loc : Option) (tid : int) (target : Option) (name : string) (index : list) (value : FSharpExpr) = + state { + let! ret = Pickler.useType value.Type + match target with + | Some target -> + do! Pickler.writeOpCode loc 20uy + do! Pickler.writeInt tid + do! Pickler.writeString name + do! Pickler.writeInt index.Length + for i in index do do! serializeS i + do! Pickler.writeInt ret + do! serializeS target + do! serializeS value + | None -> + do! Pickler.writeOpCode loc 21uy + do! Pickler.writeInt tid + do! Pickler.writeString name + do! Pickler.writeInt index.Length + for i in index do do! serializeS i + do! Pickler.writeInt ret + do! serializeS value + } + +and serializeS (expr : FSharpExpr) = + state { + let loc = Helpers.makeRangeFrom expr + match expr with + | BasicPatterns.Lambda(v, b) -> + let! var = Pickler.newVar v + do! Pickler.writeOpCode loc 1uy + do! Pickler.writeInt var + return! serializeS b + + | BasicPatterns.Value v -> + match! Pickler.tryGetVar v with + | Some var -> + do! Pickler.writeOpCode loc 2uy + do! Pickler.writeInt var + | None -> + let! var = Pickler.useValue v + do! Pickler.writeOpCode loc 3uy + do! Pickler.writeInt var + + + | BasicPatterns.Let((v, e), b) -> + let! var = Pickler.newVar v + do! Pickler.writeOpCode loc 4uy + do! Pickler.writeInt var + do! serializeS e + do! serializeS b + + | BasicPatterns.FSharpFieldGet(target, typ, field) -> + let! tid = Pickler.useType typ + let! ret = Pickler.useType field.FieldType + do! propertyGetS loc tid target field.Name [] ret + + | BasicPatterns.FSharpFieldSet(target, typ, field, value) -> + let! tid = Pickler.useType typ + do! propertySetS loc tid target field.Name [] value + + | BasicPatterns.AddressOf e -> + do! Pickler.writeOpCode loc 7uy + do! serializeS e + + | BasicPatterns.AddressSet(v, e) -> + do! Pickler.writeOpCode loc 8uy + do! serializeS v + do! serializeS e + + | BasicPatterns.AnonRecordGet(e, t, i) -> + let fieldName = t.AnonRecordTypeDetails.SortedFieldNames.[i] + let! typ = Pickler.useType t + do! Pickler.writeOpCode loc 9uy + do! Pickler.writeInt typ + do! Pickler.writeString fieldName + do! serializeS e + + | BasicPatterns.Application(e, ts, args) -> + do! Pickler.writeOpCode loc 10uy + do! serializeS e + do! Pickler.writeInt args.Length + for a in args do + do! serializeS a + + | BasicPatterns.Const(o, t) -> + do! Pickler.writeOpCode loc 11uy + let! vid = Pickler.useLiteral o t + do! Pickler.writeInt vid + + | BasicPatterns.IfThenElse(c, i, e) -> + do! Pickler.writeOpCode loc 12uy + do! serializeS c + do! serializeS i + do! serializeS e + + | BasicPatterns.UnionCaseTest(expr, typ, case) -> + do! Pickler.writeOpCode loc 13uy + let! tid = Pickler.useType typ + do! Pickler.writeInt tid + do! Pickler.writeString case.CompiledName + do! serializeS expr + + | BasicPatterns.UnionCaseGet(target, typ, case, prop) -> + let index = case.UnionCaseFields |> Seq.findIndex (fun pi -> pi = prop) + let! tid = Pickler.useType typ + + do! Pickler.writeOpCode loc 14uy + do! Pickler.writeInt tid + do! Pickler.writeString case.CompiledName + do! Pickler.writeInt index + do! serializeS target + + | BasicPatterns.Coerce(t, e) -> + let! tid = Pickler.useType t + do! Pickler.writeOpCode loc 15uy + do! Pickler.writeInt tid + do! serializeS e + + | BasicPatterns.DefaultValue t -> + let! tid = Pickler.useType t + do! Pickler.writeOpCode loc 16uy + do! Pickler.writeInt tid + + | BasicPatterns.FastIntegerForLoop(s, e, BasicPatterns.Lambda(v, b), true) -> + let! vid = Pickler.newVar v + do! Pickler.writeOpCode loc 17uy + do! Pickler.writeInt vid + do! serializeS s + do! serializeS e + do! serializeS b + + + + | BasicPatterns.ILFieldGet(target, typ, field) -> + let! tid = Pickler.useType typ + let! ret = Pickler.useType expr.Type + do! propertyGetS loc tid target field [] ret + + | BasicPatterns.ILFieldSet(target, typ, field, value) -> + let! tid = Pickler.useType typ + do! propertySetS loc tid target field [] value + + | BasicPatterns.LetRec(vs, b) -> + do! Pickler.writeOpCode loc 22uy + do! Pickler.writeInt vs.Length + for (v, e) in vs do + let! vid = Pickler.newVar v + do! Pickler.writeInt vid + do! serializeS e + do! serializeS b + + | BasicPatterns.NewAnonRecord(typ, fields) -> + // code 23 + do! Pickler.addError (makeRangeFrom expr) "anonymous records not supported in quotations atm." + + | BasicPatterns.NewArray(elementType, args) -> + let! tid = Pickler.useType elementType + do! Pickler.writeOpCode loc 24uy + do! Pickler.writeInt tid + do! Pickler.writeInt args.Length + for a in args do do! serializeS a + + | BasicPatterns.NewDelegate _ -> + // code 25 + do! Pickler.addError (makeRangeFrom expr) "delegates not supported in quotations atm." + + | BasicPatterns.NewObject(ctor, targs, args) -> + let! tid = Pickler.useTypeDef ctor.DeclaringEntity.Value targs + let! tids = args |> List.mapS (fun a -> Pickler.useType a.Type) + do! Pickler.writeOpCode loc 26uy + do! Pickler.writeInt tid + do! Pickler.writeIntArray tids + for a in args do do! serializeS a + + | BasicPatterns.NewRecord(typ, args) -> + let! tid = Pickler.useType typ + do! Pickler.writeOpCode loc 27uy + do! Pickler.writeInt tid + do! Pickler.writeInt args.Length + for a in args do do! serializeS a + + | BasicPatterns.NewTuple(typ, args) -> + do! Pickler.writeOpCode loc 28uy + do! Pickler.writeInt args.Length + for a in args do do! serializeS a + + | BasicPatterns.NewUnionCase(typ, case, args) -> + let! tid = Pickler.useType typ + do! Pickler.writeOpCode loc 29uy + do! Pickler.writeInt tid + do! Pickler.writeString case.Name + do! Pickler.writeInt args.Length + for a in args do do! serializeS a + | BasicPatterns.Quote(e) -> + do! Pickler.writeOpCode loc 30uy + do! serializeS e + + | BasicPatterns.Sequential(l, r) -> + do! Pickler.writeOpCode loc 31uy + do! serializeS l + do! serializeS r + | BasicPatterns.TupleGet(_typ, i, target) -> + do! Pickler.writeOpCode loc 32uy + do! Pickler.writeInt i + do! serializeS target + | BasicPatterns.TypeTest(typ, target) -> + let! tid = Pickler.useType typ + do! Pickler.writeOpCode loc 33uy + do! Pickler.writeInt tid + do! serializeS target + + | BasicPatterns.UnionCaseTag(e, t) -> + // code 34 + do! Pickler.addError (makeRangeFrom expr) "UnionCaseTags not supported in quotations atm." + + | BasicPatterns.UnionCaseSet(target, typ, case, prop, value) -> + // code 35 + do! Pickler.addError (makeRangeFrom expr) "UnionCaseSet not supported in quotations atm." + + | BasicPatterns.ValueSet(v, value) -> + let! var = Pickler.tryGetVar v + match var with + | Some var -> + do! Pickler.writeOpCode loc 36uy + do! Pickler.writeInt var + do! serializeS value + | None -> + // code 37 + do! Pickler.addError (makeRangeFrom expr) "static property sets not supported in quotations atm." + | BasicPatterns.WhileLoop(guard, body) -> + do! Pickler.writeOpCode loc 38uy + do! serializeS guard + do! serializeS body + + | BasicPatterns.DecisionTreeSuccess(id, values) -> + let! (vars, body) = Pickler.getCase id + let bindings = List.zip vars values + let rec wrap (l : list) = + state { + match l with + | [] -> return! serializeS body + | (v,e) :: ls -> + let! var = Pickler.newVar v + do! Pickler.writeOpCode loc 4uy + do! Pickler.writeInt var + do! serializeS e + do! wrap ls + } + do! wrap bindings + + | BasicPatterns.DecisionTree(target, cases) -> + do! Pickler.pushCases (List.toArray cases) + do! serializeS target + do! Pickler.popCases + + + | BasicPatterns.Call(target, m, targs, margs, args) -> + let args = + match args with + | [unitArg] when Helpers.isUnit unitArg.Type -> [] + | args -> args + + if m.IsValue && List.isEmpty args && List.isEmpty margs && Option.isSome m.DeclaringEntity && m.DeclaringEntity.Value.IsFSharpModule then + let! tid = Pickler.useTypeDef m.DeclaringEntity.Value targs + let! ret = Pickler.useType m.ReturnParameter.Type + do! propertyGetS loc tid target m.CompiledName [] ret + + elif not m.IsExtensionMember && m.IsPropertyGetterMethod then + let name = + let name = m.CompiledName + if name.StartsWith "get_" then name.Substring(4) + else name + + let args = + match args with + | unitVal :: rest when Helpers.isUnit unitVal.Type -> rest + | args -> args + + let! tid = Pickler.useTypeDef m.DeclaringEntity.Value targs + let! ret = Pickler.useType m.ReturnParameter.Type + do! propertyGetS loc tid target name args ret + + elif not m.IsExtensionMember && m.IsPropertySetterMethod then + let name = + let name = m.CompiledName + if name.StartsWith "set_" then name.Substring(4) + else name + + let args = + match args with + | unitVal :: rest when Helpers.isUnit unitVal.Type -> rest + | args -> args + + let idx, value = + match args with + | [] -> failwith "unreachable" + | _ -> + let value = List.last args + let idx = List.take (args.Length - 1) args + idx, value + + let! tid = Pickler.useTypeDef m.DeclaringEntity.Value targs + do! propertySetS loc tid target name idx value + else + let! tid = Pickler.useTypeDef m.DeclaringEntity.Value targs + let! rid = Pickler.useType m.ReturnParameter.Type + let! margs = margs |> List.mapS Pickler.useType + let mpars = m.GenericParameters |> Seq.map (fun p -> p.Name) |> Seq.toArray + let! aids = m.CurriedParameterGroups |> Seq.concat |> Seq.toList |> List.mapS (fun p -> Pickler.useType p.Type) + match target with + | Some target -> + do! Pickler.writeOpCode loc 5uy + do! Pickler.writeInt tid + do! Pickler.writeString m.CompiledName + do! Pickler.writeStringArray mpars + do! Pickler.writeIntArray margs + do! Pickler.writeIntArray aids + do! Pickler.writeInt rid + do! Pickler.writeInt args.Length + + do! serializeS target + for a in args do + do! serializeS a + + | _ -> + do! Pickler.writeOpCode loc 6uy + do! Pickler.writeInt tid + do! Pickler.writeString m.CompiledName + do! Pickler.writeStringArray mpars + do! Pickler.writeIntArray margs + do! Pickler.writeIntArray aids + do! Pickler.writeInt rid + do! Pickler.writeInt args.Length + + for a in args do + do! serializeS a + + | _ -> + do! Pickler.writeOpCode loc 127uy + do! Pickler.writeString (sprintf "BAD EXPRESSION: %A" expr) + } + +type VarData = + { name : string; typ : FSharpType; isMutable : bool } + +type ExprData = + { + typ : FSharpType + variables : VarData[] + values : FSharpMemberOrFunctionOrValue[] + members : array + types : Choice>[] + literals : array + data : byte[] + } + +let serialize (com : IFableCompiler) (ctx : Context) (expr : FSharpExpr) = + let s = serializeS expr + let w = BinaryWriter() + + let state = ref { debug = false; varId = 0; variables = []; valueId = 0; values = []; writer = w; typeId = 0; types = []; memberId = 0; members = []; literalId = 0; literals = []; cases = []; com = com; ctx = ctx; err = false } + Pickler.writeString expr.Range.FileName state + + s state + let s = !state + + + + let data = w.ToByteArray() + let variables = + s.variables + |> List.sortBy snd + |> List.map (fun (m,_) -> + { name = m.DisplayName; typ = m.FullType; isMutable = m.IsMutable } + ) + |> List.toArray + let values = s.values |> List.sortBy snd |> List.map fst |> List.toArray + let types = s.types |> List.sortBy snd |> List.map fst |> List.toArray + let members = s.members |> List.sortBy (fun (_,i) -> i) |> List.map (fun (m,_) -> m) |> List.toArray + let literals = s.literals |> List.sortBy (fun (_,_,i) -> i) |> List.map (fun (t, v, _) -> t, v) |> List.toArray + { + typ = expr.Type + variables = variables + values = values + types = types + members = members + literals = literals + data = data + } + + + + + + + diff --git a/src/Fable.Transforms/Replacements.fs b/src/Fable.Transforms/Replacements.fs index e02dfa587f..7a38dfcda3 100644 --- a/src/Fable.Transforms/Replacements.fs +++ b/src/Fable.Transforms/Replacements.fs @@ -25,6 +25,9 @@ type Helper = let argTypes = match argTypes with Some xs -> Typed xs | None -> NoUncurrying Operation(Call(kind, argInfo (Some callee) args argTypes), returnType, loc) + static member InstanceField(callee: Expr, memb: string, typ: Type, ?loc: SourceLocation) = + Get(callee, GetKind.FieldGet(memb, false, typ), typ, loc) + static member Application(callee: Expr, returnType: Type, args: Expr list, ?argTypes: Type list, ?loc: SourceLocation) = let argTypes = match argTypes with Some xs -> Typed xs | None -> NoUncurrying @@ -229,6 +232,13 @@ let (|Nameof|_|) com ctx = function let (|ReplaceName|_|) (namesAndReplacements: (string*string) list) name = namesAndReplacements |> List.tryPick (fun (name2, replacement) -> if name2 = name then Some replacement else None) +let (|DeclaredFullNameType|_|) = function + | DeclaredType(ent, targs) -> + match ent.TryFullName with + | Some name -> Some (ent, name, targs) + | _ -> None + | _ -> + None let inline (|ExprType|) (e: Expr) = e.Type @@ -362,14 +372,22 @@ let makeTypeInfo r t = let makeTypeDefinitionInfo r t = let t = match t with - | Option _ -> Option Any - | Array _ -> Array Any - | List _ -> List Any + | Option _ -> Option (GenericParam "a0") + | Array _ -> Array (GenericParam "a0") + | List _ -> List (GenericParam "a0") | Tuple genArgs -> - genArgs |> List.map (fun _ -> Any) |> Tuple + genArgs |> List.mapi (fun i _ -> (GenericParam (sprintf "a%d" i))) |> Tuple | DeclaredType(ent, genArgs) -> - let genArgs = genArgs |> List.map (fun _ -> Any) + let names = ent.GenericParameters |> Seq.map (fun p -> p.Name) |> Seq.toList + let genArgs = names |> List.map GenericParam DeclaredType(ent, genArgs) + | FunctionType(kind,r) -> + let kind, ret = + match kind with + | LambdaType(a) -> LambdaType (GenericParam "a0"), "a1" + | DelegateType(a) -> DelegateType (a |> List.mapi (fun i _ -> GenericParam (sprintf "a%d" i))), sprintf "a%d" a.Length + FunctionType(kind, GenericParam ret) + | ErasedUnion a -> ErasedUnion a // TODO: Do something with FunctionType and ErasedUnion? | t -> t TypeInfo t |> makeValue r @@ -694,7 +712,7 @@ let applyOp (com: ICompiler) (ctx: Context) r t opName (args: Expr list) argType let isCompatibleWithJsComparison = function | Builtin(BclInt64|BclUInt64|BclDecimal|BclBigInt) - | Array _ | List _ | Tuple _ | Option _ | MetaType -> false + | Array _ | List _ | Tuple _ | Option _ | MetaType | Expr _ -> false | Builtin(BclGuid|BclTimeSpan) -> true // TODO: Non-record/union declared types without custom equality // should be compatible with JS comparison @@ -752,6 +770,28 @@ let rec equals (com: ICompiler) r equal (left: Expr) (right: Expr) = Helper.CoreCall("Util", "equals", Boolean, [left; right], ?loc=r) |> is equal | MetaType -> Helper.CoreCall("Reflection", "equals", Boolean, [left; right], ?loc=r) |> is equal + + | DeclaredFullNameType(_ent, ("System.Reflection.MemberInfo" | "System.Reflection.MethodBase"), []) -> + Helper.CoreCall("Reflection", "memberEquals", Boolean, [left; right], ?loc=r) |> is equal + + | DeclaredFullNameType(_ent, "System.Reflection.ParameterInfo", []) -> + Helper.CoreCall("Reflection", "parameterEquals", Boolean, [left; right], ?loc=r) |> is equal + + | DeclaredFullNameType(_ent, "System.Reflection.FieldInfo", []) -> + Helper.CoreCall("Reflection", "fieldEquals", Boolean, [left; right], ?loc=r) |> is equal + + | DeclaredFullNameType(_ent, "System.Reflection.PropertyInfo", []) -> + Helper.CoreCall("Reflection", "propertyEquals", Boolean, [left; right], ?loc=r) |> is equal + + | DeclaredFullNameType(_ent, "System.Reflection.MethodInfo", []) -> + Helper.CoreCall("Reflection", "methodEquals", Boolean, [left; right], ?loc=r) |> is equal + + | DeclaredFullNameType(_ent, "System.Reflection.ConstructorInfo", []) -> + Helper.CoreCall("Reflection", "constructorEquals", Boolean, [left; right], ?loc=r) |> is equal + + | DeclaredFullNameType(_ent, "Microsoft.FSharp.Reflection.UnionCaseInfo", []) -> + Helper.CoreCall("Reflection", "unionCaseEquals", Boolean, [left; right], ?loc=r) |> is equal + | Tuple _ -> Helper.CoreCall("Util", "equalArrays", Boolean, [left; right], ?loc=r) |> is equal // unsafe optimization, left can sometimes be null @@ -1252,6 +1292,16 @@ let precompiledLib r (t: Type) (i: CallInfo) (thisArg: Expr option) (args: Expr let argInfo = { argInfo thisArg args (Typed i.SignatureArgTypes) with Spread = i.Spread } makeCustomImport Any mangledName importPath |> staticCall r t argInfo +let getPrecompiledLibReflectionName entityName = + let entityName = Naming.sanitizeIdentForbiddenChars entityName + Naming.buildNameWithoutSanitation entityName Naming.ReflectionMemberPart |> Naming.checkJsKeywords + +let precompiledLibReflection r (args: Expr list) (entityName, importPath) = + let mangledName = getPrecompiledLibReflectionName entityName + let argTypes = args |> List.map (fun _ -> MetaType) + let argInfo = { argInfo None args (Typed argTypes) with Spread = Fable.NoSpread } + makeCustomImport Any mangledName importPath |> staticCall r MetaType argInfo + let fsFormat (com: ICompiler) (ctx: Context) r t (i: CallInfo) (thisArg: Expr option) (args: Expr list) = match i.CompiledName, thisArg, args with | "get_Value", Some callee, _ -> @@ -1895,7 +1945,6 @@ let maps (com: ICompiler) (ctx: Context) r (t: Type) (i: CallInfo) (thisArg: Exp let mangledName = Naming.buildNameWithoutSanitationFrom "FSharpMap" isStatic i.CompiledName i.OverloadSuffix.Value let args = injectArg com ctx r "Map" mangledName i.GenericArgs args Helper.CoreCall("Map", mangledName, t, args, i.SignatureArgTypes, ?thisArg=thisArg, ?loc=r) |> Some - let mapModule (com: ICompiler) (ctx: Context) r (t: Type) (i: CallInfo) (_: Expr option) (args: Expr list) = let meth = Naming.lowerFirst i.CompiledName let args = injectArg com ctx r "Map" meth i.GenericArgs args @@ -2653,6 +2702,42 @@ let events (_: ICompiler) (ctx: Context) r (t: Type) (i: CallInfo) (thisArg: Exp | meth, Some x -> Helper.InstanceCall(x, meth, t, args, i.SignatureArgTypes, ?loc=r) |> Some | meth, None -> Helper.CoreCall("Event", Naming.lowerFirst meth, t, args, i.SignatureArgTypes, ?loc=r) |> Some +let exprs (name : string) (_: ICompiler) (ctx: Context) r (t: Type) (i: CallInfo) (thisArg: Expr option) (args: Expr list) = + match i.CompiledName, thisArg, args with + //| meth, Some x,_ -> Helper.InstanceCall(x, meth, t, args, i.SignatureArgTypes, ?loc=r) |> Some + | "Value", None, _ -> + let _,name = getMangledNames { i with OverloadSuffix = lazy ("") } None + match args with + | [a] -> Helper.CoreCall("Quotations", name, t, [a; makeTypeInfo None a.Type], i.SignatureArgTypes, ?loc=r) |> Some + | _ -> Helper.CoreCall("Quotations", name, t, args, i.SignatureArgTypes, ?loc=r) |> Some + | "ValueWithName", None, _ -> + let _,name = getMangledNames { i with OverloadSuffix = lazy ("") } None + match args with + | [a;n] -> Helper.CoreCall("Quotations", name, t, [a; makeTypeInfo None a.Type; n], i.SignatureArgTypes, ?loc=r) |> Some + | _ -> Helper.CoreCall("Quotations", name, t, args, i.SignatureArgTypes, ?loc=r) |> Some + | "WithValue", None, _ -> + let _,name = getMangledNames { i with OverloadSuffix = lazy ("") } None + match args with + | [a;n] -> Helper.CoreCall("Quotations", name, t, [a; makeTypeInfo None a.Type; n], i.SignatureArgTypes, ?loc=r) |> Some + | _ -> Helper.CoreCall("Quotations", name, t, args, i.SignatureArgTypes, ?loc=r) |> Some + + + | meth, Some x,_ -> + let _,name = getMangledNames i (Some x) + Helper.CoreCall("Quotations", name, t, x :: args, i.SignatureArgTypes, ?loc=r) |> Some + + + | meth, None,_ -> + //match t with + // | Fable.Expr _ -> + // let hash = match i.Original with | Some o -> lazy (OverloadSuffix.getExtensionHash o) | _ -> lazy "" + // let _,name = getMangledNames { i with OverloadSuffix = hash } None + // Helper.CoreCall("Quotations", name, t, args, i.SignatureArgTypes, ?loc=r) |> Some + // | _ -> + let _,name = getMangledNames i None + Helper.CoreCall("Quotations", name, t, args, i.SignatureArgTypes, ?loc=r) |> Some + + let observable (_: ICompiler) (ctx: Context) r (t: Type) (i: CallInfo) (_: Expr option) (args: Expr list) = Helper.CoreCall("Observable", Naming.lowerFirst i.CompiledName, t, args, i.SignatureArgTypes, ?loc=r) |> Some @@ -2757,61 +2842,110 @@ let controlExtensions (_: ICompiler) (ctx: Context) (_: SourceLocation option) t let types (com: ICompiler) (ctx: Context) r t (i: CallInfo) (thisArg: Expr option) (args: Expr list) = let returnString r x = StringConstant x |> makeValue r |> Some - let resolved = - // Some optimizations when the type is known at compile time - match thisArg with - | Some(Value(TypeInfo exprType, exprRange) as thisArg) -> - match exprType with - | GenericParam name -> genericTypeInfoError name |> addError com ctx.InlinePath exprRange - | _ -> () - match i.CompiledName with - | "get_FullName" -> getTypeFullName false exprType |> returnString r - | "get_Namespace" -> - let fullname = getTypeFullName false exprType - match fullname.LastIndexOf(".") with - | -1 -> "" |> returnString r - | i -> fullname.Substring(0, i) |> returnString r - | "get_IsArray" -> - match exprType with Array _ -> true | _ -> false - |> BoolConstant |> makeValue r |> Some - | "get_IsEnum" -> - match exprType with - | Enum t -> true | _ -> false - |> BoolConstant |> makeValue r |> Some - | "GetElementType" -> - match exprType with - | Array t -> TypeInfo t |> makeValue r |> Some - | _ -> Null t |> makeValue r |> Some - | "get_IsGenericType" -> - List.isEmpty exprType.Generics |> not |> BoolConstant |> makeValue r |> Some - | "get_GenericTypeArguments" | "GetGenericArguments" -> - let arVals = exprType.Generics |> List.map (makeTypeInfo r) |> ArrayValues - NewArray(arVals, Any) |> makeValue r |> Some - | "GetGenericTypeDefinition" -> - let newGen = exprType.Generics |> List.map (fun _ -> Any) - exprType.ReplaceGenerics(newGen) |> TypeInfo |> makeValue exprRange |> Some - | _ -> None - | _ -> None - match resolved, thisArg with - | Some _, _ -> resolved - | None, Some thisArg -> - match i.CompiledName with - | "GetTypeInfo" -> Some thisArg - | "get_GenericTypeArguments" | "GetGenericArguments" -> - Helper.CoreCall("Reflection", "getGenerics", t, [thisArg], ?loc=r) |> Some - | "MakeGenericType" -> - Helper.CoreCall("Reflection", "makeGenericType", t, thisArg::args, ?loc=r) |> Some - | "get_FullName" | "get_Namespace" - | "get_IsArray" | "GetElementType" - | "get_IsGenericType" | "GetGenericTypeDefinition" - | "get_IsEnum" | "GetEnumUnderlyingType" | "GetEnumValues" | "GetEnumNames" -> - let meth = Naming.removeGetSetPrefix i.CompiledName |> Naming.lowerFirst - Helper.CoreCall("Reflection", meth, t, [thisArg], ?loc=r) |> Some + + // TODO!!! Optimizations when the type is known at compile time (see commented code from master below) + match thisArg, i.CompiledName with + | Some this, "get_IsGenericParameter" -> Helper.InstanceCall(this, "get_IsGenericParameter", t, []) |> Some + | Some this, "get_FullName" -> Helper.InstanceCall(this, "get_FullName", t, []) |> Some + | Some this, "get_Namespace" -> Helper.InstanceCall(this, "get_Namespace", t, []) |> Some + | Some this, "get_IsArray" -> Helper.InstanceCall(this, "get_IsArray", t, []) |> Some + | Some this, "get_IsGenericType" -> Helper.InstanceCall(this, "get_IsGenericType", t, []) |> Some + | Some this, "get_IsGenericTypeDefinition" -> Helper.InstanceCall(this, "get_IsGenericTypeDefinition", t, []) |> Some + | Some this, "get_GenericTypeArguments" -> Helper.InstanceCall(this, "get_GenericTypeArguments", t, []) |> Some + | Some this, "get_DeclaringType" -> Helper.InstanceCall(this, "get_DeclaringType", t, []) |> Some + | Some this, "GetElementType" -> Helper.InstanceCall(this, "GetElementType", t, []) |> Some + | Some this, "GetGenericArguments" -> Helper.InstanceCall(this, "GetGenericArguments", t, []) |> Some + | Some this, "GetGenericTypeDefinition" -> Helper.InstanceCall(this, "GetGenericTypeDefinition", t, []) |> Some + | Some this, "MakeArrayType" -> Helper.InstanceCall(this, "MakeArrayType", t, []) |> Some + | Some this, "GetTypeInfo" -> Some this + + | Some this, "GetProperties" -> Helper.InstanceCall(this, "GetProperties", t, args) |> Some + | Some this, "GetMethods" -> Helper.InstanceCall(this, "GetMethods", t, []) |> Some + | Some this, "GetMembers" -> Helper.InstanceCall(this, "GetMembers", t, args) |> Some + | Some this, "GetFields" -> Helper.InstanceCall(this, "GetFields", t, args) |> Some + | Some this, "GetConstructors" -> Helper.InstanceCall(this, "GetConstructors", t, args) |> Some + + | Some this, "GetProperty" -> Helper.InstanceCall(this, "GetProperty", t, [List.head args]) |> Some + | Some this, "GetMethod" -> + match args with + | [a] when a.Type = Fable.String -> Helper.InstanceCall(this, "GetMethod", t, [a]) |> Some + | [a;b] when a.Type = Fable.String -> Helper.InstanceCall(this, "GetMethod", t, [a; b]) |> Some + | a::_::_::b::_ when a.Type = Fable.String && b.Type = Fable.Array (Fable.MetaType) + -> Helper.InstanceCall(this, "GetMethod", t, [a; b]) |> Some | _ -> None - | None, None -> None + | Some this, "GetField" -> Helper.InstanceCall(this, "GetField", t, [List.head args]) |> Some + + | Some this, "GetConstructor" -> + match args with + | [] -> Helper.InstanceCall(this, "GetConstructor", t, []) |> Some + | [ts] -> Helper.InstanceCall(this, "GetConstructor", t, [ts]) |> Some + | _ -> None + + | Some this, "MakeGenericType" -> Helper.InstanceCall(this, "MakeGenericType", t, args) |> Some + + | Some this, "get_IsEnum" -> Helper.CoreCall("Reflection", "isEnum", t, [this], ?loc=r) |> Some + | Some this, "GetEnumUnderlyingType" -> Helper.CoreCall("Reflection", "getEnumUnderlyingType", t, [this], ?loc=r) |> Some + | Some this, "GetEnumValues" -> Helper.CoreCall("Reflection", "getEnumValues", t, [this], ?loc=r) |> Some + | Some this, "GetEnumNames" -> Helper.CoreCall("Reflection", "getEnumNames", t, [this], ?loc=r) |> Some + + | _ -> None + // let resolved = + // // Some optimizations when the type is known at compile time + // match thisArg with + // | Some(Value(TypeInfo exprType, exprRange) as thisArg) -> + // match exprType with + // | GenericParam name -> genericTypeInfoError name |> addError com ctx.InlinePath exprRange + // | _ -> () + // match i.CompiledName with + // | "get_FullName" -> getTypeFullName false exprType |> returnString r + // | "get_Namespace" -> + // let fullname = getTypeFullName false exprType + // match fullname.LastIndexOf(".") with + // | -1 -> "" |> returnString r + // | i -> fullname.Substring(0, i) |> returnString r + // | "get_IsArray" -> + // match exprType with Array _ -> true | _ -> false + // |> BoolConstant |> makeValue r |> Some + // | "get_IsEnum" -> + // match exprType with + // | Enum t -> true | _ -> false + // |> BoolConstant |> makeValue r |> Some + // | "GetElementType" -> + // match exprType with + // | Array t -> TypeInfo t |> makeValue r |> Some + // | _ -> Null t |> makeValue r |> Some + // | "get_IsGenericType" -> + // List.isEmpty exprType.Generics |> not |> BoolConstant |> makeValue r |> Some + // | "get_GenericTypeArguments" | "GetGenericArguments" -> + // let arVals = exprType.Generics |> List.map (makeTypeInfo r) |> ArrayValues + // NewArray(arVals, Any) |> makeValue r |> Some + // | "GetGenericTypeDefinition" -> + // let newGen = exprType.Generics |> List.map (fun _ -> Any) + // exprType.ReplaceGenerics(newGen) |> TypeInfo |> makeValue exprRange |> Some + // | _ -> None + // | _ -> None + // match resolved, thisArg with + // | Some _, _ -> resolved + // | None, Some thisArg -> + // match i.CompiledName with + // | "GetTypeInfo" -> Some thisArg + // | "get_GenericTypeArguments" | "GetGenericArguments" -> + // Helper.CoreCall("Reflection", "getGenerics", t, [thisArg], ?loc=r) |> Some + // | "MakeGenericType" -> + // Helper.CoreCall("Reflection", "makeGenericType", t, thisArg::args, ?loc=r) |> Some + // | "get_FullName" | "get_Namespace" + // | "get_IsArray" | "GetElementType" + // | "get_IsGenericType" | "GetGenericTypeDefinition" + // | "get_IsEnum" | "GetEnumUnderlyingType" | "GetEnumValues" | "GetEnumNames" -> + // let meth = Naming.removeGetSetPrefix i.CompiledName |> Naming.lowerFirst + // Helper.CoreCall("Reflection", meth, t, [thisArg], ?loc=r) |> Some + // | _ -> None + // | None, None -> None let fsharpType methName (r: SourceLocation option) t (i: CallInfo) (args: Expr list) = match methName with + | "MakeFunctionType" -> + Helper.CoreCall("Reflection", "lambda", t, args, i.SignatureArgTypes, ?loc=r) |> Some | "MakeTupleType" -> Helper.CoreCall("Reflection", "tuple_type", t, args, i.SignatureArgTypes, hasSpread=true, ?loc=r) |> Some // Prevent name clash with FSharpValue.GetRecordFields @@ -2861,6 +2995,11 @@ let tryField returnTyp ownerTyp fieldName = let private replacedModules = dict [ + "Microsoft.FSharp.Quotations.FSharpExpr", exprs "Expr" + "Microsoft.FSharp.Quotations.FSharpVar", exprs "Var" + "Microsoft.FSharp.Quotations.PatternsModule", exprs "Patterns" + "Microsoft.FSharp.Quotations.DerivedPatternsModule", exprs "DerivedPatterns" + "Microsoft.FSharp.Quotations.ExprShapeModule", exprs "ExprShape" "System.Math", operators "Microsoft.FSharp.Core.Operators", operators "Microsoft.FSharp.Core.Operators.Checked", operators @@ -2973,6 +3112,12 @@ let private replacedModules = "System.Reflection.TypeInfo", types ] + +let reflectionMethods = + System.Collections.Generic.HashSet [| + "asdads" + |] + let tryCall (com: ICompiler) (ctx: Context) r t (info: CallInfo) (thisArg: Expr option) (args: Expr list) = match info.DeclaringEntityFullName with | Patterns.DicContains replacedModules replacement -> replacement com ctx r t info thisArg args @@ -2996,22 +3141,74 @@ let tryCall (com: ICompiler) (ctx: Context) r t (info: CallInfo) (thisArg: Expr if isFSharpType then fsharpType methName r t info args else fsharpValue methName r t info args - | "Microsoft.FSharp.Reflection.UnionCaseInfo" + | "System.Reflection.MemberInfo" + | "System.Reflection.MethodBase" + | "System.Reflection.ConstructorInfo" | "System.Reflection.PropertyInfo" - | "System.Reflection.MemberInfo" -> + | "System.Reflection.ParameterInfo" + | "System.Reflection.FieldInfo" + | "Microsoft.FSharp.Reflection.UnionCaseInfo" + | "FSharp.Reflection.UnionCaseInfo" + | "System.Reflection.MethodInfo" -> match thisArg, info.CompiledName with - | Some c, "get_Tag" -> makeStrConst "tag" |> getExpr r t c |> Some - | Some c, "get_PropertyType" -> makeIntConst 1 |> getExpr r t c |> Some - | Some c, "GetFields" -> Helper.CoreCall("Reflection", "getUnionCaseFields", t, [c], ?loc=r) |> Some - | Some c, "GetValue" -> Helper.CoreCall("Reflection", "getValue", t, c::args, ?loc=r) |> Some - | Some c, "get_Name" -> - match c with - | Value(TypeInfo exprType, loc) -> - getTypeName com ctx loc exprType - |> StringConstant |> makeValue r |> Some - | c -> - Helper.CoreCall("Reflection", "name", t, [c], ?loc=r) |> Some - | _ -> None + | Some this, "GetGenericArguments" -> Helper.InstanceCall(this, "GetGenericArguments", t, []) |> Some + | Some this, "GetGenericMethodDefinition" -> Helper.InstanceCall(this, "GetGenericMethodDefinition", t, []) |> Some + | Some this, "get_IsGenericMethod" -> Helper.InstanceCall(this, "get_IsGenericMethod", t, []) |> Some + | Some this, "get_IsGenericMethodDefinition" -> Helper.InstanceCall(this, "get_IsGenericMethodDefinition", t, []) |> Some + | Some this, "MakeGenericMethod" -> Helper.InstanceCall(this, "MakeGenericMethod", t, args) |> Some + | Some c, "GetIndexParameters" -> Helper.InstanceCall(c, "GetIndexParameters", t, args) |> Some + | Some c, "Invoke" -> Helper.InstanceCall(c, "Invoke", t, args) |> Some + | Some c, "get_Name" -> Helper.InstanceCall(c, "get_Name", t, []) |> Some + | Some c, "get_Tag" -> Helper.InstanceCall(c, "get_Tag", t, []) |> Some + | Some c, "get_DeclaringType" -> Helper.InstanceCall(c, "get_DeclaringType", t, []) |> Some + | Some c, "GetCustomAttributes" -> Helper.InstanceCall(c, "GetCustomAttributes", t, args) |> Some + | Some c, "GetParameters" -> Helper.InstanceCall(c, "GetParameters", t, []) |> Some + | Some c, "get_IsStatic" -> Helper.InstanceCall(c, "get_IsStatic", t, []) |> Some + | Some c, "get_ReturnType" -> Helper.InstanceCall(c, "get_ReturnType", t, []) |> Some + | Some c, "get_ReturnParameter" -> Helper.InstanceCall(c, "get_ReturnParameter", t, []) |> Some + | Some c, "GetFields" -> Helper.InstanceCall(c, "GetFields", t, []) |> Some + | Some c, "get_PropertyType" -> Helper.InstanceCall(c, "get_PropertyType", t, []) |> Some + | Some c, "get_FieldType" -> Helper.InstanceCall(c, "get_FieldType", t, []) |> Some + | Some c, "get_ParameterType" -> Helper.InstanceCall(c, "get_ParameterType", t, []) |> Some + | Some c, "get_GetMethod" -> Helper.InstanceCall(c, "get_GetMethod", t, []) |> Some + | Some c, "get_SetMethod" -> Helper.InstanceCall(c, "get_SetMethod", t, []) |> Some + | Some c, "GetGetMethod" -> Helper.InstanceCall(c, "get_GetMethod", t, []) |> Some + | Some c, "GetSetMethod" -> Helper.InstanceCall(c, "get_SetMethod", t, []) |> Some + | Some c, "get_CanRead" -> Helper.InstanceCall(c, "get_CanRead", t, []) |> Some + | Some c, "get_CanWrite" -> Helper.InstanceCall(c, "get_CanWrite", t, [])|> Some + | Some c, "SetValue" -> + match args with + | [a;v] -> Helper.InstanceCall(c, "SetValue", t, [a; v]) |> Some + | [a;v;i] -> Helper.InstanceCall(c, "SetValue", t, [a; v; i]) |> Some + | a::v::_::_::i::_ -> Helper.InstanceCall(c, "SetValue", t, [a; v; i]) |> Some + | _ -> None + | Some c, "GetValue" -> + match args with + | [a] -> Helper.InstanceCall(c, "GetValue", t, [a]) |> Some + | [a;i] -> Helper.InstanceCall(c, "GetValue", t, [a; i]) |> Some + | a::_::_::i::_ -> Helper.InstanceCall(c, "GetValue", t, [a; i]) |> Some + | _ -> None + | _ -> + let isStatic = Option.isNone thisArg + sprintf "UNKNOWN reflection member: { isStatic: %A; name: %A; args: %A }" isStatic info.CompiledName args |> addError com [] None + None + + // | "Microsoft.FSharp.Reflection.UnionCaseInfo" -> + // match thisArg, info.CompiledName with + // | Some c, "GetCustomAttributes" -> Helper.CoreCall("Reflection", "customAttributes", t, [c], ?loc=r) |> Some + // | Some c, "get_IsStatic" -> Helper.CoreCall("Reflection", "isStatic", t, [c], ?loc=r) |> Some + // | Some c, "get_PropertyType" -> makeIntConst 1 |> getExpr r t c |> Some + // | Some c, "get_Tag" -> makeStrConst "tag" |> getExpr r t c |> Some + // | Some c, "GetFields" -> Helper.CoreCall("Reflection", "getUnionCaseFields", t, [c], ?loc=r) |> Some + // | Some c, "GetValue" -> Helper.CoreCall("Reflection", "getValue", t, c::args, ?loc=r) |> Some + // | Some c, "get_Name" -> + // match c with + // | Value(TypeInfo exprType, loc) -> + // getTypeName com ctx loc exprType + // |> StringConstant |> makeValue r |> Some + // | c -> + // Helper.CoreCall("Reflection", "name", t, [c], ?loc=r) |> Some + // | _ -> None | _ when not info.IsInterface -> com.Options.precompiledLib |> Option.bind (fun tryLib -> tryLib info.DeclaringEntityFullName) diff --git a/src/Fable.Transforms/State.fs b/src/Fable.Transforms/State.fs index fded469a62..8fa30ee408 100644 --- a/src/Fable.Transforms/State.fs +++ b/src/Fable.Transforms/State.fs @@ -94,6 +94,13 @@ type Compiler(currentFile, project: Project, options, fableLibraryDir: string) = Range = range FileName = fileName } |> logs.Add + + member __.RemoveLastError() = + let mutable i = logs.Count - 1 + while i >= 0 && logs.[i].Severity <> Severity.Error do + i <- i - 1 + if i >= 0 then logs.RemoveAt i + // TODO: If name includes `$$2` at the end, remove it member __.GetUniqueVar(name) = id <- id + 1 diff --git a/src/Fable.Transforms/Transforms.Util.fs b/src/Fable.Transforms/Transforms.Util.fs index 8e2c7127d4..40b90dcfc0 100644 --- a/src/Fable.Transforms/Transforms.Util.fs +++ b/src/Fable.Transforms/Transforms.Util.fs @@ -505,6 +505,7 @@ module AST = | Boolean -> Types.bool | Char -> Types.char | String -> Types.string + | Expr _ -> "Expr" // TODO: Type info forErasedUnion? | ErasedUnion _ | Any -> Types.object | Number kind -> diff --git a/src/fable-compiler/package.json b/src/fable-compiler/package.json index 7ceec0e949..0bbb57ea3d 100644 --- a/src/fable-compiler/package.json +++ b/src/fable-compiler/package.json @@ -1,6 +1,6 @@ { - "name": "fable-compiler", - "version": "2.10.0", + "name": "fable-compiler-quotations", + "version": "2.3.10", "main": "dist/index.js", "description": "Fable compiler", "keywords": [ diff --git a/src/fable-library/ExprUtils.fs b/src/fable-library/ExprUtils.fs new file mode 100644 index 0000000000..8c3ed7f922 --- /dev/null +++ b/src/fable-library/ExprUtils.fs @@ -0,0 +1,416 @@ +module ExprUtils + +open Microsoft.FSharp.Quotations +open Fable.Core +open Fable.Core.JS +open Fable.Core.JsInterop +open System.Reflection +open FSharp.Collections + +[] +let private createUint8Array(buffer: ArrayBuffer, byteOffset: int, byteLength: int): byte[] = jsNative + +type IValue = + abstract member typ : System.Type + abstract member value : obj + abstract member name : string + +type IVariable = + abstract member typ : System.Type + abstract member name : string + abstract member isMutable : bool + +type ILiteral = + abstract member typ : System.Type + abstract member value : obj + + +type BinaryStream(arr : byte[]) = + let view = Constructors.DataView.Create(arr.buffer, arr?byteOffset, arr?byteLength) + let mutable position = 0 + + member x.Position = position + + member x.ReadOpCode() = + let value = arr.[position] //view.getUint8(float position) + position <- position + 1 + let code = unbox value + if code >= 128uy then + let sl = x.ReadInt32() + let sc = x.ReadInt32() + let el = x.ReadInt32() + let ec = x.ReadInt32() + code - 128uy, Some(sl, sc, el, ec) + else + code, None + + member x.ReadInt32() = + let value = view.getInt32(position, true) + position <- position + 4 + unbox value + + member x.ReadInt32Array() = + let length = x.ReadInt32() + FSharp.Collections.Array.init length (fun _ -> x.ReadInt32()) + + member x.ReadStringArray() = + let length = x.ReadInt32() + FSharp.Collections.Array.init length (fun _ -> x.ReadString()) + + + member x.ReadString() = + let length = x.ReadInt32() + let view = createUint8Array(arr.buffer, arr?byteOffset + position, length) + let value = System.Text.Encoding.UTF8.GetString(unbox view) + position <- position + length + value + + +// 1uy -> Lambda(var, body) +// 2uy -> Var(var) +// 3uy -> Closure(id) +// 4uy -> Let(var, e, b) +[ t[$2]), ((t, v) => { t[$2] = v; }))")>] +let createRecordProperty (decl : System.Type) (name : string) (typ : System.Type) : PropertyInfo = jsNative +[] +let createStaticProperty (decl : System.Type) (name : string) (typ : System.Type) : PropertyInfo = jsNative + + +// declaringType: NTypeInfo, +// genericArguments: NTypeInfo[], +// name: string, +// parameters: NParameterInfo[], +// returnType: NTypeInfo, +// isStatic: boolean, +// private invoke: (...args: any[]) => any, +// attributes: CustomAttribute[], +// private declaration?: NMethodInfo, + +[] +let createMethod (decl : System.Type) (name : string) (mpars : string[]) (margs : System.Type[]) (declaredArgs : System.Type[]) (ret : System.Type) (isStatic : bool) : MethodInfo = jsNative + + + +let deserialize (values : IValue[]) (variables : IVariable[]) (types : System.Type[]) (_members : System.Reflection.MemberInfo[]) (literals : ILiteral[]) (data : string) : Expr = + let arr = System.Convert.FromBase64String(data) + let stream = BinaryStream(unbox arr) + + let values = values |> FSharp.Collections.Array.map (fun v -> Expr.ValueWithName(v.value, v.typ, v.name)) + let variables = variables |> FSharp.Collections.Array.map (fun v -> Var(v.name, v.typ, v.isMutable)) + + let file = stream.ReadString() + + let init (n : int) (f : int -> 'a) = + let rec init (i : int) = + if i >= n then + [] + else + let h = f i + h :: init (i + 1) + init 0 + + + let rec read () = + let tag, range = stream.ReadOpCode() + let inline withRange (e : Expr) = + match range with + | Some(sl, sc, el, ec) -> e.WithRange(file, sl, sc, el, ec) + | None -> e + match tag with + | 1uy -> + let vid = stream.ReadInt32() + let body = read() + Expr.Lambda(variables.[vid], body) |> withRange + | 2uy -> + let vid = stream.ReadInt32() + Expr.Var(variables.[vid]) |> withRange + | 3uy -> + let vid = stream.ReadInt32() + values.[vid] |> withRange + | 4uy -> + let vid = stream.ReadInt32() + let e = read() + let b = read() + Expr.Let(variables.[vid], e, b) |> withRange + + | 5uy -> + let decl = types.[stream.ReadInt32()] + let name = stream.ReadString() + let mpars = stream.ReadStringArray() + let margs = stream.ReadInt32Array() |> FSharp.Collections.Array.map (fun t -> types.[t]) + let dargs = stream.ReadInt32Array() |> FSharp.Collections.Array.map (fun t -> types.[t]) + let ret = types.[stream.ReadInt32()] + let cnt = stream.ReadInt32() + + let target = read() + let args = init cnt (fun _ -> read()) + + let mem = + decl.GetMethods() |> FSharp.Collections.Array.tryFind (fun m -> + m.Name = name && m.GetParameters().Length = cnt && + m.GetGenericArguments().Length = margs.Length && + FSharp.Collections.Array.forall2 (fun (p : ParameterInfo) (a : Expr) -> p.ParameterType = a.Type) + (if m.IsGenericMethod then m.MakeGenericMethod(margs).GetParameters() else m.GetParameters()) + (List.toArray args) + ) + + match mem with + | Some mem -> + let mem = + if margs.Length > 0 then mem.MakeGenericMethod margs + else mem + Expr.Call(target, mem, args) |> withRange + | None -> + let mem = createMethod decl name mpars margs dargs ret false + Expr.Call(target, mem, args) |> withRange + + | 6uy -> + let decl = types.[stream.ReadInt32()] + let name = stream.ReadString() + let mpars = stream.ReadStringArray() + let margs = stream.ReadInt32Array() |> FSharp.Collections.Array.map (fun t -> types.[t]) + let dargs = stream.ReadInt32Array() |> FSharp.Collections.Array.map (fun t -> types.[t]) + let ret = types.[stream.ReadInt32()] + let cnt = stream.ReadInt32() + + let args = init cnt (fun _ -> read()) + + let mem = + decl.GetMethods() |> FSharp.Collections.Array.tryFind (fun m -> + m.Name = name && m.GetParameters().Length = cnt && + m.GetGenericArguments().Length = margs.Length && + FSharp.Collections.Array.forall2 (fun (p : ParameterInfo) (a : Expr) -> p.ParameterType = a.Type) + (if m.IsGenericMethod then m.MakeGenericMethod(margs).GetParameters() else m.GetParameters()) + (List.toArray args) + ) + + match mem with + | Some mem -> + let mem = + if margs.Length > 0 then mem.MakeGenericMethod margs + else mem + Expr.Call(mem, args) |> withRange + | None -> + let mem = createMethod decl name mpars margs dargs ret true + Expr.Call(mem, args) |> withRange + + | 7uy -> + let e = read() + Expr.AddressOf(e) |> withRange + + | 8uy -> + let v = read() + let e = read() + Expr.AddressSet(v, e) |> withRange + + | 9uy -> + let tid = stream.ReadInt32() + let name = stream.ReadString() + let target = read() + //let prop = FSharp.Reflection.FSharpType.GetRecordFields target.Type |> FSharp.Collections.Array.find (fun p -> p.Name = name) + let prop = createRecordProperty target.Type name types.[tid] + Expr.PropertyGet(target, prop) |> withRange + + | 10uy -> + let f = read() + let cnt = stream.ReadInt32() + let args = init cnt (fun _ -> read()) + Expr.Applications(f, List.map List.singleton args) |> withRange + | 11uy -> + let id = stream.ReadInt32() + let l = literals.[id] + Expr.Value(l.value, l.typ) |> withRange + | 12uy -> + let c = read() + let i = read() + let e = read() + Expr.IfThenElse(c, i, e) |> withRange + + | 13uy -> + let typ = types.[stream.ReadInt32()] + let name = stream.ReadString() + let e = read() + let case = FSharp.Reflection.FSharpType.GetUnionCases(e.Type) |> FSharp.Collections.Array.find (fun c -> c.Name = name) + Expr.UnionCaseTest(e, case) |> withRange + + | 14uy -> + let typ = types.[stream.ReadInt32()] + let name = stream.ReadString() + let index = stream.ReadInt32() + let target = read() + let case = FSharp.Reflection.FSharpType.GetUnionCases(typ) |> FSharp.Collections.Array.find (fun c -> c.Name = name) + let prop = case.GetFields().[index] + + Expr.PropertyGet(target, prop) |> withRange + | 15uy -> + let typ = types.[stream.ReadInt32()] + let e = read() + Expr.Coerce(e, typ) |> withRange + + | 16uy -> + let typ = types.[stream.ReadInt32()] + Expr.DefaultValue typ |> withRange + + | 17uy -> + let var = variables.[stream.ReadInt32()] + let s = read() + let e = read() + let b = read() + Expr.ForIntegerRangeLoop(var, s, e, b) |> withRange + + | 18uy -> + let typ = types.[stream.ReadInt32()] + let name = stream.ReadString() + let cidx = stream.ReadInt32() + let idx = init cidx (fun _ -> read()) + let ret = types.[stream.ReadInt32()] + let target = read() + + let prop = typ.GetProperties() |> FSharp.Collections.Array.tryFind (fun p -> p.Name = name && p.PropertyType = ret) + match prop with + | Some prop -> + Expr.PropertyGet(target, prop, idx) |> withRange + | None -> + let prop = createRecordProperty typ name ret + Expr.PropertyGet(target, prop, idx) |> withRange + + | 19uy -> + let typ = types.[stream.ReadInt32()] + let name = stream.ReadString() + let cidx = stream.ReadInt32() + let idx = init cidx (fun _ -> read()) + let ret = types.[stream.ReadInt32()] + + let prop = typ.GetProperties() |> FSharp.Collections.Array.tryFind (fun p -> p.Name = name && p.PropertyType = ret) + match prop with + | Some prop -> + Expr.PropertyGet(prop, idx) |> withRange + | None -> + let prop = createStaticProperty typ name ret + Expr.PropertyGet(prop, idx) |> withRange + + | 20uy -> + let typ = types.[stream.ReadInt32()] + let name = stream.ReadString() + let cidx = stream.ReadInt32() + let idx = init cidx (fun _ -> read()) + let ret = types.[stream.ReadInt32()] + let target = read() + let value = read() + + let prop = typ.GetProperties() |> FSharp.Collections.Array.tryFind (fun p -> p.Name = name && p.PropertyType = ret) + match prop with + | Some prop -> + Expr.PropertySet(target, prop, value, idx) |> withRange + | None -> + let prop = createRecordProperty typ name ret + Expr.PropertySet(target, prop, value, idx) |> withRange + + | 21uy -> + let typ = types.[stream.ReadInt32()] + let name = stream.ReadString() + let cidx = stream.ReadInt32() + let idx = init cidx (fun _ -> read()) + let ret = types.[stream.ReadInt32()] + let value = read() + + let prop = typ.GetProperties() |> FSharp.Collections.Array.tryFind (fun p -> p.Name = name && p.PropertyType = ret) + match prop with + | Some prop -> + Expr.PropertySet(prop, value, idx) |> withRange + | None -> + let prop = createStaticProperty typ name ret + Expr.PropertySet(prop, value, idx) |> withRange + + | 22uy -> + let cnt = stream.ReadInt32() + let bindings = + init cnt (fun _ -> + let v = variables.[stream.ReadInt32()] + let e = read() + v, e + ) + let body = read() + Expr.LetRecursive(bindings, body) |> withRange + + | 24uy -> + let typ = types.[stream.ReadInt32()] + let cnt = stream.ReadInt32() + let args = init cnt (fun _ -> read()) + Expr.NewArray(typ, args) |> withRange + + | 26uy -> + let typ = types.[stream.ReadInt32()] + let argts = stream.ReadInt32Array() |> FSharp.Collections.Array.map (fun t -> types.[t]) + let args = init argts.Length (fun _ -> read()) + + let ctor = + typ.GetConstructors() + |> FSharp.Collections.Array.tryFind (fun ctor -> + ctor.GetParameters().Length = argts.Length && + FSharp.Collections.Array.forall2 (fun (p : ParameterInfo) t -> p.ParameterType = t) (ctor.GetParameters()) argts + ) + + match ctor with + | Some ctor -> + Expr.NewObject(ctor, args) |> withRange + | _ -> + failwith "no ctor found" + + | 27uy -> + let typ = types.[stream.ReadInt32()] + let cnt = stream.ReadInt32() + let args = init cnt (fun _ -> read()) + Expr.NewRecord(typ, args) |> withRange + + | 28uy -> + let cnt = stream.ReadInt32() + let args = init cnt (fun _ -> read()) + Expr.NewTuple(args) |> withRange + + | 29uy -> + let typ = types.[stream.ReadInt32()] + let name = stream.ReadString() + let cnt = stream.ReadInt32() + let args = init cnt (fun _ -> read()) + // TODO: non existing unions + let case = FSharp.Reflection.FSharpType.GetUnionCases(typ) |> FSharp.Collections.Array.find (fun c -> c.Name = name) + Expr.NewUnionCase(case, args) |> withRange + | 30uy -> + let e = read() + Expr.Quote(e) |> withRange + + | 31uy -> + let l = read() + let r = read() + Expr.Sequential(l, r) |> withRange + + | 32uy -> + let i = stream.ReadInt32() + let t = read() + Expr.TupleGet(t, i) |> withRange + + | 33uy -> + let typ = types.[stream.ReadInt32()] + let target = read() + Expr.TypeTest(target, typ) |> withRange + | 36uy -> + let v = variables.[stream.ReadInt32()] + let value = read() + Expr.VarSet(v, value) |> withRange + | 38uy -> + let guard = read() + let body = read() + Expr.WhileLoop(guard, body) |> withRange + + | 127uy -> + let str = stream.ReadString() + match range with + | Some (sl, sc, _el, _ec) -> + failwithf "%s [%d, %d]: unsupported expression: %s" file sl sc str + | None -> + failwithf "%s: unsupported expression: %s" file str + | _ -> + failwithf "invalid expression: %A at %A" tag stream.Position + + read() diff --git a/src/fable-library/Fable.Library.fsproj b/src/fable-library/Fable.Library.fsproj index c1ee14f8fb..246c709239 100644 --- a/src/fable-library/Fable.Library.fsproj +++ b/src/fable-library/Fable.Library.fsproj @@ -1,20 +1,14 @@ - - + netstandard2.0 $(DefineConstants);FABLE_COMPILER $(DefineConstants);FX_NO_BIGINT - - - - @@ -25,9 +19,10 @@ + + - - + \ No newline at end of file diff --git a/src/fable-library/Quotations.fs b/src/fable-library/Quotations.fs new file mode 100644 index 0000000000..be53ddae97 --- /dev/null +++ b/src/fable-library/Quotations.fs @@ -0,0 +1,1234 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Quotations + +open System +open System.IO +open System.Reflection +open System.Collections.Generic +open Microsoft.FSharp +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Reflection +open Microsoft.FSharp.Core.Printf +open Fable.Core +#nowarn "52" // The value has been copied to ensure the original is not mutated by this operation + + +//-------------------------------------------------------------------------- +// RAW quotations - basic data types +//-------------------------------------------------------------------------- + +module Helpers = + let qOneOrMoreRLinear q inp = + let rec queryAcc rvs e = + match q e with + | Some(v, body) -> queryAcc (v::rvs) body + | None -> + match rvs with + | [] -> None + | _ -> Some(List.rev rvs, e) + queryAcc [] inp + + let qOneOrMoreLLinear q inp = + let rec queryAcc e rvs = + match q e with + | Some(body, v) -> queryAcc body (v::rvs) + | None -> + match rvs with + | [] -> None + | _ -> Some(e, rvs) + queryAcc inp [] + + let inline mkRLinear mk (vs, body) = List.foldBack (fun v acc -> mk(v, acc)) vs body + let inline mkLLinear mk (body, vs) = List.fold (fun acc v -> mk(acc, v)) body vs + + + let inline isDelegateType (typ:Type) = + typ.FullName.StartsWith "System.Func" + + let inline getDelegateNargs (ty:Type) = + if ty.FullName.StartsWith "System.Func`" then + let ngen = ty.FullName.Substring(12, ty.FullName.Length - 12) |> int + ngen - 1 + else + 0 + + + let inline checkNonNull argName (v: 'T) = + match box v with + | null -> nullArg argName + | _ -> () + + let inline getTypesFromParamInfos (infos : ParameterInfo[]) = infos |> Array.map (fun pi -> pi.ParameterType) + +open Helpers + + +[] +[] +type Var(name: string, typ:Type, ?isMutable: bool) = + static let globals = new Dictionary<(string*Type), Var>(11) + + let id = System.Guid.NewGuid() + let isMutable = defaultArg isMutable false + + member v.Name = name + member v.IsMutable = isMutable + member v.Type = typ + member x.Stamp = id + + static member Global(name, typ: Type) = + checkNonNull "name" name + checkNonNull "typ" typ + let ok = globals.ContainsKey((name, typ)) //.TryGetValue((name, typ), &res) + if ok then globals.[(name, typ)] else + let res = Var(name, typ) + globals.[(name, typ)] <- res + res + + override v.ToString() = name + + + override x.GetHashCode() = + Unchecked.hash id + + override x.Equals o = + match o with + | :? Var as v -> id = v.Stamp + | _ -> false + + interface System.IComparable with + member v.CompareTo(obj:obj) = + match obj with + | :? Var as v2 -> + if System.Object.ReferenceEquals(v, v2) then 0 else + let c = compare v.Name v2.Name + if c <> 0 then c else + let c = compare v.Type.FullName v2.Type.FullName + if c <> 0 then c else + compare v.Stamp v2.Stamp + | _ -> 0 + +/// Represents specifications of a subset of F# expressions +[] +type Tree = + | CombTerm of ExprConstInfo * Expr list + | VarTerm of Var + | LambdaTerm of Var * Expr + | HoleTerm of Type * int + +and + [] + ExprConstInfo = + | AppOp + | IfThenElseOp + | LetRecOp + | LetRecCombOp + | LetOp + | NewRecordOp of Type + | NewUnionCaseOp of UnionCaseInfo + | UnionCaseTestOp of UnionCaseInfo + | NewTupleOp of Type + | TupleGetOp of Type * int + | InstancePropGetOp of PropertyInfo + | StaticPropGetOp of PropertyInfo + | InstancePropSetOp of PropertyInfo + | StaticPropSetOp of PropertyInfo + | InstanceFieldGetOp of FieldInfo + | StaticFieldGetOp of FieldInfo + | InstanceFieldSetOp of FieldInfo + | StaticFieldSetOp of FieldInfo + | NewObjectOp of ConstructorInfo + | InstanceMethodCallOp of MethodInfo + | StaticMethodCallOp of MethodInfo + | CoerceOp of Type + | NewArrayOp of Type + | NewDelegateOp of Type + | QuoteOp of bool + | SequentialOp + | AddressOfOp + | VarSetOp + | AddressSetOp + | TypeTestOp of Type + | TryWithOp + | TryFinallyOp + | ForIntegerRangeLoopOp + | WhileLoopOp + // Arbitrary spliced values - not serialized + | ValueOp of obj * Type * string option + | WithValueOp of obj * Type + | DefaultValueOp of Type + +and [] + Expr(term:Tree, attribs:Expr list) = + member x.Tree = term + member x.CustomAttributes = attribs + + override x.Equals(obj) = + match obj with + | :? Expr as y -> + let rec eq t1 t2 = + match t1, t2 with + // We special-case ValueOp to ensure that ValueWithName = Value + | CombTerm(ValueOp(v1, ty1, _), []), CombTerm(ValueOp(v2, ty2, _), []) -> (v1 = v2) && (ty1 = ty2) + | CombTerm(c1, es1), CombTerm(c2, es2) -> c1 = c2 && es1.Length = es2.Length && (es1 = es2) + | VarTerm v1, VarTerm v2 -> (v1 = v2) + | LambdaTerm (v1, e1), LambdaTerm(v2, e2) -> (v1 = v2) && (e1 = e2) + | HoleTerm (ty1, n1), HoleTerm(ty2, n2) -> (ty1 = ty2) && (n1 = n2) + | _ -> false + eq x.Tree y.Tree + | _ -> false + member x.GetLayout(long) = + let inline expr (e:Expr ) = e.GetLayout(long) + let inline exprs (es:Expr list) = es |> List.map expr + let inline parens ls = sprintf "(%s)" (String.concat ", " ls) + let inline pairL l1 l2 = sprintf "(%s, %s)" l1 l2 + let inline listL ls = sprintf "[%s]" (String.concat ", " ls) + let inline combTaggedL nm ls = sprintf "%s%s" nm (parens ls) + let inline combL nm ls = sprintf "%s%s" nm (parens ls) + let noneL = "None" + let inline someL e = sprintf "Some(%s)" (expr e) + let inline typeL (o: Type) = if long then o.FullName else o.Name + let inline objL (o: 'T) = sprintf "%A" o + let inline varL (v:Var) = v.Name + let inline (|E|) (e: Expr) = e.Tree + let inline (|Lambda|_|) (E x) = match x with LambdaTerm(a, b) -> Some (a, b) | _ -> None + let inline (|IteratedLambda|_|) (e: Expr) = qOneOrMoreRLinear (|Lambda|_|) e + let inline ucaseL (unionCase:UnionCaseInfo) = (if long then objL unionCase else unionCase.Name) + let inline minfoL (minfo: MethodInfo) = if long then objL minfo else minfo.Name + let inline cinfoL (cinfo: ConstructorInfo) = if long then objL cinfo else cinfo.DeclaringType.Name + let inline pinfoL (pinfo: PropertyInfo) = if long then objL pinfo else pinfo.Name + let inline finfoL (finfo: FieldInfo) = if long then objL finfo else finfo.Name + let rec (|NLambdas|_|) n (e:Expr) = + match e with + | _ when n <= 0 -> Some([], e) + | Lambda(v, NLambdas ((-) n 1) (vs, b)) -> Some(v::vs, b) + | _ -> None + // let combL (name : string) (args : seq) = sprintf "%s(%s)" name (String.concat ", " args) + // let exprs (es : seq) = es |> Seq.map (fun e -> e.GetLayout(long)) + + match x.Tree with + | CombTerm(AppOp, args) -> combL "Application" (exprs args) + | CombTerm(IfThenElseOp, args) -> combL "IfThenElse" (exprs args) + | CombTerm(LetRecOp, [IteratedLambda(vs, E(CombTerm(LetRecCombOp, b2::bs)))]) -> combL "LetRecursive" [listL (List.map2 pairL (List.map varL vs) (exprs bs) ); b2.GetLayout(long)] + | CombTerm(LetOp, [e;E(LambdaTerm(v, b))]) -> combL "Let" [varL v; e.GetLayout(long); b.GetLayout(long)] + | CombTerm(NewRecordOp(ty), args) -> combL "NewRecord" (typeL ty :: exprs args) + | CombTerm(NewUnionCaseOp(unionCase), args) -> combL "NewUnionCase" (ucaseL unionCase :: exprs args) + | CombTerm(UnionCaseTestOp(unionCase), args) -> combL "UnionCaseTest" (exprs args@ [ucaseL unionCase]) + | CombTerm(NewTupleOp _, args) -> combL "NewTuple" (exprs args) + | CombTerm(TupleGetOp (_, i), [arg]) -> combL "TupleGet" ([expr arg] @ [objL i]) + | CombTerm(ValueOp(v, _, Some nm), []) -> combL "ValueWithName" [objL v; nm] + | CombTerm(ValueOp(v, _, None), []) -> combL "Value" [objL v] + | CombTerm(WithValueOp(v, _), [defn]) -> combL "WithValue" [objL v; expr defn] + | CombTerm(InstanceMethodCallOp(minfo), obj::args) -> combL "Call" [someL obj; minfoL minfo; listL (exprs args)] + | CombTerm(StaticMethodCallOp(minfo), args) -> combL "Call" [noneL; minfoL minfo; listL (exprs args)] + | CombTerm(InstancePropGetOp(pinfo), (obj::args)) -> combL "PropertyGet" [someL obj; pinfoL pinfo; listL (exprs args)] + | CombTerm(StaticPropGetOp(pinfo), args) -> combL "PropertyGet" [noneL; pinfoL pinfo; listL (exprs args)] + | CombTerm(InstancePropSetOp(pinfo), (obj::args)) -> combL "PropertySet" [someL obj; pinfoL pinfo; listL (exprs args)] + | CombTerm(StaticPropSetOp(pinfo), args) -> combL "PropertySet" [noneL; pinfoL pinfo; listL (exprs args)] + | CombTerm(InstanceFieldGetOp(finfo), [obj]) -> combL "FieldGet" [someL obj; finfoL finfo] + | CombTerm(StaticFieldGetOp(finfo), []) -> combL "FieldGet" [noneL; finfoL finfo] + | CombTerm(InstanceFieldSetOp(finfo), [obj;v]) -> combL "FieldSet" [someL obj; finfoL finfo; expr v;] + | CombTerm(StaticFieldSetOp(finfo), [v]) -> combL "FieldSet" [noneL; finfoL finfo; expr v;] + | CombTerm(CoerceOp(ty), [arg]) -> combL "Coerce" [ expr arg; typeL ty] + | CombTerm(NewObjectOp cinfo, args) -> combL "NewObject" ([ cinfoL cinfo ] @ exprs args) + | CombTerm(DefaultValueOp(ty), args) -> combL "DefaultValue" ([ typeL ty ] @ exprs args) + | CombTerm(NewArrayOp(ty), args) -> combL "NewArray" ([ typeL ty ] @ exprs args) + | CombTerm(TypeTestOp(ty), args) -> combL "TypeTest" ([ typeL ty] @ exprs args) + | CombTerm(AddressOfOp, args) -> combL "AddressOf" (exprs args) + | CombTerm(VarSetOp, [E(VarTerm(v)); e]) -> combL "VarSet" [varL v; expr e] + | CombTerm(AddressSetOp, args) -> combL "AddressSet" (exprs args) + | CombTerm(ForIntegerRangeLoopOp, [e1;e2;E(LambdaTerm(v, e3))]) -> combL "ForIntegerRangeLoop" [varL v; expr e1; expr e2; expr e3] + | CombTerm(WhileLoopOp, args) -> combL "WhileLoop" (exprs args) + | CombTerm(TryFinallyOp, args) -> combL "TryFinally" (exprs args) + | CombTerm(TryWithOp, [e1;Lambda(v1, e2);Lambda(v2, e3)]) -> combL "TryWith" [expr e1; varL v1; expr e2; varL v2; expr e3] + | CombTerm(SequentialOp, args) -> combL "Sequential" (exprs args) + | CombTerm(NewDelegateOp(ty), [e]) -> + let nargs = getDelegateNargs ty + if nargs = 0 then + match e with + | NLambdas 1 ([_], e) -> combL "NewDelegate" ([typeL ty] @ [expr e]) + | NLambdas 0 ([], e) -> combL "NewDelegate" ([typeL ty] @ [expr e]) + | _ -> combL "NewDelegate" [typeL ty; expr e] + else + match e with + | NLambdas nargs (vs, e) -> combL "NewDelegate" ([typeL ty] @ (vs |> List.map varL) @ [expr e]) + | _ -> combL "NewDelegate" [typeL ty; expr e] + //| CombTerm(_, args) -> combL "??" (exprs args) + | VarTerm(v) -> v.Name + | LambdaTerm(v, b) -> combL "Lambda" [varL v; expr b] + | HoleTerm _ -> "_" + | CombTerm(QuoteOp _, args) -> combL "Quote" (exprs args) + | _ -> failwithf "Unexpected term in layout %A" x.Tree + override x.GetHashCode() = + x.Tree.GetHashCode() + + override x.ToString() = + x.ToString(false) + + member x.ToString(full) = + x.GetLayout(full) + + + +and [] + Expr<'T>(term:Tree, attribs) = + inherit Expr(term, attribs) + member x.Raw = (x :> Expr) + +[] +module Patterns = + + + type ByteStream(bytes:byte[], initial:int, len:int) = + + let mutable pos = initial + let lim = initial + len + + member b.ReadByte() = + if pos >= lim then failwith "end of stream" + let res = int32 bytes.[pos] + pos <- pos + 1 + res + + member b.ReadBytes n = + if pos + n > lim then failwith "ByteStream.ReadBytes: end of stream" + let res = bytes.[pos..pos+n-1] + pos <- pos + n + res + + member b.ReadUtf8BytesAsString n = + let res = System.Text.Encoding.UTF8.GetString(bytes, pos, n) + pos <- pos + n + res + + + let E t = new Expr< >(t, []) + let EA (t, attribs) = new Expr< >(t, attribs) + let ES ts = List.map E ts + + let (|E|) (e: Expr) = e.Tree + let (|ES|) (es: list) = es |> List.map (fun e -> e.Tree) + let (|FrontAndBack|_|) es = + let rec loop acc xs = match xs with [] -> None | [h] -> Some (List.rev acc, h) | h::t -> loop (h::acc) t + loop [] es + + + + let funTyC = typeof<(obj -> obj)>.GetGenericTypeDefinition() + let exprTyC = typedefof> + let voidTy = typeof + let unitTy = typeof + let removeVoid a = if a = voidTy then unitTy else a + let addVoid a = if a = unitTy then voidTy else a + let inline mkFunTy a b = + let (a, b) = removeVoid a, removeVoid b + funTyC.MakeGenericType([| a;b |]) + + let inline mkArrayTy (t:Type) = t.MakeArrayType() + let inline mkExprTy (t:Type) = exprTyC.MakeGenericType([| t |]) + let rawExprTy = typeof + + + //-------------------------------------------------------------------------- + // Active patterns for decomposing quotations + //-------------------------------------------------------------------------- + + let (|Comb0|_|) (E x) = match x with CombTerm(k, []) -> Some(k) | _ -> None + + let (|Comb1|_|) (E x) = match x with CombTerm(k, [x]) -> Some(k, x) | _ -> None + + let (|Comb2|_|) (E x) = match x with CombTerm(k, [x1;x2]) -> Some(k, x1, x2) | _ -> None + + let (|Comb3|_|) (E x) = match x with CombTerm(k, [x1;x2;x3]) -> Some(k, x1, x2, x3) | _ -> None + + [] + let (|Var|_|) (E x) = match x with VarTerm v -> Some v | _ -> None + + [] + let (|Application|_|) input = match input with Comb2(AppOp, a, b) -> Some (a, b) | _ -> None + + [] + let (|Lambda|_|) (E x) = match x with LambdaTerm(a, b) -> Some (a, b) | _ -> None + + [] + let (|Quote|_|) (E x) = match x with CombTerm(QuoteOp _, [a]) -> Some (a) | _ -> None + + [] + let (|QuoteRaw|_|) (E x) = match x with CombTerm(QuoteOp false, [a]) -> Some (a) | _ -> None + + [] + let (|QuoteTyped|_|) (E x) = match x with CombTerm(QuoteOp true, [a]) -> Some (a) | _ -> None + + [] + let (|IfThenElse|_|) input = match input with Comb3(IfThenElseOp, e1, e2, e3) -> Some(e1, e2, e3) | _ -> None + + [] + let (|NewTuple|_|) input = match input with E(CombTerm(NewTupleOp(_), es)) -> Some(es) | _ -> None + + [] + let (|DefaultValue|_|) input = match input with E(CombTerm(DefaultValueOp(ty), [])) -> Some(ty) | _ -> None + + [] + let (|NewRecord|_|) input = match input with E(CombTerm(NewRecordOp(x), es)) -> Some(x, es) | _ -> None + + [] + let (|NewUnionCase|_|) input = match input with E(CombTerm(NewUnionCaseOp(unionCase), es)) -> Some(unionCase, es) | _ -> None + + [] + let (|UnionCaseTest|_|) input = match input with Comb1(UnionCaseTestOp(unionCase), e) -> Some(e, unionCase) | _ -> None + + [] + let (|TupleGet|_|) input = match input with Comb1(TupleGetOp(_, n), e) -> Some(e, n) | _ -> None + + [] + let (|Coerce|_|) input = match input with Comb1(CoerceOp ty, e1) -> Some(e1, ty) | _ -> None + + [] + let (|TypeTest|_|) input = match input with Comb1(TypeTestOp ty, e1) -> Some(e1, ty) | _ -> None + + [] + let (|NewArray|_|) input = match input with E(CombTerm(NewArrayOp ty, es)) -> Some(ty, es) | _ -> None + + [] + let (|AddressSet|_|) input = match input with E(CombTerm(AddressSetOp, [e;v])) -> Some(e, v) | _ -> None + + [] + let (|TryFinally|_|) input = match input with E(CombTerm(TryFinallyOp, [e1;e2])) -> Some(e1, e2) | _ -> None + + [] + let (|TryWith|_|) input = match input with E(CombTerm(TryWithOp, [e1;Lambda(v1, e2);Lambda(v2, e3)])) -> Some(e1, v1, e2, v2, e3) | _ -> None + + [] + let (|VarSet|_| ) input = match input with E(CombTerm(VarSetOp, [E(VarTerm(v)); e])) -> Some(v, e) | _ -> None + + [] + let (|Value|_|) input = match input with E(CombTerm(ValueOp (v, ty, _), _)) -> Some(v, ty) | _ -> None + + [] + let (|ValueObj|_|) input = match input with E(CombTerm(ValueOp (v, _, _), _)) -> Some(v) | _ -> None + + [] + let (|ValueWithName|_|) input = + match input with + | E(CombTerm(ValueOp (v, ty, Some nm), _)) -> Some(v, ty, nm) + | _ -> None + + [] + let (|WithValue|_|) input = + match input with + | E(CombTerm(WithValueOp (v, ty), [e])) -> Some(v, ty, e) + | _ -> None + + [] + let (|AddressOf|_|) input = + match input with + | Comb1(AddressOfOp, e) -> Some(e) + | _ -> None + + [] + let (|Sequential|_|) input = + match input with + | Comb2(SequentialOp, e1, e2) -> Some(e1, e2) + | _ -> None + + [] + let (|ForIntegerRangeLoop|_|) input = + match input with + | Comb3(ForIntegerRangeLoopOp, e1, e2, Lambda(v, e3)) -> Some(v, e1, e2, e3) + | _ -> None + + [] + let (|WhileLoop|_|) input = + match input with + | Comb2(WhileLoopOp, e1, e2) -> Some(e1, e2) + | _ -> None + + [] + let (|PropertyGet|_|) input = + match input with + | E(CombTerm(StaticPropGetOp pinfo, args)) -> Some(None, pinfo, args) + | E(CombTerm(InstancePropGetOp pinfo, obj::args)) -> Some(Some(obj), pinfo, args) + | _ -> None + + [] + let (|PropertySet|_|) input = + match input with + | E(CombTerm(StaticPropSetOp pinfo, FrontAndBack(args, v))) -> Some(None, pinfo, args, v) + | E(CombTerm(InstancePropSetOp pinfo, obj::FrontAndBack(args, v))) -> Some(Some(obj), pinfo, args, v) + | _ -> None + + + [] + let (|FieldGet|_|) input = + match input with + | E(CombTerm(StaticFieldGetOp finfo, [])) -> Some(None, finfo) + | E(CombTerm(InstanceFieldGetOp finfo, [obj])) -> Some(Some(obj), finfo) + | _ -> None + + [] + let (|FieldSet|_|) input = + match input with + | E(CombTerm(StaticFieldSetOp finfo, [v])) -> Some(None, finfo, v) + | E(CombTerm(InstanceFieldSetOp finfo, [obj;v])) -> Some(Some(obj), finfo, v) + | _ -> None + + [] + let (|NewObject|_|) input = + match input with + | E(CombTerm(NewObjectOp ty, e)) -> Some(ty, e) | _ -> None + + [] + let (|Call|_|) input = + match input with + | E(CombTerm(StaticMethodCallOp minfo, args)) -> Some(None, minfo, args) + | E(CombTerm(InstanceMethodCallOp minfo, (obj::args))) -> Some(Some(obj), minfo, args) + | _ -> None + + let (|LetRaw|_|) input = + match input with + | Comb2(LetOp, e1, e2) -> Some(e1, e2) + | _ -> None + + let (|LetRecRaw|_|) input = + match input with + | Comb1(LetRecOp, e1) -> Some(e1) + | _ -> None + + [] + let (|Let|_|)input = + match input with + | LetRaw(e, Lambda(v, body)) -> Some(v, e, body) + | _ -> None + + let (|IteratedLambda|_|) (e: Expr) = qOneOrMoreRLinear (|Lambda|_|) e + + let rec (|NLambdas|_|) n (e:Expr) = + match e with + | _ when n <= 0 -> Some([], e) + | Lambda(v, NLambdas ((-) n 1) (vs, b)) -> Some(v::vs, b) + | _ -> None + + [] + let (|NewDelegate|_|) input = + match input with + | Comb1(NewDelegateOp(ty), e) -> + let nargs = getDelegateNargs ty + if nargs = 0 then + match e with + | NLambdas 1 ([_], e) -> Some(ty, [], e) // try to strip the unit parameter if there is one + | NLambdas 0 ([], e) -> Some(ty, [], e) + | _ -> None + else + match e with + | NLambdas nargs (vs, e) -> Some(ty, vs, e) + | _ -> None + | _ -> None + + [] + let (|LetRecursive|_|) input = + match input with + | LetRecRaw(IteratedLambda(vs1, E(CombTerm(LetRecCombOp, body::es)))) -> Some(List.zip vs1 es, body) + | _ -> None + + //-------------------------------------------------------------------------- + // Getting the type of Raw quotations + //-------------------------------------------------------------------------- + + // Returns record member specified by name + let getRecordProperty(ty, fieldName) = + let mems = FSharpType.GetRecordFields(ty) + match mems |> Array.tryFind (fun minfo -> minfo.Name = fieldName) with + | Some (m) -> m + | _ -> invalidArg "fieldName" (sprintf "missing record field for type %s %s" ty.FullName fieldName) + + let getUnionCaseInfo(ty, unionCaseName) = + let cases = FSharpType.GetUnionCases(ty) + match cases |> Array.tryFind (fun ucase -> ucase.Name = unionCaseName) with + | Some(case) -> case + | _ -> invalidArg "unionCaseName" (sprintf "missing union-case for %s: %s" ty.FullName unionCaseName) + + let getUnionCaseInfoField(unionCase:UnionCaseInfo, index) = + let fields = unionCase.GetFields() + if index < 0 || index >= fields.Length then invalidArg "index" (sprintf "invalid union-case-field index for %s: %d" unionCase.Name index) + fields.[index] + + /// Returns type of lambda application - something like "(fun a -> ..) b" + let rec typeOfAppliedLambda f = + let fty = ((exprType f):Type) + match fty.GetGenericArguments() with + | [| _; b|] -> b + | _ -> raise <| System.InvalidOperationException "(SR.GetString(SR.QillFormedAppOrLet))" + + /// Returns type of the Raw quotation or fails if the quotation is ill formed + /// if 'verify' is true, verifies all branches, otherwise ignores some of them when not needed + and exprType (e : Expr) : Type = + let res = + let (E t) = e + match t with + | VarTerm v -> v.Type + | LambdaTerm (v, b) -> mkFunTy v.Type (exprType b) + | HoleTerm (ty, _) -> ty + | CombTerm (c, args) -> + match c, args with + | AppOp, [f;_] -> typeOfAppliedLambda f + | LetOp, _ -> match e with Let(_, _, b) -> exprType b | _ -> failwith "unreachable" + | IfThenElseOp, [_;t;_] -> exprType t + | LetRecOp, _ -> match e with LetRecursive(_, b) -> exprType b | _ -> failwith "unreachable" + | LetRecCombOp, _ -> failwith "typeOfConst: LetRecCombOp" + | NewRecordOp ty, _ -> ty + | NewUnionCaseOp unionCase, _ -> unionCase.DeclaringType + | UnionCaseTestOp _, _ -> typeof + | ValueOp (_, ty, _), _ -> ty + | WithValueOp (_, ty), _ -> ty + | TupleGetOp (ty, i), _ -> FSharpType.GetTupleElements(ty).[i] + | NewTupleOp ty, _ -> ty + | StaticPropGetOp prop, _ -> prop.PropertyType + | InstancePropGetOp prop, _ -> prop.PropertyType + | StaticPropSetOp _, _ -> typeof + | InstancePropSetOp _, _ -> typeof + | InstanceFieldGetOp fld, _ -> fld.FieldType + | StaticFieldGetOp fld, _ -> fld.FieldType + | InstanceFieldSetOp _, _ -> typeof + | StaticFieldSetOp _, _ -> typeof + | NewObjectOp ctor, _ -> ctor.DeclaringType + | InstanceMethodCallOp minfo, _ -> minfo.ReturnType + | StaticMethodCallOp minfo, _ -> minfo.ReturnType + | CoerceOp ty, _ -> ty + | SequentialOp, [_;b] -> exprType b + | ForIntegerRangeLoopOp, _ -> typeof + | NewArrayOp ty, _ -> mkArrayTy ty + | NewDelegateOp ty, _ -> ty + | DefaultValueOp ty, _ -> ty + | TypeTestOp _, _ -> typeof + | QuoteOp true, [expr] -> mkExprTy (exprType expr) + | QuoteOp false, [_] -> rawExprTy + | TryFinallyOp, [e1;_] -> exprType e1 + | TryWithOp, [e1;_;_] -> exprType e1 + | WhileLoopOp, _ + | VarSetOp, _ + | AddressSetOp, _ -> typeof + | AddressOfOp, [expr]-> failwith "(typeOf expr).MakeByRefType()" + | (AddressOfOp | QuoteOp _ | SequentialOp | TryWithOp | TryFinallyOp | IfThenElseOp | AppOp), _ -> failwith "unreachable" + if unbox res then + res + else + failwithf "bad type for: %A" e + + //-------------------------------------------------------------------------- + // Constructors for building Raw quotations + //-------------------------------------------------------------------------- + + let inline mkFEN op l = E(CombTerm(op, l)) + let inline mkFE0 op = E(CombTerm(op, [])) + let inline mkFE1 op x = E(CombTerm(op, [(x:>Expr)])) + let inline mkFE2 op (x, y) = E(CombTerm(op, [(x:>Expr);(y:>Expr)])) + let inline mkFE3 op (x, y, z) = E(CombTerm(op, [(x:>Expr);(y:>Expr);(z:>Expr)]) ) + let inline mkOp v () = v + + // [Correct by definition] + let inline mkVar v = E(VarTerm v ) + let inline mkQuote(a, isTyped) = E(CombTerm(QuoteOp isTyped, [(a:>Expr)] )) + + let inline mkValue (v, ty) = mkFE0 (ValueOp(v, ty, None)) + let inline mkValueWithName (v, ty, nm) = mkFE0 (ValueOp(v, ty, Some nm)) + let inline mkValueWithDefn (v, ty, defn) = mkFE1 (WithValueOp(v, ty)) defn + let inline mkValueG (v:'T) = mkValue(box v, typeof<'T>) + let inline mkLiftedValueOpG (v, ty: System.Type) = + //let obj = if ty.IsEnum then System.Enum.ToObject(ty, box v) else box v + ValueOp(box v, ty, None) + let inline mkUnit () = mkValue(null, typeof) + let inline mkAddressOf v = mkFE1 AddressOfOp v + let inline mkSequential (e1, e2) = mkFE2 SequentialOp (e1, e2) + let inline mkTypeTest (e, ty) = mkFE1 (TypeTestOp(ty)) e + let inline mkVarSet (v, e) = mkFE2 VarSetOp (mkVar(v), e) + let inline mkAddressSet (e1, e2) = mkFE2 AddressSetOp (e1, e2) + let inline mkLambda(var, body) = E(LambdaTerm(var, (body:>Expr))) + let inline mkTryWith(e1, v1, e2, v2, e3) = mkFE3 TryWithOp (e1, mkLambda(v1, e2), mkLambda(v2, e3)) + let inline mkTryFinally(e1, e2) = mkFE2 TryFinallyOp (e1, e2) + + let inline mkCoerce (ty, x) = mkFE1 (CoerceOp ty) x + let inline mkNull (ty) = mkFE0 (ValueOp(null, ty, None)) + + let inline mkApplication v = mkFE2 AppOp v + + let inline mkLetRaw v = + mkFE2 LetOp v + + let inline mkLetRawWithCheck v = + mkLetRaw v + + // Tuples + let inline mkNewTupleWithType (ty, args:Expr list) = + let mems = FSharpType.GetTupleElements ty + if (args.Length <> mems.Length) then invalidArg "args" ("SR.GetString(SR.QtupleLengthsDiffer)") + mkFEN (NewTupleOp ty) args + + let inline mkNewTuple (args) = + let ty = FSharpType.MakeTupleType(Array.map exprType (Array.ofList args)) + mkFEN (NewTupleOp ty) args + + let inline mkTupleGet (ty, n, x) = + let mems = FSharpType.GetTupleElements ty + if (n < 0 || mems.Length <= n) then invalidArg "n" ("SR.GetString(SR.QtupleAccessOutOfRange)") + mkFE1 (TupleGetOp (ty, n)) x + + // Records + let inline mkNewRecord (ty, args:list) = + let mems = FSharpType.GetRecordFields(ty) + if (args.Length <> mems.Length) then invalidArg "args" ("SR.GetString(SR.QincompatibleRecordLength)") + mkFEN (NewRecordOp ty) args + + + // Discriminated unions + let inline mkNewUnionCase (unionCase:UnionCaseInfo, args:list) = + if Unchecked.defaultof = unionCase then raise (ArgumentNullException()) + let sargs = unionCase.GetFields() + if (args.Length <> sargs.Length) then invalidArg "args" ("SR.GetString(SR.QunionNeedsDiffNumArgs)") + mkFEN (NewUnionCaseOp unionCase) args + + let inline mkUnionCaseTest (unionCase:UnionCaseInfo, expr) = + if Unchecked.defaultof = unionCase then raise (ArgumentNullException()) + mkFE1 (UnionCaseTestOp unionCase) expr + + // Conditional etc.. + let inline mkIfThenElse (e, t, f) = + mkFE3 IfThenElseOp (e, t, f) + + let inline mkNewArray (ty, args) = + mkFEN (NewArrayOp ty) args + + let inline mkInstanceFieldGet(obj, finfo:FieldInfo) = + if Unchecked.defaultof = finfo then raise (ArgumentNullException()) + match finfo.IsStatic with + | false -> + mkFE1 (InstanceFieldGetOp finfo) obj + | true -> invalidArg "finfo" ("SR.GetString(SR.QstaticWithReceiverObject)") + + let inline mkStaticFieldGet (finfo:FieldInfo) = + if Unchecked.defaultof = finfo then raise (ArgumentNullException()) + match finfo.IsStatic with + | true -> mkFE0 (StaticFieldGetOp finfo) + | false -> invalidArg "finfo" ("SR.GetString(SR.QnonStaticNoReceiverObject)") + + let inline mkStaticFieldSet (finfo:FieldInfo, value:Expr) = + if Unchecked.defaultof = finfo then raise (ArgumentNullException()) + //checkTypesSR (exprType value) finfo.FieldType "value" ("SR.GetString(SR.QtmmBadFieldType)") + match finfo.IsStatic with + | true -> mkFE1 (StaticFieldSetOp finfo) value + | false -> invalidArg "finfo" ("SR.GetString(SR.QnonStaticNoReceiverObject)") + + let inline mkInstanceFieldSet (obj, finfo:FieldInfo, value:Expr) = + if Unchecked.defaultof = finfo then raise (ArgumentNullException()) + //checkTypesSR (exprType value) finfo.FieldType "value" ("SR.GetString(SR.QtmmBadFieldType)") + match finfo.IsStatic with + | false -> + mkFE2 (InstanceFieldSetOp finfo) (obj, value) + | true -> invalidArg "finfo" ("SR.GetString(SR.QstaticWithReceiverObject)") + + let inline mkCtorCall (ci:ConstructorInfo, args:list) = + if Unchecked.defaultof = ci then raise (ArgumentNullException()) + mkFEN (NewObjectOp ci) args + + let inline mkDefaultValue (ty:Type) = + mkFE0 (DefaultValueOp ty) + + let inline mkStaticPropGet (pinfo:PropertyInfo, args:list) = + if Unchecked.defaultof = pinfo then raise (ArgumentNullException()) + mkFEN (StaticPropGetOp pinfo) args + // if (not pinfo.CanRead) then invalidArg "pinfo" ("SR.GetString(SR.QreadingSetOnly)") + // checkArgs (pinfo.GetIndexParameters()) args + // match pinfo.GetGetMethod(true).IsStatic with + // | true -> mkFEN (StaticPropGetOp pinfo) args + // | false -> invalidArg "pinfo" ("SR.GetString(SR.QnonStaticNoReceiverObject)") + + let inline mkInstancePropGet (obj, pinfo:PropertyInfo, args:list) = + if Unchecked.defaultof = pinfo then raise (ArgumentNullException()) + mkFEN (InstancePropGetOp pinfo) (obj::args) + // if (not pinfo.CanRead) then invalidArg "pinfo" ("SR.GetString(SR.QreadingSetOnly)") + // checkArgs (pinfo.GetIndexParameters()) args + // match pinfo.GetGetMethod(true).IsStatic with + // | false -> + // checkObj pinfo obj + // mkFEN (InstancePropGetOp pinfo) (obj::args) + // | true -> invalidArg "pinfo" ("SR.GetString(SR.QstaticWithReceiverObject)") + + let inline mkStaticPropSet (pinfo:PropertyInfo, args:list, value:Expr) = + if Unchecked.defaultof = pinfo then raise (ArgumentNullException()) + mkFEN (StaticPropSetOp pinfo) (args@[value]) + // if (not pinfo.CanWrite) then invalidArg "pinfo" ("SR.GetString(SR.QwritingGetOnly)") + // checkArgs (pinfo.GetIndexParameters()) args + // match pinfo.GetSetMethod(true).IsStatic with + // | true -> mkFEN (StaticPropSetOp pinfo) (args@[value]) + // | false -> invalidArg "pinfo" ("SR.GetString(SR.QnonStaticNoReceiverObject)") + + let inline mkInstancePropSet (obj, pinfo:PropertyInfo, args:list, value:Expr) = + if Unchecked.defaultof = pinfo then raise (ArgumentNullException()) + mkFEN (InstancePropSetOp pinfo) (obj::(args@[value])) + // if (not pinfo.CanWrite) then invalidArg "pinfo" ("SR.GetString(SR.QwritingGetOnly)") + // checkArgs (pinfo.GetIndexParameters()) args + // match pinfo.GetSetMethod(true).IsStatic with + // | false -> + // checkObj pinfo obj + // mkFEN (InstancePropSetOp pinfo) (obj::(args@[value])) + // | true -> invalidArg "pinfo" ("SR.GetString(SR.QstaticWithReceiverObject)") + + let inline mkInstanceMethodCall (obj, minfo:MethodInfo, args:list) = + if Unchecked.defaultof = minfo then raise (ArgumentNullException()) + match minfo.IsStatic with + | false -> mkFEN (InstanceMethodCallOp minfo) (obj::args) + | true -> invalidArg "minfo" ("SR.GetString(SR.QstaticWithReceiverObject)") + + let inline mkStaticMethodCall (minfo:MethodInfo, args:list) = + if Unchecked.defaultof = minfo then raise (ArgumentNullException()) + match minfo.IsStatic with + | true -> mkFEN (StaticMethodCallOp minfo) args + | false -> invalidArg "minfo" ("SR.GetString(SR.QnonStaticNoReceiverObject)") + + let inline mkForLoop (v:Var, lowerBound, upperBound, body) = + mkFE3 ForIntegerRangeLoopOp (lowerBound, upperBound, mkLambda(v, body)) + + let inline mkWhileLoop (guard, body) = + mkFE2 (WhileLoopOp) (guard, body) + + let inline mkNewDelegate (ty, e) = + mkFE1 (NewDelegateOp ty) e + + let inline mkLet (v, e, b) = + mkLetRaw (e, mkLambda(v, b)) + + //let inline mkLambdas(vs, b) = mkRLinear mkLambdaRaw (vs, (b:>Expr)) + let inline mkTupledApplication (f, args) = + match args with + | [] -> mkApplication (f, mkUnit()) + | [x] -> mkApplication (f, x) + | _ -> mkApplication (f, mkNewTuple args) + + let inline mkApplications(f: Expr, es:list>) = mkLLinear mkTupledApplication (f, es) + + let inline mkIteratedLambdas(vs, b) = mkRLinear mkLambda (vs, b) + + let inline mkLetRecRaw v = mkFE1 LetRecOp v + let inline mkLetRecCombRaw v = mkFEN LetRecCombOp v + let inline mkLetRec (ves:(Var*Expr) list, body) = + let vs, es = List.unzip ves + mkLetRecRaw(mkIteratedLambdas (vs, mkLetRecCombRaw (body::es))) + + //-------------------------------------------------------------------------- + // General utilities that will eventually be folded into + // Microsoft.FSharp.Quotations.Typed + //-------------------------------------------------------------------------- + + let rec freeInExprAcc bvs acc (E t) = + match t with + | HoleTerm _ -> acc + | CombTerm (_, ag) -> ag |> List.fold (freeInExprAcc bvs) acc + | VarTerm v -> if Set.contains v bvs || Set.contains v acc then acc else Set.add v acc + | LambdaTerm (v, b) -> freeInExprAcc (Set.add v bvs) acc b + and freeInExpr e = freeInExprAcc Set.empty Set.empty e + + + [] + exception Clash of Var + + /// Replace type variables and expression variables with parameters using the + /// given substitution functions/maps. + let rec substituteInExpr bvs tmsubst (E t as e) = + match t with + | CombTerm (c, args) -> + let substargs = args |> List.map (fun arg -> substituteInExpr bvs tmsubst arg) + EA(CombTerm(c, substargs), e.CustomAttributes) + | VarTerm v -> + match tmsubst v with + | None -> e + | Some e2 -> + let fvs = freeInExpr e2 + let clashes = Set.intersect fvs bvs in + if clashes.IsEmpty then e2 + else raise (Clash(clashes.MinimumElement)) + | LambdaTerm (v, b) -> + try EA(LambdaTerm(v, substituteInExpr (Set.add v bvs) tmsubst b), e.CustomAttributes) + with Clash(bv) -> + if v = bv then + let v2 = Var(v.Name, v.Type) + let v2exp = E(VarTerm(v2)) + EA(LambdaTerm(v2, substituteInExpr bvs (fun v -> if v = bv then Some(v2exp) else tmsubst v) b), e.CustomAttributes) + else + reraise() + | HoleTerm _ -> e + + + let substituteRaw tmsubst e = substituteInExpr Set.empty tmsubst e + + + let tryGetReflectedDefinitionInstantiated (methodBase:MethodBase) : Expr option = + checkNonNull "methodBase" methodBase + None + + let cast (expr: Expr) : Expr<'T> = + new Expr<'T>(expr.Tree, expr.CustomAttributes) + +open Patterns + + +type Expr with + member x.WithRange (file : string, sl : int, sc : int, el : int, ec : int) = + let att = Expr.Value((file, sl, sc, el, ec) :> obj, typeof) + EA(x.Tree, [att]) + + member x.Substitute substitution = substituteRaw substitution x + member x.GetFreeVars () = (freeInExpr x :> seq<_>) + member x.Type = exprType x + + static member AddressOf (target:Expr) = + mkAddressOf target + + static member AddressSet (target:Expr, value:Expr) = + mkAddressSet (target, value) + + static member Application (functionExpr:Expr, argument:Expr) = + mkApplication (functionExpr, argument) + + static member Applications (functionExpr:Expr, arguments) = + mkApplications (functionExpr, arguments) + + static member Call (methodInfo:MethodInfo, arguments) = + checkNonNull "methodInfo" methodInfo + mkStaticMethodCall (methodInfo, arguments) + + static member Call (obj:Expr, methodInfo:MethodInfo, arguments) = + checkNonNull "methodInfo" methodInfo + mkInstanceMethodCall (obj, methodInfo, arguments) + + static member Coerce (source:Expr, target:Type) = + checkNonNull "target" target + mkCoerce (target, source) + + static member IfThenElse (guard:Expr, thenExpr:Expr, elseExpr:Expr) = + mkIfThenElse (guard, thenExpr, elseExpr) + + static member ForIntegerRangeLoop (loopVariable, start:Expr, endExpr:Expr, body:Expr) = + mkForLoop(loopVariable, start, endExpr, body) + + static member FieldGet (fieldInfo:FieldInfo) = + checkNonNull "fieldInfo" fieldInfo + mkStaticFieldGet fieldInfo + + static member FieldGet (obj:Expr, fieldInfo:FieldInfo) = + checkNonNull "fieldInfo" fieldInfo + mkInstanceFieldGet (obj, fieldInfo) + + static member FieldSet (fieldInfo:FieldInfo, value:Expr) = + checkNonNull "fieldInfo" fieldInfo + mkStaticFieldSet (fieldInfo, value) + + static member FieldSet (obj:Expr, fieldInfo:FieldInfo, value:Expr) = + checkNonNull "fieldInfo" fieldInfo + mkInstanceFieldSet (obj, fieldInfo, value) + + static member Lambda (parameter:Var, body:Expr) = mkLambda (parameter, body) + + static member Let (letVariable:Var, letExpr:Expr, body:Expr) = mkLet (letVariable, letExpr, body) + + static member LetRecursive (bindings, body:Expr) = mkLetRec (bindings, body) + + static member NewObject (constructorInfo:ConstructorInfo, arguments) = + checkNonNull "constructorInfo" constructorInfo + mkCtorCall (constructorInfo, arguments) + + static member DefaultValue (expressionType:Type) = + checkNonNull "expressionType" expressionType + mkDefaultValue expressionType + + static member NewTuple elements = + mkNewTuple elements + + static member NewRecord (recordType:Type, elements) = + checkNonNull "recordType" recordType + mkNewRecord (recordType, elements) + + static member NewArray (elementType:Type, elements) = + checkNonNull "elementType" elementType + mkNewArray(elementType, elements) + + static member NewDelegate (delegateType:Type, parameters: Var list, body: Expr) = + checkNonNull "delegateType" delegateType + mkNewDelegate(delegateType, mkIteratedLambdas (parameters, body)) + + static member NewUnionCase (unionCase, arguments) = + mkNewUnionCase (unionCase, arguments) + + static member PropertyGet (obj:Expr, property: PropertyInfo, ?indexerArgs) = + checkNonNull "property" property + mkInstancePropGet (obj, property, defaultArg indexerArgs []) + + static member PropertyGet (property: PropertyInfo, ?indexerArgs) = + checkNonNull "property" property + mkStaticPropGet (property, defaultArg indexerArgs []) + + static member PropertySet (obj:Expr, property:PropertyInfo, value:Expr, ?indexerArgs) = + checkNonNull "property" property + mkInstancePropSet(obj, property, defaultArg indexerArgs [], value) + + static member PropertySet (property:PropertyInfo, value:Expr, ?indexerArgs) = + mkStaticPropSet(property, defaultArg indexerArgs [], value) + + static member Quote (inner:Expr) = mkQuote (inner, true) + + static member QuoteRaw (inner:Expr) = mkQuote (inner, false) + + static member QuoteTyped (inner:Expr) = mkQuote (inner, true) + + static member Sequential (first:Expr, second:Expr) = + mkSequential (first, second) + + static member TryWith (body:Expr, filterVar:Var, filterBody:Expr, catchVar:Var, catchBody:Expr) = + mkTryWith (body, filterVar, filterBody, catchVar, catchBody) + + static member TryFinally (body:Expr, compensation:Expr) = + mkTryFinally (body, compensation) + + static member TupleGet (tuple:Expr, index:int) = + mkTupleGet (exprType tuple, index, tuple) + + static member TypeTest (source: Expr, target: Type) = + checkNonNull "target" target + mkTypeTest (source, target) + + static member UnionCaseTest (source:Expr, unionCase: UnionCaseInfo) = + mkUnionCaseTest (unionCase, source) + + [] + static member Value(value: obj, expressionType: Type) = + checkNonNull "expressionType" expressionType + mkValue(value, expressionType) + + + [] + static member ValueWithName(value: obj, expressionType: Type, name:string) = + checkNonNull "expressionType" expressionType + checkNonNull "name" name + mkValueWithName(value, expressionType, name) + + [] + static member WithValue(value: obj, expressionType: Type, definition: Expr) = + checkNonNull "expressionType" expressionType + mkValueWithDefn (value, expressionType, definition) + + + static member Var(variable) = + mkVar(variable) + + static member VarSet (variable, value:Expr) = + mkVarSet (variable, value) + + static member WhileLoop (guard:Expr, body:Expr) = + mkWhileLoop (guard, body) + + static member TryGetReflectedDefinition(methodBase:MethodBase) = + checkNonNull "methodBase" methodBase + tryGetReflectedDefinitionInstantiated(methodBase) + + static member Cast(source:Expr) = cast source + + static member Deserialize(qualifyingType:Type, spliceTypes, spliceExprs, bytes: byte[]) : Expr = + checkNonNull "qualifyingType" qualifyingType + checkNonNull "bytes" bytes + failwith "not implemented" + + static member Deserialize40(qualifyingType:Type, referencedTypes, spliceTypes, spliceExprs, bytes: byte[]) : Expr = + checkNonNull "spliceExprs" spliceExprs + checkNonNull "spliceTypes" spliceTypes + checkNonNull "referencedTypeDefs" referencedTypes + checkNonNull "qualifyingType" qualifyingType + checkNonNull "bytes" bytes + failwith "not implemented" + + static member RegisterReflectedDefinitions(resource, serializedValue) = + Expr.RegisterReflectedDefinitions(resource, serializedValue, [| |]) + + static member RegisterReflectedDefinitions(resource, serializedValue, referencedTypes) : unit = + failwith "not implemented" + //registerReflectedDefinitions( resource, serializedValue, referencedTypes) + + static member GlobalVar<'T>(name) : Expr<'T> = + checkNonNull "name" name + Expr.Var(Var.Global(name, typeof<'T>)) |> Expr.Cast + +[] +module DerivedPatterns = + open Patterns + + [] + let (|Bool|_|) input = match input with ValueObj(:? bool as v) -> Some(v) | _ -> None + [] + let (|String|_|) input = match input with ValueObj(:? string as v) -> Some(v) | _ -> None + [] + let (|Single|_|) input = match input with ValueObj(:? single as v) -> Some(v) | _ -> None + [] + let (|Double|_|) input = match input with ValueObj(:? double as v) -> Some(v) | _ -> None + [] + let (|Char|_|) input = match input with ValueObj(:? char as v) -> Some(v) | _ -> None + [] + let (|SByte|_|) input = match input with ValueObj(:? sbyte as v) -> Some(v) | _ -> None + [] + let (|Byte|_|) input = match input with ValueObj(:? byte as v) -> Some(v) | _ -> None + [] + let (|Int16|_|) input = match input with ValueObj(:? int16 as v) -> Some(v) | _ -> None + [] + let (|UInt16|_|) input = match input with ValueObj(:? uint16 as v) -> Some(v) | _ -> None + [] + let (|Int32|_|) input = match input with ValueObj(:? int32 as v) -> Some(v) | _ -> None + [] + let (|UInt32|_|) input = match input with ValueObj(:? uint32 as v) -> Some(v) | _ -> None + [] + let (|Int64|_|) input = match input with ValueObj(:? int64 as v) -> Some(v) | _ -> None + [] + let (|UInt64|_|) input = match input with ValueObj(:? uint64 as v) -> Some(v) | _ -> None + [] + let (|Unit|_|) input = match input with Comb0(ValueOp(_, ty, None)) when ty = typeof -> Some() | _ -> None + + /// (fun (x, y) -> z) is represented as 'fun p -> let x = p#0 let y = p#1' etc. + /// This reverses this encoding. + let (|TupledLambda|_|) (lam: Expr) = + /// Strip off the 'let' bindings for an TupledLambda + let rec stripSuccessiveProjLets (p:Var) n expr = + match expr with + | Let(v1, TupleGet(Var(pA), m), rest) + when p = pA && m = n-> + let restvs, b = stripSuccessiveProjLets p (n+1) rest + v1::restvs, b + | _ -> ([], expr) + match lam.Tree with + | LambdaTerm(v, body) -> + match stripSuccessiveProjLets v 0 body with + | [], b -> Some([v], b) + | letvs, b -> Some(letvs, b) + | _ -> None + + let (|TupledApplication|_|) e = + match e with + | Application(f, x) -> + match x with + | Unit -> Some(f, []) + | NewTuple(x) -> Some(f, x) + | x -> Some(f, [x]) + | _ -> None + + [] + let (|Lambdas|_|) (input: Expr) = qOneOrMoreRLinear (|TupledLambda|_|) input + [] + let (|Applications|_|) (input: Expr) = qOneOrMoreLLinear (|TupledApplication|_|) input + /// Reverse the compilation of And and Or + [] + let (|AndAlso|_|) input = + match input with + | IfThenElse(x, y, Bool(false)) -> Some(x, y) + | _ -> None + + [] + let (|OrElse|_|) input = + match input with + | IfThenElse(x, Bool(true), y) -> Some(x, y) + | _ -> None + + [] + let (|SpecificCall|_|) templateParameter = + // Note: precomputation + match templateParameter with + | (Lambdas(_, Call(_, minfo1, _)) | Call(_, minfo1, _)) -> + let isg1 = minfo1.IsGenericMethod + let gmd = if isg1 then minfo1.GetGenericMethodDefinition() else null + + // end-of-precomputation + + (fun tm -> + match tm with + | Call(obj, minfo2, args) + when ( // if metadata tokens are not available we'll rely only on equality of method references + if isg1 then + minfo2.IsGenericMethod && gmd = minfo2.GetGenericMethodDefinition() + else + minfo1 = minfo2) -> + Some(obj, (minfo2.GetGenericArguments() |> Array.toList), args) + | _ -> None) + | _ -> + invalidArg "templateParameter" ("SR.GetString(SR.QunrecognizedMethodCall)") + + + [] + let (|MethodWithReflectedDefinition|_|) (methodBase) = + Expr.TryGetReflectedDefinition(methodBase) + + [] + let (|PropertyGetterWithReflectedDefinition|_|) (propertyInfo:System.Reflection.PropertyInfo) = + Expr.TryGetReflectedDefinition(propertyInfo.GetGetMethod(true)) + + [] + let (|PropertySetterWithReflectedDefinition|_|) (propertyInfo:System.Reflection.PropertyInfo) = + Expr.TryGetReflectedDefinition(propertyInfo.GetSetMethod(true)) + +[] +module ExprShape = + open Patterns + let RebuildShapeCombination(shape:obj, arguments) = + // preserve the attributes + let op, attrs = unbox(shape) + EA(CombTerm(op, arguments), attrs) + // let e = + // match op, arguments with + // | AppOp, [f;x] -> mkApplication(f, x) + // | IfThenElseOp, [g;t;e] -> mkIfThenElse(g, t, e) + // | LetRecOp, [e1] -> mkLetRecRaw(e1) + // | LetRecCombOp, _ -> mkLetRecCombRaw(arguments) + // | LetOp, [e1;e2] -> mkLetRawWithCheck(e1, e2) + // | NewRecordOp(ty), _ -> mkNewRecord(ty, arguments) + // | NewUnionCaseOp(unionCase), _ -> mkNewUnionCase(unionCase, arguments) + // | UnionCaseTestOp(unionCase), [arg] -> mkUnionCaseTest(unionCase, arg) + // | NewTupleOp(ty), _ -> mkNewTupleWithType(ty, arguments) + // | TupleGetOp(ty, i), [arg] -> mkTupleGet(ty, i, arg) + // | InstancePropGetOp(pinfo), (obj::args) -> mkInstancePropGet(obj, pinfo, args) + // | StaticPropGetOp(pinfo), _ -> mkStaticPropGet(pinfo, arguments) + // | InstancePropSetOp(pinfo), obj::(FrontAndBack(args, v)) -> mkInstancePropSet(obj, pinfo, args, v) + // | StaticPropSetOp(pinfo), (FrontAndBack(args, v)) -> mkStaticPropSet(pinfo, args, v) + // | InstanceFieldGetOp(finfo), [obj] -> mkInstanceFieldGet(obj, finfo) + // | StaticFieldGetOp(finfo), [] -> mkStaticFieldGet(finfo ) + // | InstanceFieldSetOp(finfo), [obj;v] -> mkInstanceFieldSet(obj, finfo, v) + // | StaticFieldSetOp(finfo), [v] -> mkStaticFieldSet(finfo, v) + // | NewObjectOp minfo, _ -> mkCtorCall(minfo, arguments) + // | DefaultValueOp(ty), _ -> mkDefaultValue(ty) + // | StaticMethodCallOp(minfo), _ -> mkStaticMethodCall(minfo, arguments) + // | InstanceMethodCallOp(minfo), obj::args -> mkInstanceMethodCall(obj, minfo, args) + // | CoerceOp(ty), [arg] -> mkCoerce(ty, arg) + // | NewArrayOp(ty), _ -> mkNewArray(ty, arguments) + // | NewDelegateOp(ty), [arg] -> mkNewDelegate(ty, arg) + // | SequentialOp, [e1;e2] -> mkSequential(e1, e2) + // | TypeTestOp(ty), [e1] -> mkTypeTest(e1, ty) + // | AddressOfOp, [e1] -> mkAddressOf(e1) + // | VarSetOp, [E(VarTerm(v)); e] -> mkVarSet(v, e) + // | AddressSetOp, [e1;e2] -> mkAddressSet(e1, e2) + // | ForIntegerRangeLoopOp, [e1;e2;E(LambdaTerm(v, e3))] -> mkForLoop(v, e1, e2, e3) + // | WhileLoopOp, [e1;e2] -> mkWhileLoop(e1, e2) + // | TryFinallyOp, [e1;e2] -> mkTryFinally(e1, e2) + // | TryWithOp, [e1;Lambda(v1, e2);Lambda(v2, e3)] -> mkTryWith(e1, v1, e2, v2, e3) + // | QuoteOp flg, [e1] -> mkQuote(e1, flg) + // | ValueOp(v, ty, None), [] -> mkValue(v, ty) + // | ValueOp(v, ty, Some nm), [] -> mkValueWithName(v, ty, nm) + // | WithValueOp(v, ty), [e] -> mkValueWithDefn(v, ty, e) + // | _ -> raise <| System.InvalidOperationException ("SR.GetString(SR.QillFormedAppOrLet)") + + + // EA(e.Tree, attrs) + + [] + let rec (|ShapeVar|ShapeLambda|ShapeCombination|) input = + let rec loop expr = + let (E(t)) = expr + match t with + | VarTerm v -> ShapeVar(v) + | LambdaTerm(v, b) -> ShapeLambda(v, b) + | CombTerm(op, args) -> ShapeCombination(box (op, expr.CustomAttributes), args) + | HoleTerm _ -> invalidArg "expr" ("SR.GetString(SR.QunexpectedHole)") + loop (input :> Expr) \ No newline at end of file diff --git a/src/fable-library/Reflection.ts b/src/fable-library/Reflection.ts index 3770769c50..fdae7905e8 100644 --- a/src/fable-library/Reflection.ts +++ b/src/fable-library/Reflection.ts @@ -1,215 +1,1256 @@ import { anonRecord as makeAnonRecord, Record, Union } from "./Types"; -import { compareArraysWith, equalArraysWith } from "./Util"; +import { combineHashCodes, compareArraysWith, equalArraysWith, stringHash } from "./Util"; + +// tslint:disable: max-line-length + +export enum NReflKind { + Property = 0, + Field = 1, + MethodBase = 2, + Method = 3, + Constructor = 4, + UnionCase = 5, + Type = 6, +} + +function compareStrings(l: string, r: string) { + if (l === r) { return 0; } + return l < r ? -1 : 1; +} + +export class NParameterInfo { + constructor( + public Name: string, + public ParameterType: NTypeInfo, + ) { } + + public toPrettyString() { + return this.Name + " : " + this.ParameterType.toFullString(); + } + + public toString() { + return this.ParameterType.toString() + " " + this.Name; + } + + public get_ParameterType() { + return this.ParameterType; + } + + public get_Name() { + return this.Name; + } + + public GetHashCode() { + return combineHashCodes([stringHash(this.Name), this.ParameterType.GetHashCode()]); + } + + public Equals(o: any) { + if ("Name" in o && "ParameterType" in o) { + return this.Name === o.Name && equals(this.ParameterType, o.ParameterType); + } else { + return false; + } + } + + public CompareTo(o: any) { + if (o == null) { throw new Error("cannot compare to null"); } + + if ("Name" in o && "ParameterType" in o) { + const c = compareStrings(this.Name, o.Name); + if (c !== 0) { return c; } + return this.ParameterType.CompareTo(o.ParameterType); + } + throw new Error(`cannot compare to ${o}`); + } -export type FieldInfo = [string, TypeInfo]; -export type PropertyInfo = FieldInfo; +} -export type Constructor = new (...args: any[]) => any; +export abstract class NMemberInfo { + public attributes: CustomAttribute[]; -export class CaseInfo { constructor( - public declaringType: TypeInfo, - public tag: number, - public name: string, - public fields?: FieldInfo[]) { + public DeclaringType: NTypeInfo, + public Name: string, + att: CustomAttribute[], + ) { + + if (!Name) { throw new Error(`cannot declare MemberInfo without a name`); } + if (!DeclaringType) { throw new Error(`${Name} has no declaring type`); } + this.attributes = att || []; + } + + public abstract getMemberKind(): NReflKind; + public abstract toPrettyString(): string; + + public abstract GetHashCode(): number; + public abstract Equals(o: any): boolean; + public abstract CompareTo(o: any): number; + + public is(kind: NReflKind) { + return this.getMemberKind() === kind; + } + + public get_Name() { return this.Name; } + + public get_DeclaringType() { return this.DeclaringType; } + + public GetCustomAttributes(a: (boolean|NTypeInfo), _?: boolean) { + if (typeof a === "boolean") { + return this.attributes.map((att) => att.AttributeValue); + } else if (a.fullname) { + return this.attributes.filter((att) => att.AttributeType === a.fullname).map((att) => att.AttributeValue); + } else { + return this.attributes.map((att) => att.AttributeValue); + } } } -export type EnumCase = [string, number]; +export abstract class NMethodBase extends NMemberInfo { + public Parameters: NParameterInfo[]; + public IsStatic: boolean; -export class TypeInfo { constructor( - public fullname: string, - public generics?: TypeInfo[], - public construct?: Constructor, - public fields?: () => FieldInfo[], - public cases?: () => CaseInfo[], - public enumCases?: EnumCase[]) { + DeclaringType: NTypeInfo, + Name: string, + parameters: NParameterInfo[], + isStatic: boolean, + attributes: CustomAttribute[], + ) { + super(DeclaringType, Name, attributes); + parameters = parameters || []; + this.IsStatic = isStatic || false; + this.Parameters = parameters.map((t) => t.ParameterType.get_ContainsGenericParameters() ? new NParameterInfo(t.Name, DeclaringType.ResolveGeneric(t.ParameterType)) : t); + } + + public GetParameters() { return this.Parameters; } + + public get_IsStatic() { return this.IsStatic; } + + public ParametersAssignable(ts: NTypeInfo[]) { + if (this.Parameters.length === ts.length) { + const broken = + this.Parameters.findIndex((p, i) => { + const d = p.ParameterType; + const a = ts[i]; + return !(d.isGenericParameter || d.fullname === "System.Object" || equals(d, a)); + }); + return broken < 0; + } else { + return false; + } + } + +} + +export class NMethodInfo extends NMethodBase { + public ReturnType: NTypeInfo; + public GenericArguments: NTypeInfo[]; + + private isGenericDef: boolean; + private genMap: { [name: string]: number } = {}; + + constructor( + declaringType: NTypeInfo, + genericArguments: NTypeInfo[], + name: string, + parameters: NParameterInfo[], + returnType: NTypeInfo, + isStatic: boolean, + private invoke: (target: any, args: any[]) => any, + attributes: CustomAttribute[], + private declaration?: NMethodInfo, + ) { + super(declaringType, name, parameters.map((a) => a), isStatic, attributes); + + if (!returnType) { throw new Error(`MethodInfo ${declaringType.toFullString()} ${name} does not have a return type`); } + + genericArguments = genericArguments || []; + const isDef = genericArguments.findIndex((p) => p.isGenericParameter) >= 0; + + this.GenericArguments = genericArguments; + this.isGenericDef = isDef; + if (isDef) { + genericArguments.forEach((v, i) => { + this.genMap[v.fullname] = i; + }); + } else if (declaration) { + this.genMap = declaration.genMap; + } + this.Parameters.forEach((p) => { p.ParameterType = this.ResolveGeneric(p.ParameterType); }); + this.ReturnType = returnType.get_ContainsGenericParameters() ? this.ResolveGeneric(returnType) : returnType; + if (!this.ReturnType) { throw new Error(`MethodInfo ${declaringType.toFullString()} ${name} does not have a return type`); } + + } + + public getMemberKind() { + return NReflKind.Method; + } + + public GetHashCode() { + return combineHashCodes([ + this.DeclaringType.GetHashCode(), + combineHashCodes(this.GenericArguments.map((a) => a.GetHashCode())), + stringHash(this.Name), + combineHashCodes(this.Parameters.map((a) => a.GetHashCode())), + (this.IsStatic ? 1 : 0), + ]); + } + + public CompareTo(oo: any) { + if (!isMethodInfo(oo)) { throw new Error(`cannot compare MethodInfo to ${oo}`); } + const o = oo as NMethodInfo; + let c = 0; + c = compareStrings(this.Name, o.Name); if (c !== 0) { return c; } + c = this.IsStatic === o.IsStatic ? 0 : (this.IsStatic < o.IsStatic ? -1 : 1); if (c !== 0) { return c; } + c = this.DeclaringType.CompareTo(o.DeclaringType); if (c !== 0) { return c; } + c = compareArraysWith(this.GenericArguments, o.GenericArguments, (l, r) => l.CompareTo(r)); if (c !== 0) { return c; } + c = compareArraysWith(this.Parameters, o.Parameters, (l, r) => l.CompareTo(r)); if (c !== 0) { return c; } + return 0; + } + + public Equals(ob: any) { + if (isMethodInfo(ob)) { + return methodEquals(this, ob as NMethodInfo); + } else { + return false; + } + } + + public ResolveGeneric(t: NTypeInfo): NTypeInfo { + if (t.isGenericParameter) { + if (t.fullname in this.genMap) { + const idx = this.genMap[t.fullname]; + if (idx < 0 || idx > this.GenericArguments.length) { + throw new Error(`invalid generic index ${idx}`); + } + + return this.GenericArguments[idx]; + } else { + return this.DeclaringType.ResolveGeneric(t); + } + } else if (t.get_ContainsGenericParameters()) { + const gen = t.generics.map((t) => this.ResolveGeneric(t)); + return t.MakeGenericType(gen); + // return new NTypeInfo(t.fullname, t.genericCount, t.isGenericParameter, t.generics.map((t) => this.ResolveType(t)), t.members, t.declaration) + } else { + return t; + } + } + + public get_IsGenericMethodDefinition() { + return this.isGenericDef; + } + + public MakeGenericMethod(types: NTypeInfo[]) { + return new NMethodInfo(this.DeclaringType, types, this.Name, this.Parameters, this.ReturnType, this.IsStatic, this.invoke, this.attributes, this); } + + public get_IsGenericMethod() { return this.isGenericDef || this.declaration; } + + public GetGenericArguments(): NTypeInfo[] { + return this.GenericArguments; + } + + public GetGenericMethodDefinition(): NMethodInfo { + if (this.declaration) { + return this.declaration; + } else { + return this; + } + } + + public get_ReturnType() { return this.ReturnType; } + + public get_ReturnParameter() { + return new NParameterInfo("Return", this.ReturnType); + } + + public toPrettyString(): string { + const args = this.Parameters.map((p) => p.toPrettyString()).join(", "); + + let attPrefix = ""; + const atts = this.GetCustomAttributes(true); + if (atts.length > 0) { + attPrefix = "[<" + atts.map((a) => a.toString()).join("; ") + ">] "; + } + let prefix = "member "; + if (this.IsStatic) { prefix = "static " + prefix; } + + return attPrefix + prefix + this.Name + "(" + args + ") : " + this.ReturnType.toFullString(); + } + public toString() { - return fullName(this); + return this.toPrettyString(); } - public Equals(other: TypeInfo) { - return equals(this, other); + + public Invoke(target: any, args: any[]) { + args = args || []; + if (!this.IsStatic) { + if (!target) { throw new Error(`MethodInfo ${this.toPrettyString()} cannot be called without a this argument`); } + return this.invoke(target, args); + } else { + return this.invoke(null, args); + } } - public CompareTo(other: TypeInfo) { - return compare(this, other); +} + +export class NConstructorInfo extends NMethodBase { + constructor( + declaringType: NTypeInfo, + parameters: NParameterInfo[], + private invoke: (args: any[]) => any, + attributes: CustomAttribute[], + ) { + super(declaringType, ".ctor", parameters, true, attributes); + } + + public toPrettyString() { + const args = this.Parameters.map((p) => p.toPrettyString()).join(", "); + + let attPrefix = ""; + const atts = this.GetCustomAttributes(true); + if (atts.length > 0) { + attPrefix = "[<" + atts.map((a) => a.toString()).join("; ") + ">] "; + } + + return attPrefix + "new(" + args + ")"; + } + + public getMemberKind() { + return NReflKind.Constructor; + } + + public GetHashCode() { + return combineHashCodes([ + this.DeclaringType.GetHashCode(), + combineHashCodes(this.Parameters.map((p) => p.GetHashCode())), + ]); + } + + public Equals(o: any) { + if (isConstructorInfo(o)) { + return constructorEquals(this, o as NConstructorInfo); + } else { + return false; + } + } + + public CompareTo(oo: any) { + if (!isConstructorInfo(oo)) { throw new Error(`cannot compare ConstructorInfo to ${oo}`); } + const o = oo as NConstructorInfo; + let c = 0; + c = this.DeclaringType.CompareTo(o.DeclaringType); if (c !== 0) { return c; } + c = compareArraysWith(this.Parameters, o.Parameters, (l, r) => l.CompareTo(r)); if (c !== 0) { return c; } + return 0; + } + + public toString() { + return this.toPrettyString(); + } + + public Invoke(args: any[]) { + args = args || []; + return this.invoke(args); } } -export function getGenerics(t: TypeInfo): TypeInfo[] { - return t.generics != null ? t.generics : []; +export class NFieldInfo extends NMemberInfo { + public Type: NTypeInfo; + constructor( + declaringType: NTypeInfo, + name: string, + type: NTypeInfo, + public IsStatic: boolean, + attributes: CustomAttribute[], + private get?: (t: any) => any, + ) { + super(declaringType, name, attributes); + + if (!type) { throw new Error(`FieldInfo ${name} does not have a type`); } + + this.Type = type.get_ContainsGenericParameters() ? this.DeclaringType.ResolveGeneric(type) : type; + } + public get_FieldType() { return this.Type; } + public get_IsStatic() { return this.IsStatic; } + + public getMemberKind() { + return NReflKind.Field; + } + + public GetHashCode() { + return combineHashCodes([ + stringHash(this.Name), + this.DeclaringType.GetHashCode(), + (this.IsStatic ? 1 : 0), + ]); + } + + public Equals(o: any) { + if (isFieldInfo(o)) { + return fieldEquals(this, o as NFieldInfo); + } else { + return false; + } + } + + public CompareTo(oo: any) { + if (!isFieldInfo(oo)) { throw new Error(`cannot compare FieldInfo to ${oo}`); } + const o = oo as NFieldInfo; + let c = 0; + c = compareStrings(this.Name, o.Name); if (c !== 0) { return c; } + c = this.IsStatic === o.IsStatic ? 0 : (this.IsStatic < o.IsStatic ? -1 : 1); if (c !== 0) { return c; } + c = this.DeclaringType.CompareTo(o.DeclaringType); if (c !== 0) { return c; } + return 0; + } + + public toPrettyString() { + const typ = this.Type.toFullString(); + let prefix = "val "; + if (this.IsStatic) { prefix = "static " + prefix; } + + let attPrefix = ""; + const atts = this.GetCustomAttributes(true); + if (atts.length > 0) { + attPrefix = "[<" + atts.map((a) => a.toString()).join("; ") + ">] "; + } + + return attPrefix + prefix + this.Name + " : " + typ; + } + + public GetValue(target: any) { + if (this.get) { + return this.get(target); + } else { + throw new Error("cannot get field " + this.toPrettyString()); + } + } + + public toString() { + return this.toPrettyString(); + } + } -export function equals(t1: TypeInfo, t2: TypeInfo): boolean { - if (t1.fullname === "") { // Anonymous records - return t2.fullname === "" - && equalArraysWith(getRecordElements(t1), - getRecordElements(t2), - ([k1, v1], [k2, v2]) => k1 === k2 && equals(v1, v2)); - } else { - return t1.fullname === t2.fullname - && equalArraysWith(getGenerics(t1), getGenerics(t2), equals); +export class NPropertyInfo extends NMemberInfo { + public Type: NTypeInfo; + constructor( + DeclaringType: NTypeInfo, + Name: string, + type: NTypeInfo, + public IsStatic: boolean, + public IsFSharp: boolean, + attributes: CustomAttribute[], + private get?: (target: any, index: any[]) => any, + private set?: (target: any, index: any[], value: any) => void, + ) { + super(DeclaringType, Name, attributes); + + if (!type) { throw new Error(`FieldInfo ${Name} does not have a type`); } + + this.Type = type.get_ContainsGenericParameters() ? DeclaringType.ResolveGeneric(type) : type; + } + + public getMemberKind() { + return NReflKind.Property; + } + + public GetHashCode() { + return combineHashCodes([ + stringHash(this.Name), + this.DeclaringType.GetHashCode(), + (this.IsFSharp ? 1 : 0), + (this.IsStatic ? 1 : 0), + ]); + } + + public Equals(o: any) { + if (isPropertyInfo(o)) { + return propertyEquals(this, o as NPropertyInfo); + } else { + return false; + } + } + + public CompareTo(oo: any) { + if (!isPropertyInfo(oo)) { throw new Error(`cannot compare FieldInfo to ${oo}`); } + const o = oo as NPropertyInfo; + let c = 0; + c = this.IsStatic === o.IsStatic ? 0 : (this.IsStatic < o.IsStatic ? -1 : 1); if (c !== 0) { return c; } + c = this.IsFSharp === o.IsFSharp ? 0 : (this.IsFSharp < o.IsFSharp ? -1 : 1); if (c !== 0) { return c; } + c = compareStrings(this.Name, o.Name); if (c !== 0) { return c; } + c = this.DeclaringType.CompareTo(o.DeclaringType); if (c !== 0) { return c; } + return 0; + } + + public get_PropertyType() { return this.Type; } + public get_IsStatic() { return this.IsStatic; } + public get_IsFSharp() { return this.IsFSharp; } + + public get_CanRead() { + return this.get || this.get_GetMethod(); + } + public get_CanWrite() { + return this.set || this.get_SetMethod(); + } + + public GetIndexParameters() { + const m = this.get_GetMethod(); + if (m) { return m.GetParameters(); } else { return []; } + } + + public get_GetMethod() { + const getterName = "get_" + this.Name; + const mems = this.DeclaringType.GetAllMembers(); + const idx = mems.findIndex((m) => isMethodInfo(m) && m.Name === getterName); + if (idx >= 0) { + return mems[idx] as NMethodInfo; + } else { + return null; + } + } + + public get_SetMethod() { + const getterName = "set_" + this.Name; + const mems = this.DeclaringType.GetAllMembers(); + const idx = mems.findIndex((m) => isMethodInfo(m) && m.Name === getterName); + if (idx >= 0) { return mems[idx] as NMethodInfo; } else { return null; } + } + + public GetValue(target: any, index: any[]): any { + if (this.get) { + return this.get(target, index); + } else if (this.IsFSharp) { + // TODO: mangled-names???? + if (this.Name in target) { + return target[this.Name]; + } else { + throw new Error(`property ${this.Name} not in target`); + } + } else { + const g = this.get_GetMethod(); + if (g === null) { throw new Error(`property ${this.Name} has no GetMethod`); } + index = index || []; + return g.Invoke(target, index); + } + } + + public SetValue(target: any, value: any, index: any[]) { + if (this.set) { + return this.set(target, index, value); + } else if (this.IsFSharp) { + target[this.Name] = value; + } else { + index = index || []; + const s = this.get_SetMethod(); + s?.Invoke(target, [...index, value]); + } + } + + public toPrettyString() { + const g = this.get_GetMethod(); + const s = this.get_SetMethod(); + let typ = this.Type.toFullString(); + if (g && g.Parameters.length > 0) { + const prefix = g.Parameters.map((p) => p.ParameterType.toFullString()).join(" * "); + typ = prefix + " -> " + typ; + } else if (s && s.Parameters.length > 0) { + const prefix = s.Parameters.slice(0, s.Parameters.length - 1).map((p) => p.ParameterType.toFullString()).join(" * "); + typ = prefix + " -> " + typ; + } + + let suffix = ""; + if (g && s) { + suffix = " with get, set"; + } else if (g) { + suffix = " with get"; + } else if (s) { + suffix = " with set"; + } + + let prefix = "member "; + if (this.IsStatic) { prefix = "static " + prefix; } + + let attPrefix = ""; + const atts = this.GetCustomAttributes(true); + if (atts.length > 0) { + attPrefix = "[<" + atts.map((a) => a.toString()).join("; ") + ">] "; + } + + return attPrefix + prefix + this.Name + " : " + typ + suffix; + } + + public toString() { + return this.toPrettyString(); } + } -// System.Type is not comparable in .NET, but let's implement this -// in case users want to create a dictionary with types as keys -export function compare(t1: TypeInfo, t2: TypeInfo): number { - if (t1.fullname !== t2.fullname) { - return t1.fullname < t2.fullname ? -1 : 1; +export class NUnionCaseInfo extends NMemberInfo { + public Fields: NPropertyInfo[]; + + public constructor( + DeclaringType: NTypeInfo, + public Tag: number, + Name: string, + Attributes: CustomAttribute[], + fields: Array<[string, NTypeInfo]>, + public Invoke: (...args: any[]) => any, + ) { + super(DeclaringType, Name, Attributes); + + if (typeof Tag !== "number") { throw new Error(`UnionCase ${Name} does not have a tag`); } + + fields = fields || []; + this.Fields = fields.map ((tup, i) => { + const name = tup[0]; + const typ = tup[1].get_ContainsGenericParameters() ? DeclaringType.ResolveGeneric(tup[1]) : tup[1]; + return new NPropertyInfo(DeclaringType, name, typ, false, true, [], (t) => t.fields[i], (t, v) => { t.fields[i] = v; }); + // tup[1].get_ContainsGenericParameters() ? [tup[0], DeclaringType.ResolveGeneric(tup[1])] : tup) as Array<[string, NTypeInfo]>; + }); + } + + public getMemberKind() { + return NReflKind.UnionCase; + } + + public GetHashCode() { + return combineHashCodes([ + stringHash(this.Name), + this.DeclaringType.GetHashCode(), + ]); + } + + public Equals(o: any) { + if (isUnionCaseInfo(o)) { + return unionCaseEquals(this, o as NUnionCaseInfo); + } else { + return false; + } + } + + public CompareTo(oo: any) { + if (!isUnionCaseInfo(oo)) { throw new Error(`cannot compare UnionCaseInfo to ${oo}`); } + const o = oo as NUnionCaseInfo; + let c = 0; + c = compareStrings(this.Name, o.Name); if (c !== 0) { return c; } + c = this.DeclaringType.CompareTo(o.DeclaringType); if (c !== 0) { return c; } + return 0; + } + + + public GetFields() { + return this.Fields; + } + + public get_Tag() { + return this.Tag; + } + + public toPrettyString() { + const decl = this.DeclaringType.toFullString(); + const fields = this.Fields.map((tup) => tup.Name + ": " + tup.Type.toFullString()).join(" * "); + return decl + "." + this.Name + " of " + fields; + } + + public toString() { + return this.toPrettyString(); + } + +} + +export type NEnumCase = [string, number]; + +export class NTypeInfo { + public static getParameter(i: string) { + if (NTypeInfo.parameterCache[i]) { + return NTypeInfo.parameterCache[i]; + } else { + const p = new NTypeInfo(i, 0, true, [], (_s) => [], null, null); + this.parameterCache[i] = p; + return p; + } + } + + public static Simple(name: string) { + return new NTypeInfo(name, 0, false, [], ((_s) => []), null, null); + } + + private static parameterCache: {[i: string]: NTypeInfo} = {}; + public generics: NTypeInfo[]; + public GenericDeclaration: NTypeInfo | null; + public DeclaringType: NTypeInfo | null; + + private cachedMembers: NMemberInfo[] | null = null; + private instantiations: {[i: string]: NTypeInfo} = {}; + private genericMap: {[name: string]: number} = {}; + + constructor( + public fullname: string, + public genericCount: number, + public isGenericParameter: boolean, + _generics: NTypeInfo[], + public members: (self: NTypeInfo) => NMemberInfo[], + genericDeclaration: NTypeInfo | null, + declaringType: NTypeInfo | null, + public enumCases?: NEnumCase[]) { + if (!fullname) { throw new Error("cannot declare type without name"); } + _generics = _generics || []; + isGenericParameter = isGenericParameter || false; + genericCount = genericCount || 0; + + const g = _generics.filter((t) => !t.isGenericParameter); + if (g.length === genericCount) { + this.generics = g; + if (genericDeclaration) { + this.genericMap = genericDeclaration.genericMap; + } + } else { + _generics.forEach((g, i) => { + this.genericMap[g.get_Name()] = i; + }); + this.generics = _generics; + } + if (this.generics.length !== this.genericCount) { throw new Error(`${this.fullname} contains ${this.genericCount} generic parameters but only ${this.generics.length} given.`); } + this.GenericDeclaration = genericDeclaration || null; + this.DeclaringType = declaringType; + } + + public get_DeclaringType(): NTypeInfo | null { + return this.DeclaringType; + } + + public MakeArrayType(): NTypeInfo { + return array(this); + } + + public get_IsGenericParameter() { + return this.isGenericParameter; + } + + public ResolveGeneric(t: NTypeInfo): NTypeInfo { + if (t.isGenericParameter) { + if (t.fullname in this.genericMap) { + const idx = this.genericMap[t.fullname]; + return this.generics[idx]; + } else { + return t; + } + } else if (t.genericCount > 0) { + return new NTypeInfo(t.fullname, t.genericCount, false, t.generics.map((ta) => this.ResolveGeneric(ta)), t.members, t.GenericDeclaration, t.DeclaringType); + } else { + return t; + } + } + + public GetGenericTypeDefinition() { + if (this.genericCount === 0 || this.get_IsGenericTypeDefinition()) { + return this; + } else if (this.GenericDeclaration) { + return this.GenericDeclaration; + } else { + throw new Error(`${this.fullname} does not have a proper generic definition`); + } + } + + public MakeGenericType(args: NTypeInfo[]) { + // args = args.filter((a) => a); + if (args.length === 0) { return this; } + if (args.length !== this.genericCount) { throw new Error(`${this.fullname} contains ${this.genericCount} generic parameters but only ${args.length} given.`); } + + const key = args.map((t) => t.toString()).join(", "); + if (key in this.instantiations) { + return this.instantiations[key]; + } else { + const res = new NTypeInfo(this.fullname, this.genericCount, this.isGenericParameter, args, this.members, this, this.DeclaringType); + this.instantiations[key] = res; + return res; + } + } + + public get_FullName() { + return this.fullname; + } + public get_Namespace() { + const i = this.fullname.lastIndexOf("."); + return i === -1 ? "" : this.fullname.substr(0, i); + } + public get_Name() { + const i = this.fullname.lastIndexOf("."); + return i === -1 ? this.fullname : this.fullname.substr(i + 1); + } + public get_IsArray() { + return this.fullname.endsWith("[]"); + } + + public GetElementType(): NTypeInfo | null { + return this.get_IsArray() ? this.generics[0] : null; + } + + public get_IsGenericType() { + return this.genericCount > 0; + } + public get_IsGenericTypeDefinition() { + if (this.genericCount > 0) { + const idx = this.generics.findIndex((g) => g.isGenericParameter); + return idx >= 0; + } else { + return false; + } + } + + public get_ContainsGenericParameters(): boolean { + return this.isGenericParameter || (this.genericCount > 0 && (this.generics.length === 0 || (this.generics.findIndex((t) => t.get_ContainsGenericParameters()) >= 0))); + } + + public GetGenericArguments() { + if (this.genericCount > 0) { + if (this.generics.length > 0) { + return this.generics; + } else { + return Array(this.genericCount).map((_, i) => NTypeInfo.getParameter(i.toString())); + } + } else { + return []; + } + } + + public get_GenericTypeArguments() { + return this.GetGenericArguments(); + } + + public GetAllMembers() { + if (!this.cachedMembers) { + if (this.members) { + this.cachedMembers = this.members(this); + } else { + this.cachedMembers = []; + } + } + return this.cachedMembers; + } + + public GetMembers() { + const m = this.GetAllMembers(); + return m.filter((m) => !(isUnionCaseInfo(m))); + } + + public GetProperties() { + const m = this.GetAllMembers(); + return m.filter((m) => isPropertyInfo(m)) as NPropertyInfo[]; + } + + public GetMethods() { + const m = this.GetAllMembers(); + return m.filter((m) => isMethodInfo(m)) as NMethodInfo[]; + } + public GetConstructors() { + const m = this.GetAllMembers(); + return m.filter((m) => isConstructorInfo(m)) as NConstructorInfo[]; + } + public GetFields() { + const m = this.GetAllMembers(); + return m.filter((m) => isFieldInfo(m)) as NFieldInfo[]; + } + public GetConstructor(ts?: NTypeInfo[]) { + if (ts) { + return this.GetConstructors().find((ctor) => ctor.ParametersAssignable(ts)); + } else { + const ctors = this.GetConstructors(); + return ctors.length === 1 ? ctors[0] : null; + } + } + public GetField(name: string) { + const m = this.GetAllMembers(); + return m.find((m) => isFieldInfo(m) && m.Name === name) as NFieldInfo; + } + + public GetProperty(name: string) { + const m = this.GetAllMembers(); + const prop = m.find((m) => isPropertyInfo(m) && m.Name === name) as NPropertyInfo; + return prop; + } + public GetMethod(name: string, types?: NTypeInfo[]) { + const m = this.GetAllMembers(); + if (types) { + const meths = m.filter((m) => isMethodInfo(m) && m.Name === name && (m as NMethodInfo).ParametersAssignable(types)) as NMethodInfo[]; + return meths.length === 1 ? meths[0] : null; + } else { + const meths = m.filter((m) => isMethodInfo(m) && m.Name === name) as NMethodInfo[]; + return meths.length === 1 ? meths[0] : null; + } + } + public toFullString(): string { + if (this.isGenericParameter) { + return "'" + this.fullname; + } else if (this.genericCount > 0) { + let name = this.fullname; + const suffix = "`" + this.genericCount; + if (name.endsWith(suffix)) { + name = name.substr(0, name.length - suffix.length); + } + const args = this.generics.map((t) => t.toFullString()).join(", "); + return name + "<" + args + ">"; + } else { + return this.fullname; + } + } + + public toString(): string { + if (this.genericCount > 0) { + const suffix = "`" + this.genericCount; + return this.fullname.endsWith(suffix) ? this.fullname : this.fullname + suffix; + } else { + return this.fullname; + } + } + public toPrettyString() { + const members = + this + .GetMembers() + .filter((m) => !(isMethodInfo(m)) || !(m.Name.startsWith("get_") || m.Name.startsWith("set_"))) + .map((m) => " " + m.toPrettyString()).join("\n"); + return "type " + this.toFullString() + "=\n" + members; + } + + public GetHashCode() { + return stringHash(this.toFullString()); + } + + public Equals(other: NTypeInfo) { + return equals(this, other); + } + public CompareTo(other: NTypeInfo) { + return compare(this, other); + } +} + +export interface CustomAttribute { + AttributeType: string; + AttributeValue: any; +} + +const typeCache: { [fullname: string]: NTypeInfo } = {}; + +export function declareNType(fullname: string, generics: number, members: (self: NTypeInfo, gen: NTypeInfo[]) => NMemberInfo[]): NTypeInfo { + let gen: NTypeInfo; + if (fullname in typeCache) { + gen = typeCache[fullname]; } else { - return compareArraysWith(getGenerics(t1), getGenerics(t2), compare); + const pars = Array.from({ length: generics }, (_, i) => getGenericParameter("a" + i)); + + const mems = members || ((_self, _gen) => []); + gen = new NTypeInfo(fullname, pars.length, false, pars, (s) => mems(s, pars), null, null); + typeCache[fullname] = gen; } + return gen; } -export function class_type( - fullname: string, - generics?: TypeInfo[], - construct?: Constructor): TypeInfo { - return new TypeInfo(fullname, generics, construct); +export function getGenericParameter(name: string) { + return NTypeInfo.getParameter(name); } -export function record_type( - fullname: string, - generics: TypeInfo[], - construct: Constructor, - fields: () => FieldInfo[]): TypeInfo { - return new TypeInfo(fullname, generics, construct, fields); +export function getGenerics(t: NTypeInfo): NTypeInfo[] { + const gen = t.generics || []; + // const badIdx = gen.findIndex((t) => !t); + // if (badIdx >= 0) { throw new Error("bad generic arg: " + badIdx); } + return gen; } -export function anonRecord_type(...fields: FieldInfo[]): TypeInfo { - return new TypeInfo("", undefined, undefined, () => fields); +export function equals(t1: NTypeInfo, t2: NTypeInfo): boolean { + if (t1 === t2) { return true; } else + if (t1 == null && t2 != null) { return false; } else + if (t1 != null && t2 == null) { return false; } else { + if (t1.fullname === t2.fullname) { + const g1 = getGenerics(t1); + const g2 = getGenerics(t2); + try { + return equalArraysWith(g1, g2, equals); + } catch (e) { + throw new Error(t1.fullname + " g1: " + g1 + " g2: " + g2); + } + } else { + return false; + } + } } -export type CaseInfoInput = string | [string, FieldInfo[]]; +function typesEqual(l: NTypeInfo[], r: NTypeInfo[]) { + if (l.length === r.length) { + for (let i = 0; i < l.length; i++) { + if (!equals(l[i], r[i])) { return false; } + } + return true; + } else { + return false; + } +} -export function union_type( - fullname: string, - generics: TypeInfo[], - construct: Constructor, - cases: () => CaseInfoInput[]): TypeInfo { - const t: TypeInfo = new TypeInfo(fullname, generics, construct, undefined, () => cases().map((x, i) => - typeof x === "string" - ? new CaseInfo(t, i, x) - : new CaseInfo(t, i, x[0], x[1]))); - return t; +export function parameterEquals(l: NParameterInfo, r: NParameterInfo) { + if (l === r) { return true; } else + if (l == null && r != null) { return false; } else + if (l != null && r == null) { return false; } else { + return l.Name === r.Name && equals(l.ParameterType, r.ParameterType); + } } -export function tuple_type(...generics: TypeInfo[]): TypeInfo { - return new TypeInfo("System.Tuple`" + generics.length, generics); +function parametersEqual(l: NParameterInfo[], r: NParameterInfo[]) { + if (l.length === r.length) { + for (let i = 0; i < l.length; i++) { + if (!parameterEquals(l[i], r[i])) { return false; } + } + return true; + } else { + return false; + } } -export function delegate_type(...generics: TypeInfo[]): TypeInfo { - return new TypeInfo("System.Func`" + generics.length, generics); +export function fieldEquals(l: NFieldInfo, r: NFieldInfo) { + if (l === r) { return true; } else + if (l == null && r != null) { return false; } else + if (l != null && r == null) { return false; } else { + return l.Name === r.Name && l.IsStatic === r.IsStatic && equals(l.DeclaringType, r.DeclaringType); + } } -export function lambda_type(argType: TypeInfo, returnType: TypeInfo): TypeInfo { - return new TypeInfo("Microsoft.FSharp.Core.FSharpFunc`2", [argType, returnType]); +export function propertyEquals(l: NPropertyInfo, r: NPropertyInfo) { + if (l === r) { return true; } else + if (l == null && r != null) { return false; } else + if (l != null && r == null) { return false; } else { + return l.Name === r.Name && l.IsFSharp === r.IsFSharp && l.IsStatic === r.IsStatic && equals(l.DeclaringType, r.DeclaringType); + } } -export function option_type(generic: TypeInfo): TypeInfo { - return new TypeInfo("Microsoft.FSharp.Core.FSharpOption`1", [generic]); +export function constructorEquals(l: NConstructorInfo, r: NConstructorInfo) { + if (l === r) { return true; } else + if (l == null && r != null) { return false; } else + if (l != null && r == null) { return false; } else { + return equals(l.DeclaringType, r.DeclaringType) && parametersEqual(l.Parameters, r.Parameters); + } } -export function list_type(generic: TypeInfo): TypeInfo { - return new TypeInfo("Microsoft.FSharp.Collections.FSharpList`1", [generic]); +export function methodEquals(l: NMethodInfo, r: NMethodInfo) { + if (l === r) { return true; } else + if (l == null && r != null) { return false; } else + if (l != null && r == null) { return false; } else { + return l.Name === r.Name && + l.IsStatic === r.IsStatic && + equals(l.DeclaringType, r.DeclaringType) && + typesEqual(l.GenericArguments, r.GenericArguments) && + parametersEqual(l.Parameters, r.Parameters); + } } -export function array_type(generic: TypeInfo): TypeInfo { - return new TypeInfo(generic.fullname + "[]", [generic]); +export function unionCaseEquals(l: NUnionCaseInfo, r: NUnionCaseInfo) { + if (l === r) { return true; } else + if (l == null && r != null) { return false; } else + if (l != null && r == null) { return false; } else { + return l.Name === r.Name && equals(l.DeclaringType, r.DeclaringType); + } } -export function enum_type(fullname: string, underlyingType: TypeInfo, enumCases: EnumCase[]): TypeInfo { - return new TypeInfo(fullname, [underlyingType], undefined, undefined, undefined, enumCases); +export function memberEquals(l: NMemberInfo, r: NMemberInfo) { + if (l === r) { return true; } else + if (l == null && r != null) { return false; } else + if (l != null && r == null) { return false; } else { + const lk = l.getMemberKind(); + const rk = r.getMemberKind(); + if (lk !== rk) { return false; } + + switch (lk) { + case NReflKind.Constructor: return constructorEquals(l as NConstructorInfo, r as NConstructorInfo); + case NReflKind.Method: return methodEquals(l as NMethodInfo, r as NMethodInfo); + case NReflKind.Field: return fieldEquals(l as NFieldInfo, r as NFieldInfo); + case NReflKind.Property: return propertyEquals(l as NPropertyInfo, r as NPropertyInfo); + case NReflKind.UnionCase: return unionCaseEquals(l as NUnionCaseInfo, r as NUnionCaseInfo); + default: return l === r; + } + } } -export const obj_type: TypeInfo = new TypeInfo("System.Object"); -export const unit_type: TypeInfo = new TypeInfo("Microsoft.FSharp.Core.Unit"); -export const char_type: TypeInfo = new TypeInfo("System.Char"); -export const string_type: TypeInfo = new TypeInfo("System.String"); -export const bool_type: TypeInfo = new TypeInfo("System.Boolean"); -export const int8_type: TypeInfo = new TypeInfo("System.SByte"); -export const uint8_type: TypeInfo = new TypeInfo("System.Byte"); -export const int16_type: TypeInfo = new TypeInfo("System.Int16"); -export const uint16_type: TypeInfo = new TypeInfo("System.UInt16"); -export const int32_type: TypeInfo = new TypeInfo("System.Int32"); -export const uint32_type: TypeInfo = new TypeInfo("System.UInt32"); -export const float32_type: TypeInfo = new TypeInfo("System.Single"); -export const float64_type: TypeInfo = new TypeInfo("System.Double"); -export const decimal_type: TypeInfo = new TypeInfo("System.Decimal"); +export function methodBaseEquals(l: NMemberInfo, r: NMemberInfo) { + return memberEquals(l, r); +} -export function name(info: FieldInfo | CaseInfo | TypeInfo): string { - if (Array.isArray(info)) { - return info[0]; - } else if (info instanceof CaseInfo) { - return info.name; +// System.Type is not comparable in .NET, but let's implement this +// in case users want to create a dictionary with types as keys +export function compare(t1: NTypeInfo, t2: NTypeInfo): number { + if (t1.fullname !== t2.fullname) { + return t1.fullname < t2.fullname ? -1 : 1; } else { - const i = info.fullname.lastIndexOf("."); - return i === -1 ? info.fullname : info.fullname.substr(i + 1); + return compareArraysWith(getGenerics(t1), getGenerics(t2), compare); } } -export function fullName(t: TypeInfo): string { - const gen = t.generics != null && !isArray(t) ? t.generics : []; - if (gen.length > 0) { - return t.fullname + "[" + gen.map((x) => fullName(x)).join(",") + "]"; +export function ntype(fullname: string, genericNames?: string[], generics?: NTypeInfo[], members?: (self: NTypeInfo, pars: NTypeInfo[]) => NMemberInfo[], declaringType?: NTypeInfo): NTypeInfo { + let gen: NTypeInfo; + generics = generics || []; + const a = generics.findIndex((t) => !t); + if (a >= 0) { throw new Error("bad hate occured"); } + + if (fullname in typeCache) { + gen = typeCache[fullname]; + } else { + const _members = members || ((_s, _g) => []); + genericNames = genericNames || []; + const b = genericNames.findIndex((t) => !t); + if (b >= 0) { throw new Error("bad hate occured"); } + + const pars = genericNames.map((n) => getGenericParameter(n)); + gen = new NTypeInfo(fullname, pars.length, false, pars, (s) => _members(s, pars), null, declaringType || null); + typeCache[fullname] = gen; + } + + if (generics.length > 0) { + return gen.MakeGenericType(generics); } else { - return t.fullname; + return gen; } } +function selectMany(input: TIn[], selectListFn: (t: TIn, i: number) => TOut[]): TOut[] { + return input.reduce((out, inx, idx) => { + out.push(...selectListFn(inx, idx)); + return out; + }, new Array()); +} -export function namespace(t: TypeInfo) { - const i = t.fullname.lastIndexOf("."); - return i === -1 ? "" : t.fullname.substr(0, i); +export function tuple(...generics: any[]): NTypeInfo { + if (generics.length === 1) { generics = generics[0] as NTypeInfo[]; } + if (generics.length === 0) { throw new Error("empty tuple"); } + const name = "System.Tuple`" + generics.length; + const gen = + declareNType(name, generics.length, (self, gen) => selectMany(gen, (t, i) => [ + new NPropertyInfo(self, "Item" + i, t, false, false, []), + new NMethodInfo(self, [], "get_Item" + i, [], t, false, ((a) => a[i]), []), + ])); + return gen.MakeGenericType(generics); } -export function isArray(t: TypeInfo): boolean { - return t.fullname.endsWith("[]"); +export function delegate(...generics: NTypeInfo[]): NTypeInfo { + const name = "System.Func`" + generics.length; + const gen = + declareNType(name, generics.length, (self, _gen) => { + const ret = generics[generics.length - 1]; + const args = generics.slice(0, generics.length - 1).map((t, i) => new NParameterInfo("arg" + i, t)); + return [ + new NMethodInfo(self, [], "Invoke", args, ret, false, ((target, ...args) => target(...args)), []), + ]; + }); + return gen.MakeGenericType(generics); } -export function getElementType(t: TypeInfo): TypeInfo | undefined { - return isArray(t) ? t.generics?.[0] : undefined; +export function lambda(argType: NTypeInfo, returnType: NTypeInfo): NTypeInfo { + const name = "Microsoft.FSharp.Core.FSharpFunc`2"; + const gen = + declareNType(name, 2, (self, gen) => [ + new NMethodInfo(self, [], "Invoke", [new NParameterInfo("arg", gen[0])], gen[1], false, ((target, ...args) => target(...args)), []), + ]); + return gen.MakeGenericType([argType, returnType]); } -export function isGenericType(t: TypeInfo) { - return t.generics != null && t.generics.length > 0; +export function option(generic: NTypeInfo): NTypeInfo { + const name = "Microsoft.FSharp.Core.FSharpOption`1"; + const gen = + declareNType(name, 1, (self, gen) => [ + new NUnionCaseInfo(self, 0, "None", [], [], ((_) => null)), + new NUnionCaseInfo(self, 1, "Some", [], [["Value", gen[0]]], ((args, ..._rest) => args)), + ]); + return gen.MakeGenericType([generic]); } -export function isEnum(t: TypeInfo) { - return t.enumCases != null && t.enumCases.length > 0; +export function list(generic: NTypeInfo): NTypeInfo { + const gen = declareNType("Microsoft.FSharp.Collections.FSharpList`1", 1, (self, gen) => [ + new NPropertyInfo(self, "Head", gen[0], false, false, []), + new NMethodInfo(self, [], "get_Head", [], gen[0], false, ((l) => l[0]), []), + ]); + return gen.MakeGenericType([generic]); + // return new NTypeInfo("Microsoft.FSharp.Collections.FSharpList`1", 1, false, [generic], (_s) => []); +} + +export function array(generic: NTypeInfo): NTypeInfo { + const gen = declareNType("_[]", 1, (self, _gen) => [ + new NPropertyInfo(self, "Length", int32, false, false, []), + new NMethodInfo(self, [], "get_Length", [], int32, false, ((l) => l.length), []), + ]); + return gen.MakeGenericType([generic]); + // generic = generic || getGenericParameter("a"); + // return new NTypeInfo(generic.fullname + "[]", 1, false, [generic], (_s) => []); +} + +export function enumType(fullname: string, underlyingType: NTypeInfo, enumCases: NEnumCase[]): NTypeInfo { + return new NTypeInfo(fullname, 1, false, [underlyingType], (_) => [], null, null, enumCases); +} + +export const obj: NTypeInfo = NTypeInfo.Simple("System.Object"); +export const unit: NTypeInfo = NTypeInfo.Simple("Microsoft.FSharp.Core.Unit"); +export const char: NTypeInfo = NTypeInfo.Simple("System.Char"); +export const string: NTypeInfo = NTypeInfo.Simple("System.String"); +export const bool: NTypeInfo = NTypeInfo.Simple("System.Boolean"); +export const int8: NTypeInfo = NTypeInfo.Simple("System.SByte"); +export const uint8: NTypeInfo = NTypeInfo.Simple("System.Byte"); +export const int16: NTypeInfo = NTypeInfo.Simple("System.Int16"); +export const uint16: NTypeInfo = NTypeInfo.Simple("System.UInt16"); +export const int32: NTypeInfo = NTypeInfo.Simple("System.Int32"); +export const uint32: NTypeInfo = NTypeInfo.Simple("System.UInt32"); +export const float32: NTypeInfo = NTypeInfo.Simple("System.Single"); +export const float64: NTypeInfo = NTypeInfo.Simple("System.Double"); +export const decimal: NTypeInfo = NTypeInfo.Simple("System.Decimal"); + +export function isType(o: any) { + return o != null && "fullname" in o; +} +export function isMemberInfo(o: any) { + return o != null && "getMemberKind" in o; +} +export function isMethodBase(o: any) { + if (isMemberInfo(o)) { + const k = o.getMemberKind(); + return k === NReflKind.Method || k === NReflKind.Constructor; + } else { + return false; + } +} +export function isMethodInfo(o: any) { + return o != null && isMemberInfo(o) && o.getMemberKind() === NReflKind.Method; +} +export function isPropertyInfo(o: any) { + return o != null && isMemberInfo(o) && o.getMemberKind() === NReflKind.Property; +} +export function isUnionCaseInfo(o: any) { + return o != null && isMemberInfo(o) && o.getMemberKind() === NReflKind.UnionCase; +} +export function isFieldInfo(o: any) { + return o != null && isMemberInfo(o) && o.getMemberKind() === NReflKind.Field; +} +export function isConstructorInfo(o: any) { + return o != null && isMemberInfo(o) && o.getMemberKind() === NReflKind.Constructor; } -/** - * This doesn't replace types for fields (records) or cases (unions) - * but it should be enough for type comparison purposes - */ -export function getGenericTypeDefinition(t: TypeInfo) { - return t.generics == null ? t : new TypeInfo(t.fullname, t.generics.map(() => obj_type)); +export function isEnum(t: NTypeInfo) { + return t.enumCases != null && t.enumCases.length > 0; } -export function getEnumUnderlyingType(t: TypeInfo) { - return t.generics?.[0]; +export function getEnumUnderlyingType(t: NTypeInfo) { + return t.generics[0]; } -export function getEnumValues(t: TypeInfo): number[] { - if (isEnum(t) && t.enumCases != null) { +export function getEnumValues(t: NTypeInfo): number[] { + if (t.enumCases) { return t.enumCases.map((kv) => kv[1]); } else { throw new Error(`${t.fullname} is not an enum type`); } } -export function getEnumNames(t: TypeInfo): string[] { - if (isEnum(t) && t.enumCases != null) { +export function getEnumNames(t: NTypeInfo): string[] { + if (t.enumCases) { return t.enumCases.map((kv) => kv[0]); } else { throw new Error(`${t.fullname} is not an enum type`); } } -function getEnumCase(t: TypeInfo, v: number | string): EnumCase { - if (t.enumCases != null) { +function getEnumCase(t: NTypeInfo, v: number | string): NEnumCase { + if (t.enumCases) { if (typeof v === "string") { for (const kv of t.enumCases) { if (kv[0] === v) { @@ -231,13 +1272,13 @@ function getEnumCase(t: TypeInfo, v: number | string): EnumCase { } } -export function parseEnum(t: TypeInfo, str: string): number { +export function parseEnum(t: NTypeInfo, str: string): number { // TODO: better int parsing here, parseInt ceils floats: "4.8" -> 4 const value = parseInt(str, 10); return getEnumCase(t, isNaN(value) ? str : value)[1]; } -export function tryParseEnum(t: TypeInfo, str: string): [boolean, number] { +export function tryParseEnum(t: NTypeInfo, str: string): [boolean, number] { try { const v = parseEnum(t, str); return [true, v]; @@ -247,11 +1288,11 @@ export function tryParseEnum(t: TypeInfo, str: string): [boolean, number] { return [false, NaN]; } -export function getEnumName(t: TypeInfo, v: number): string { +export function getEnumName(t: NTypeInfo, v: number): string { return getEnumCase(t, v)[0]; } -export function isEnumDefined(t: TypeInfo, v: string | number): boolean { +export function isEnumDefined(t: NTypeInfo, v: string | number): boolean { try { const kv = getEnumCase(t, v); return kv[0] != null && kv[0] !== ""; @@ -263,32 +1304,34 @@ export function isEnumDefined(t: TypeInfo, v: string | number): boolean { // FSharpType -export function getUnionCases(t: TypeInfo): CaseInfo[] { - if (t.cases != null) { - return t.cases(); +export function getUnionCases(t: NTypeInfo): NUnionCaseInfo[] { + const cases = t.GetAllMembers().filter((m) => isUnionCaseInfo(m)) as NUnionCaseInfo[]; + if (cases.length > 0) { + return cases; } else { throw new Error(`${t.fullname} is not an F# union type`); } } -export function getRecordElements(t: TypeInfo): FieldInfo[] { - if (t.fields != null) { - return t.fields(); +export function getRecordElements(t: NTypeInfo): NPropertyInfo[] { + const fields = t.GetAllMembers().filter((m) => isPropertyInfo(m) && (m as NPropertyInfo).IsFSharp) as NPropertyInfo[]; + if (fields.length > 0) { + return fields; } else { throw new Error(`${t.fullname} is not an F# record type`); } } -export function getTupleElements(t: TypeInfo): TypeInfo[] { - if (isTuple(t) && t.generics != null) { +export function getTupleElements(t: NTypeInfo): NTypeInfo[] { + if (isTuple(t)) { return t.generics; } else { throw new Error(`${t.fullname} is not a tuple type`); } } -export function getFunctionElements(t: TypeInfo): [TypeInfo, TypeInfo] { - if (isFunction(t) && t.generics != null) { +export function getFunctionElements(t: NTypeInfo): [NTypeInfo, NTypeInfo] { + if (isFunction(t)) { const gen = t.generics; return [gen[0], gen[1]]; } else { @@ -297,25 +1340,35 @@ export function getFunctionElements(t: TypeInfo): [TypeInfo, TypeInfo] { } export function isUnion(t: any): boolean { - return t instanceof TypeInfo ? t.cases != null : t instanceof Union; + if (isType(t)) { + const idx = (t as NTypeInfo).GetAllMembers().findIndex((m) => isUnionCaseInfo(m)); + return idx >= 0; + } else { + return t instanceof Union; + } } export function isRecord(t: any): boolean { - return t instanceof TypeInfo ? t.fields != null : t instanceof Record; + if (isType(t)) { + const idx = (t as NTypeInfo).GetAllMembers().findIndex((m) => isPropertyInfo(m) && (m as NPropertyInfo).IsFSharp); + return idx >= 0; + } else { + return t instanceof Record; + } } -export function isTuple(t: TypeInfo): boolean { +export function isTuple(t: NTypeInfo): boolean { return t.fullname.startsWith("System.Tuple"); } // In .NET this is false for delegates -export function isFunction(t: TypeInfo): boolean { +export function isFunction(t: NTypeInfo): boolean { return t.fullname === "Microsoft.FSharp.Core.FSharpFunc`2"; } // FSharpValue -export function getUnionFields(v: any, t: TypeInfo): [CaseInfo, any[]] { +export function getUnionFields(v: any, t: NTypeInfo): [NUnionCaseInfo, any[]] { const cases = getUnionCases(t); const case_ = cases[v.tag]; if (case_ == null) { @@ -324,16 +1377,39 @@ export function getUnionFields(v: any, t: TypeInfo): [CaseInfo, any[]] { return [case_, v.fields]; } -export function getUnionCaseFields(uci: CaseInfo): FieldInfo[] { - return uci.fields == null ? [] : uci.fields; +export function getUnionCaseFields(uci: NUnionCaseInfo): NPropertyInfo[] { + return uci.Fields; } -export function getRecordFields(v: any): FieldInfo[] { +export function getRecordFields(v: any): any[] { return Object.keys(v).map((k) => v[k]); } -export function getRecordField(v: any, field: FieldInfo): any { - return v[field[0]]; +export function getRecordField(v: any, field: NPropertyInfo): any { + return v[field.Name]; +} + +export function anonRecord(...fields: Array<[string, NTypeInfo]>): NTypeInfo { + const fullName = fields.map((nt) => nt[0] + nt[1].toFullString()).join("_"); + return declareNType(fullName, 0, (self, _) => { + const mems = fields.map((tt) => new NPropertyInfo(self, tt[0], tt[1], false, true, [], ((target) => target[tt[0]])) as NMemberInfo); + + const pars = fields.map ((tt) => new NParameterInfo(tt[0], tt[1])); + + function makeObj(args: any[]) { + if (args.length !== fields.length) { throw new Error(`mismatching argument count for anon record ${args.length} expected ${fields.length}`); } + const res: any = {}; + for (let i = 0; i < fields.length; i++) { + res[fields[i][0]] = args[i]; + } + return res; + } + + const ctor = new NConstructorInfo(self, pars, (args) => makeAnonRecord(makeObj(args)), []); + mems.push(ctor as NMemberInfo); + + return mems; + }); } export function getTupleFields(v: any): any[] { @@ -344,56 +1420,23 @@ export function getTupleField(v: any, i: number): any { return v[i]; } -export function makeUnion(uci: CaseInfo, values: any[]): any { - const expectedLength = (uci.fields || []).length; - if (values.length !== expectedLength) { - throw new Error(`Expected an array of length ${expectedLength} but got ${values.length}`); - } - return uci.declaringType.construct != null - ? new uci.declaringType.construct(uci.tag, uci.name, ...values) - : {}; +export function makeUnion(uci: NUnionCaseInfo, values: any[]): any { + return uci.Invoke.apply(null, values); } -export function makeRecord(t: TypeInfo, values: any[]): any { +export function makeRecord(t: NTypeInfo, values: any[]): any { const fields = getRecordElements(t); if (fields.length !== values.length) { throw new Error(`Expected an array of length ${fields.length} but got ${values.length}`); } - return t.construct != null - ? new t.construct(...values) - : makeAnonRecord(fields.reduce((obj, [key, _t], i) => { - obj[key] = values[i]; - return obj; - }, {} as any)); + const ctor = t.GetAllMembers().find((m) => isConstructorInfo(m)) as NConstructorInfo; + return ctor.Invoke(values); } -export function makeTuple(values: any[], _t: TypeInfo): any { +export function makeTuple(values: any[], _: NTypeInfo): any { return values; } -export function makeGenericType(t: TypeInfo, generics: TypeInfo[]): TypeInfo { - return new TypeInfo( - t.fullname, - generics, - t.construct, - t.fields, - t.cases); -} - -export function createInstance(t: TypeInfo, consArgs?: any[]): any { - // TODO: Check if consArgs length is same as t.construct? - // (Arg types can still be different) - if (typeof t.construct === "function") { - return new t.construct(...(consArgs ?? [])); - } else { - throw new Error(`Cannot access constructor of ${t.fullname}`); - } -} - -export function getValue(propertyInfo : PropertyInfo, v : any) : any { - return v[propertyInfo[0]] ; -} - // Fable.Core.Reflection function assertUnion(x: any) { @@ -416,3 +1459,22 @@ export function getCaseFields(x: any): any[] { assertUnion(x); return x.fields; } + +export function createMethod(decl: NTypeInfo, name: string, mpars: string[], margs: NTypeInfo[], declaredArgs: NTypeInfo[], ret: NTypeInfo, isStatic: boolean): NMethodInfo { + const found = + decl.GetMethods().find((m) => + m.Name === name && m.GenericArguments.length === margs.length && + m.Parameters.length === declaredArgs.length && m.IsStatic === isStatic && + (m.get_IsGenericMethod() ? m.MakeGenericMethod(margs).ParametersAssignable(declaredArgs) : m.ParametersAssignable(declaredArgs)) && + equals(m.ReturnType, ret), + ); + if (found) { + return found.get_IsGenericMethod() ? found.MakeGenericMethod(margs) : found; + } else { + const pp = mpars.map ((n) => getGenericParameter(n)); + const meth = new NMethodInfo(decl, pp, name, declaredArgs.map((a, i) => new NParameterInfo("arg" + i, a)), ret, isStatic, ((_target, _args) => { throw new Error("cannot invoke " + decl.fullname + "." + name); }), []); + // TODO: Is this necessary? I don't see `createMethod` in use anywhere + // decl.cachedMembers.push(meth); + return meth.get_IsGenericMethod() ? meth.MakeGenericMethod(margs) : meth; + } +} diff --git a/src/fable-library/String.ts b/src/fable-library/String.ts index 1e964bef84..aa434d4058 100644 --- a/src/fable-library/String.ts +++ b/src/fable-library/String.ts @@ -464,24 +464,83 @@ export function arrayToGuid(buf: ArrayLike) { return guid; } -function notSupported(name: string): never { - throw new Error("The environment doesn't support '" + name + "', please use a polyfill."); +function valueToCharCode(c: number) { + if (c < 26) { + return 65 + c; + } else if (c < 52) { + return 97 + (c - 26); + } else if (c < 62) { + return 48 + (c - 52); + } else if (c === 62) { + return 43; + } else if (c === 63) { + return 47; + } else { + return 0; + } +} +function charCodeToValue(c: number) { + if (c >= 65 && c <= 90) { + return c - 65; + } else if (c >= 97 && c <= 122) { + return 26 + c - 97; + } else if (c >= 48 && c <= 57) { + return 52 + c - 48; + } else if (c === 43) { + return 62; + } else if (c === 47) { + return 63; + } else { + return 0; + } } export function toBase64String(inArray: number[]) { - let str = ""; - for (let i = 0; i < inArray.length; i++) { - str += String.fromCharCode(inArray[i]); - } - return typeof btoa === "function" ? btoa(str) : notSupported("btoa"); + let res = ""; + let i = 0; + while (i < inArray.length - 3) { + const b0 = inArray[i++]; + const b1 = inArray[i++]; + const b2 = inArray[i++]; + const c0 = valueToCharCode((b0 >> 2)); + const c1 = valueToCharCode(((b0 & 0x3) << 4) | (b1 >> 4)); + const c2 = valueToCharCode(((b1 & 0xF) << 2) | (b2 >> 6)); + const c3 = valueToCharCode(b2 & 0x3F); + res += String.fromCharCode(c0, c1, c2, c3); + } + + const missing = inArray.length - i; + const b0 = inArray[i++]; + const b1 = i < inArray.length ? inArray[i++] : 0; + const b2 = i < inArray.length ? inArray[i++] : 0; + const c0 = valueToCharCode((b0 >> 2)); + const c1 = valueToCharCode(((b0 & 0x3) << 4) | (b1 >> 4)); + const c2 = missing < 2 ? 61 : valueToCharCode(((b1 & 0xF) << 2) | (b2 >> 6)); + const c3 = missing < 3 ? 61 : valueToCharCode(b2 & 0x3F); + res += String.fromCharCode(c0, c1, c2, c3); + return res; } export function fromBase64String(b64Encoded: string) { - const binary = typeof atob === "function" ? atob(b64Encoded) : notSupported("atob"); - const bytes = new Uint8Array(binary.length); - for (let i = 0; i < binary.length; i++) { - bytes[i] = binary.charCodeAt(i); + let pad = 0; + while (b64Encoded.charCodeAt(b64Encoded.length - 1 - pad) === 61) { + pad = pad + 1; } + const length = 3 * (0 | b64Encoded.length / 4) - pad; + const bytes = new Uint8Array(length); + + let o = 0; + let i = 0; + while (i < bytes.length) { + const c0 = charCodeToValue(b64Encoded.charCodeAt(o++)); + const c1 = charCodeToValue(b64Encoded.charCodeAt(o++)); + const c2 = charCodeToValue(b64Encoded.charCodeAt(o++)); + const c3 = charCodeToValue(b64Encoded.charCodeAt(o++)); + bytes[i++] = ((c0 << 2) | (c1 >> 4)) & 0xFF; + if (i < bytes.length) { bytes[i++] = ((c1 << 4) | (c2 >> 2)) & 0xFF; } + if (i < bytes.length) { bytes[i++] = ((c2 << 6) | c3) & 0xFF; } + } + return bytes; } diff --git a/src/fable-standalone/src/Fable.Standalone.fsproj b/src/fable-standalone/src/Fable.Standalone.fsproj index e0fad2210d..86421734ce 100644 --- a/src/fable-standalone/src/Fable.Standalone.fsproj +++ b/src/fable-standalone/src/Fable.Standalone.fsproj @@ -26,6 +26,7 @@ + diff --git a/src/fable-standalone/src/Main.fs b/src/fable-standalone/src/Main.fs index a44f873ca8..99688d1694 100644 --- a/src/fable-standalone/src/Main.fs +++ b/src/fable-standalone/src/Main.fs @@ -230,6 +230,7 @@ let makeCompilerOptions (config: CompilerConfig option) (otherFSharpOptions: str debugMode = isDebug verbosity = Fable.Verbosity.Normal outputPublicInlinedFunctions = false + quotations = false precompiledLib = config.precompiledLib } let compileAst (com: Compiler) (project: Project) = diff --git a/tests/Main/ExprTests.fs b/tests/Main/ExprTests.fs new file mode 100644 index 0000000000..5a93c81973 --- /dev/null +++ b/tests/Main/ExprTests.fs @@ -0,0 +1,262 @@ +module Fable.Tests.Expr + +open System +open Util.Testing +open Fable.Tests +open System.Globalization +open FSharp.Quotations.Patterns + + +type Heinz<'a>(value : 'a) = + member x.Sepp = [value] + + member x.Self(v : 'a) = Heinz(v) + + +type Bla() = + member x.Delay (f : unit -> 'a) = f() + +type SeppBuilder() = + inherit Bla() + member x.Quote() = () + + member x.Return v = v + + +let sepp = SeppBuilder() + +type BlaAttribute(name : string) = + inherit Attribute() + member x.Name = name + override x.ToString() = sprintf "Bla(%s)" name + +type BlubbAttribute(name : string) = + inherit Attribute() + member x.Name = name + override x.ToString() = sprintf "Blubb(%s)" name + +type V2 = { x : int; y : int } with + [] + static member Blubber = { x = 1; y = 3} + + [] + member x.Sepp = + x.x + x.y + + static member GetX (v : V2) = v.x + + static member (+) (l : V2, r : V2) = { x = l.x + r.x; y = l.y + r.y } + + member x.Item + with set (i : int) (v : int) = + () + +open FSharp.Quotations +open FSharp.Quotations.Patterns +open Fable.Core + +type System.Type with + + [] + member x.ToPrettyString() : string = jsNative + +type Classy(a : int, b : string) = + let mutable a = a + let mutable b = b + member x.Yeah + with get() = b + and set (v : string) = b <- v + + member x.DoIt(c : int) = a*c + + member x.Item + with get(i : int) = a + i + and set (i : int) (v : int) = a <- v - i + +type MyUnion = + | Values of int * int + | Single of value : int + + +module MyModule = + let someValue = Values(1,1) + +[] +module Blubber = + type Classy with + member x.A = 10 +let tests = + testList "Expr" [ + + + testCase "Var constructions" <| fun () -> + let a = Var("a", typeof, true) + let b = Var("b", typeof) + let a2 = Var("a", typeof, true) + + equal a.Name "a" + equal b.Name "b" + equal a.IsMutable true + equal b.IsMutable false + equal a.Type typeof + equal b.Type typeof + + equal a a + equal b b + equal a2 a2 + notEqual a a2 + + testCase "Expr.Value" <| fun () -> + let e = Expr.Value(10, typeof) + equal e.Type typeof + match e with + | Value((:? int as o),t) -> + equal o 10 + equal typeof t + | _ -> failwith "not a value" + + testCase "Expr.Value<'a>" <| fun () -> + let e = Expr.Value(10) + equal e.Type typeof + match e with + | Value((:? int as o),t) -> + equal o 10 + equal typeof t + | _ -> failwith "not a value" + + testCase "Expr.Var" <| fun () -> + let v = Var("a", typeof) + let e = Expr.Var v + equal e.Type typeof + match e with + | Var v1 -> equal v v1 + | _ -> failwith "not a var" + + testCase "Expr.Lambda" <| fun () -> + let v = Var("a", typeof) + let e = Expr.Lambda(v, Expr.Var v) + equal e.Type typeof int> + match e with + | Lambda(v1, _) -> equal v v1 + | _ -> failwith "not a lambda" + + testCase "Expr.Application" <| fun () -> + let v = Var("a", typeof float>) + let e = Expr.Application(Expr.Var v, Expr.Value 10) + equal e.Type typeof + match e with + | Application(v1, _) -> () + | _ -> failwith "not a lambda" + + testCase "Expr.IfThenElse" <| fun () -> + let v = Var("a", typeof) + match Expr.IfThenElse(Expr.Var v, Expr.Value 10, Expr.Value 3) with + | IfThenElse _ -> () + | _ -> failwith "not an ifthenelse" + + + testCase "Expr.Let" <| fun () -> + let v = Var("a", typeof) + let e = Expr.Let(v, Expr.Value 100, Expr.Var v) + match e with + | Let(v1, Value _, Var _) -> equal v v1 + | _ -> failwith "bad let binding" + + + testCase "Expr.LetRecursive" <| fun () -> + let bindings = + [ + Var("a", typeof), Expr.Value 10.0 + Var("b", typeof), Expr.Value true + ] + let e = Expr.LetRecursive(bindings, Expr.Value 100) + equal e.Type typeof + match e with + | LetRecursive([a, va; b, vb], _) -> + equal a.Name "a" + equal a.Type va.Type + equal a.Type typeof + + equal b.Name "b" + equal b.Type vb.Type + equal b.Type typeof + | _ -> failwith "bad recursive binding" + + testCase "Expr.NewRecord" <| fun () -> + let e = Expr.NewRecord(typeof, [Expr.Value 10; Expr.Value 1]) + match e with + | NewRecord(t, [a;b]) -> + equal t typeof + | _ -> + failwith "bad record" + + testCase "Quote static call library" <| fun () -> + + match <@@ fun (a : int) -> a + 1 @@> with + | Lambda(va,Call(None, add, [Var a; Value(x,y)])) -> + equal "op_Addition" add.Name + equal 3 (add.GetGenericArguments().Length) + equal a va + equal (1 :> obj) x + equal y typeof + | e -> + failwithf "bad expression: %A" e + + testCase "Quote static call user" <| fun () -> + + match <@@ V2.GetX @@> with + | Lambda(va,Call(None, m, [Var a])) -> + equal "GetX" m.Name + equal m (typeof.GetMethod("GetX")) + equal a va + | e -> + failwithf "bad expression: %A" e + + testCase "Quote option deconstruct" <| fun () -> + match <@@ fun (v : Option) -> match v with | Some a -> a | None -> 0 @@> with + | Lambda(va,IfThenElse(UnionCaseTest(Var v, c), a, b)) -> + equal va v + | e -> + failwithf "bad expression: %A" e + + testCase "Quote record property" <| fun () -> + match <@@ fun (v : V2) -> v.x @@> with + | Lambda(va,PropertyGet(Some (Var v), prop, [])) -> + equal va v + equal prop (typeof.GetProperty("x")) + | e -> + failwithf "bad expression: %A" e + + testCase "Quote Extension Property" <| fun () -> + match <@@ fun (v : Classy) -> v.A @@> with + | Lambda (_, Call(t, meth, args)) -> + equal "Classy.get_A" meth.Name + | _ -> + () + + testCase "Property Get/SetValue working (indexed)" <| fun () -> + let instance = Classy(10, "11") + let prop = typeof.GetProperty "Item" + let test = prop.GetValue(instance, [| 15 :> obj |]) + equal (25 :> obj) test + prop.SetValue(instance, 24, [| 15 :> obj |]) + equal 24 instance.[15] + + + testCase "Property Get/SetValue working" <| fun () -> + let instance = Classy(10, "11") + let prop = typeof.GetProperty "Yeah" + let test = prop.GetValue(instance) + equal ("11" :> obj) test + prop.SetValue(instance, "123" :> obj) + equal "123" instance.Yeah + + // let e = <@@ fun a -> a + 1 @@> + // match e.CustomAttributes with + // | [Value((:? (string * int * int * int * int) as tup), t)] -> + // let (file, sl, sc, el, ec) = tup + // failwithf "%A" tup + // | _ -> + // failwith "no debug info" + + ] \ No newline at end of file diff --git a/tests/Main/Fable.Tests.fsproj b/tests/Main/Fable.Tests.fsproj index f1e1842ebb..339271c90b 100644 --- a/tests/Main/Fable.Tests.fsproj +++ b/tests/Main/Fable.Tests.fsproj @@ -66,6 +66,7 @@ + diff --git a/tests/Main/JsInteropTests.fs b/tests/Main/JsInteropTests.fs index 525718da56..af8f77fe54 100644 --- a/tests/Main/JsInteropTests.fs +++ b/tests/Main/JsInteropTests.fs @@ -339,9 +339,9 @@ let tests = 3 |> add 2 |> equal 5 testCase "TypedArray element can be set and get using index" <| fun () -> - let arr = JS.Uint8Array.Create(5) + let arr = JS.Constructors.Uint8Array.Create(5) arr.[0] <- 5uy - equal 5uy arr.[0] + equal 5uy arr.[0] #endif testCase "Pattern matching with StringEnum works" <| fun () -> diff --git a/tests/Main/Main.fs b/tests/Main/Main.fs index e3dd177b0a..2f5f89d299 100644 --- a/tests/Main/Main.fs +++ b/tests/Main/Main.fs @@ -44,6 +44,7 @@ let allTests = TypeTests.tests UnionTypes.tests Uri.tests + Expr.tests |] #if FABLE_COMPILER diff --git a/tests/Main/ReflectionTests.fs b/tests/Main/ReflectionTests.fs index c902557840..4c84ce06e5 100644 --- a/tests/Main/ReflectionTests.fs +++ b/tests/Main/ReflectionTests.fs @@ -23,6 +23,7 @@ type TestType = type TestType2 = | Union2 of string +[] type TestType3 = class end type TestType4 = class end type TestType5 = class end @@ -516,7 +517,42 @@ type MyRecord20 = { FieldA: int FieldB: string } +type MyClass3<'a>(value : 'a) = + static member GetValue<'b>(a : 'a, b : 'b) = (a,b) + member x.Value : 'a = value + let fableTests = [ + testCase "Generic static method can be instantiated and invoked" <| fun () -> + let tm = typedefof>.MakeGenericType [| typeof |] + let meth = tm.GetMethod("GetValue") + let m = meth.MakeGenericMethod [| typeof |] + let pars = m.GetParameters() |> Array.map (fun p -> p.ParameterType, p.Name) + let res = m.Invoke(null, [| 1 :> obj; 2.0 :> obj |]) |> unbox + + res |> equal (1, 2.0) + m.ReturnType |> equal typeof + pars |> equal [| (typeof, "a"); (typeof, "b") |] + + + testCase "Property can be read" <| fun () -> + let tm = typedefof>.MakeGenericType [| typeof |] + let prop = tm.GetProperty("Value") + let v1 = prop.GetMethod.Invoke(MyClass3(1), null) |> unbox + let v2 = prop.GetValue(MyClass3(1)) |> unbox + v1 |> equal 1 + v2 |> equal 1 + + + testCase "Record Property can be read" <| fun () -> + let tm = typeof + let fa = tm.GetProperty("FieldA") + let fb = tm.GetProperty("FieldB") + let r = { FieldA = 10; FieldB = "asdasd"} + let va = fa.GetValue(r) |> unbox + let vb = fb.GetValue(r) |> unbox + va |> equal 10 + vb |> equal "asdasd" + testCase "ITypeResolver can be injected" <| fun () -> let x: R1 = Helper.Make [|box 5|] let y: R2 = Helper.Make [|box 10|] diff --git a/tests/splitter.config.js b/tests/splitter.config.js index c25d2e38c1..a690f23800 100644 --- a/tests/splitter.config.js +++ b/tests/splitter.config.js @@ -12,6 +12,8 @@ function defineConstants() { if (process.argv.find(v => v === "-d:OPTIMIZE_FCS")) { ar.push("OPTIMIZE_FCS"); } + ar.push("FABLE_QUOTATIONS"); + return ar; }