diff --git a/fcs/build.fsx b/fcs/build.fsx index cf0e0d8deda..76a9282d9c0 100644 --- a/fcs/build.fsx +++ b/fcs/build.fsx @@ -31,7 +31,7 @@ let dotnetExePath = if File.Exists(pathToCli) then pathToCli else - DotNetCli.InstallDotNetSDK "2.2.105" + DotNetCli.InstallDotNetSDK "3.0.100" let runDotnet workingDir args = let result = @@ -90,6 +90,10 @@ Target "BuildVersion" (fun _ -> Shell.Exec("appveyor", sprintf "UpdateBuild -Version \"%s\"" buildVersion) |> ignore ) +Target "BuildTools" (fun _ -> + runDotnet __SOURCE_DIRECTORY__ "build ../src/buildtools/buildtools.proj -v n -c Proto" +) + Target "Build" (fun _ -> runDotnet __SOURCE_DIRECTORY__ "build ../src/buildtools/buildtools.proj -v n -c Proto" let fslexPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fslex/Proto/netcoreapp2.1/fslex.dll" @@ -110,6 +114,30 @@ Target "NuGet" (fun _ -> runDotnet __SOURCE_DIRECTORY__ "pack FSharp.Compiler.Service.sln -v n -c Release" ) +Target "CodeGen.Fable" (fun _ -> + let outDir = __SOURCE_DIRECTORY__ + "/fcs-fable/codegen/" + + // build FCS codegen + let fslexPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fslex/Proto/netcoreapp2.1/fslex.dll" + let fsyaccPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fsyacc/Proto/netcoreapp2.1/fsyacc.dll" + runDotnet outDir (sprintf "build -v n /p:FsLexPath=%s /p:FsYaccPath=%s" fslexPath fsyaccPath) + + // run FCS fssrgen (without .resx output, inlining it instead) + runDotnet outDir "run -- ../../../src/fsharp/FSComp.txt FSComp.fs" + runDotnet outDir "run -- ../../../src/fsharp/fsi/FSIstrings.txt FSIstrings.fs" + + // Fable-specific (comment the #line directive as it is not supported) + ["lex.fs"; "pplex.fs"; "illex.fs"; "ilpars.fs"; "pars.fs"; "pppars.fs"] + |> Seq.map (fun fileName -> outDir + fileName) + |> RegexReplaceInFilesWithEncoding @"(? Seq.map (fun fileName -> outDir + fileName) + // |> RegexReplaceInFilesWithEncoding pattern @"inline $0" Text.Encoding.UTF8 +) + Target "GenerateDocsEn" (fun _ -> executeFSIWithArgs "docsrc/tools" "generate.fsx" [] [] |> ignore ) @@ -137,6 +165,10 @@ Target "Release" DoNothing Target "GenerateDocs" DoNothing Target "TestAndNuGet" DoNothing +"Clean" + ==> "BuildTools" + ==> "CodeGen.Fable" + "Start" =?> ("BuildVersion", isAppVeyorBuild) ==> "Restore" diff --git a/fcs/fcs-fable/.gitignore b/fcs/fcs-fable/.gitignore new file mode 100644 index 00000000000..db7b2bd5665 --- /dev/null +++ b/fcs/fcs-fable/.gitignore @@ -0,0 +1,3 @@ +# Codegen +codegen/*.fs +codegen/*.fsi diff --git a/fcs/fcs-fable/FSStrings.fs b/fcs/fcs-fable/FSStrings.fs new file mode 100644 index 00000000000..138696f36bb --- /dev/null +++ b/fcs/fcs-fable/FSStrings.fs @@ -0,0 +1,977 @@ +module internal SR.Resources + +let resources = + dict [ + ( "SeeAlso", + ". See also {0}." + ); + ( "ConstraintSolverTupleDiffLengths", + "The tuples have differing lengths of {0} and {1}" + ); + ( "ConstraintSolverInfiniteTypes", + "The types '{0}' and '{1}' cannot be unified." + ); + ( "ConstraintSolverMissingConstraint", + "A type parameter is missing a constraint '{0}'" + ); + ( "ConstraintSolverTypesNotInEqualityRelation1", + "The unit of measure '{0}' does not match the unit of measure '{1}'" + ); + ( "ConstraintSolverTypesNotInEqualityRelation2", + "The type '{0}' does not match the type '{1}'" + ); + ( "ConstraintSolverTypesNotInSubsumptionRelation", + "The type '{0}' is not compatible with the type '{1}'{2}" + ); + ( "ErrorFromAddingTypeEquation1", + "This expression was expected to have type\n '{1}' \nbut here has type\n '{0}' {2}" + ); + ( "ErrorFromAddingTypeEquation2", + "Type mismatch. Expecting a\n '{0}' \nbut given a\n '{1}' {2}\n" + ); + ( "ErrorFromApplyingDefault1", + "Type constraint mismatch when applying the default type '{0}' for a type inference variable. " + ); + ( "ErrorFromApplyingDefault2", + " Consider adding further type constraints" + ); + ( "ErrorsFromAddingSubsumptionConstraint", + "Type constraint mismatch. The type \n '{0}' \nis not compatible with type\n '{1}' {2}\n" + ); + ( "UpperCaseIdentifierInPattern", + "Uppercase variable identifiers should not generally be used in patterns, and may indicate a misspelt pattern name." + ); + ( "NotUpperCaseConstructor", + "Discriminated union cases and exception labels must be uppercase identifiers" + ); + ( "PossibleOverload", + "Possible overload: '{0}'. {1}." + ); + ( "FunctionExpected", + "This function takes too many arguments, or is used in a context where a function is not expected" + ); + ( "BakedInMemberConstraintName", + "Member constraints with the name '{0}' are given special status by the F# compiler as certain .NET types are implicitly augmented with this member. This may result in runtime failures if you attempt to invoke the member constraint from your own code." + ); + ( "BadEventTransformation", + "A definition to be compiled as a .NET event does not have the expected form. Only property members can be compiled as .NET events." + ); + ( "ParameterlessStructCtor", + "Implicit object constructors for structs must take at least one argument" + ); + ( "InterfaceNotRevealed", + "The type implements the interface '{0}' but this is not revealed by the signature. You should list the interface in the signature, as the interface will be discoverable via dynamic type casts and/or reflection." + ); + ( "TyconBadArgs", + "The type '{0}' expects {1} type argument(s) but is given {2}" + ); + ( "IndeterminateType", + "Lookup on object of indeterminate type based on information prior to this program point. A type annotation may be needed prior to this program point to constrain the type of the object. This may allow the lookup to be resolved." + ); + ( "NameClash1", + "Duplicate definition of {0} '{1}'" + ); + ( "NameClash2", + "The {0} '{1}' can not be defined because the name '{2}' clashes with the {3} '{4}' in this type or module" + ); + ( "Duplicate1", + "Two members called '{0}' have the same signature" + ); + ( "Duplicate2", + "Duplicate definition of {0} '{1}'" + ); + ( "UndefinedName2", + " A construct with this name was found in FSharp.PowerPack.dll, which contains some modules and types that were implicitly referenced in some previous versions of F#. You may need to add an explicit reference to this DLL in order to compile this code." + ); + ( "FieldNotMutable", + "This field is not mutable" + ); + ( "FieldsFromDifferentTypes", + "The fields '{0}' and '{1}' are from different types" + ); + ( "VarBoundTwice", + "'{0}' is bound twice in this pattern" + ); + ( "Recursion", + "A use of the function '{0}' does not match a type inferred elsewhere. The inferred type of the function is\n {1}. \nThe type of the function required at this point of use is\n {2} {3}\nThis error may be due to limitations associated with generic recursion within a 'let rec' collection or within a group of classes. Consider giving a full type signature for the targets of recursive calls including type annotations for both argument and return types." + ); + ( "InvalidRuntimeCoercion", + "Invalid runtime coercion or type test from type {0} to {1}\n{2}" + ); + ( "IndeterminateRuntimeCoercion", + "This runtime coercion or type test from type\n {0} \n to \n {1} \ninvolves an indeterminate type based on information prior to this program point. Runtime type tests are not allowed on some types. Further type annotations are needed." + ); + ( "IndeterminateStaticCoercion", + "The static coercion from type\n {0} \nto \n {1} \n involves an indeterminate type based on information prior to this program point. Static coercions are not allowed on some types. Further type annotations are needed." + ); + ( "StaticCoercionShouldUseBox", + "A coercion from the value type \n {0} \nto the type \n {1} \nwill involve boxing. Consider using 'box' instead" + ); + ( "TypeIsImplicitlyAbstract", + "This type is 'abstract' since some abstract members have not been given an implementation. If this is intentional then add the '[]' attribute to your type." + ); + ( "NonRigidTypar1", + "This construct causes code to be less generic than indicated by its type annotations. The type variable implied by the use of a '#', '_' or other type annotation at or near '{0}' has been constrained to be type '{1}'." + ); + ( "NonRigidTypar2", + "This construct causes code to be less generic than indicated by the type annotations. The unit-of-measure variable '{0} has been constrained to be measure '{1}'." + ); + ( "NonRigidTypar3", + "This construct causes code to be less generic than indicated by the type annotations. The type variable '{0} has been constrained to be type '{1}'." + ); + ( "Parser.TOKEN.IDENT", + "identifier" + ); + ( "Parser.TOKEN.INT", + "integer literal" + ); + ( "Parser.TOKEN.FLOAT", + "floating point literal" + ); + ( "Parser.TOKEN.DECIMAL", + "decimal literal" + ); + ( "Parser.TOKEN.CHAR", + "character literal" + ); + ( "Parser.TOKEN.BASE", + "keyword 'base'" + ); + ( "Parser.TOKEN.LPAREN.STAR.RPAREN", + "symbol '(*)'" + ); + ( "Parser.TOKEN.DOLLAR", + "symbol '$'" + ); + ( "Parser.TOKEN.INFIX.STAR.STAR.OP", + "infix operator" + ); + ( "Parser.TOKEN.INFIX.COMPARE.OP", + "infix operator" + ); + ( "Parser.TOKEN.COLON.GREATER", + "symbol ':>'" + ); + ( "Parser.TOKEN.COLON.COLON", + "symbol '::'" + ); + ( "Parser.TOKEN.PERCENT.OP", + "symbol '{0}" + ); + ( "Parser.TOKEN.INFIX.AT.HAT.OP", + "infix operator" + ); + ( "Parser.TOKEN.INFIX.BAR.OP", + "infix operator" + ); + ( "Parser.TOKEN.PLUS.MINUS.OP", + "infix operator" + ); + ( "Parser.TOKEN.PREFIX.OP", + "prefix operator" + ); + ( "Parser.TOKEN.COLON.QMARK.GREATER", + "symbol ':?>'" + ); + ( "Parser.TOKEN.INFIX.STAR.DIV.MOD.OP", + "infix operator" + ); + ( "Parser.TOKEN.INFIX.AMP.OP", + "infix operator" + ); + ( "Parser.TOKEN.AMP", + "symbol '&'" + ); + ( "Parser.TOKEN.AMP.AMP", + "symbol '&&'" + ); + ( "Parser.TOKEN.BAR.BAR", + "symbol '||'" + ); + ( "Parser.TOKEN.LESS", + "symbol '<'" + ); + ( "Parser.TOKEN.GREATER", + "symbol '>'" + ); + ( "Parser.TOKEN.QMARK", + "symbol '?'" + ); + ( "Parser.TOKEN.QMARK.QMARK", + "symbol '??'" + ); + ( "Parser.TOKEN.COLON.QMARK", + "symbol ':?'" + ); + ( "Parser.TOKEN.INT32.DOT.DOT", + "integer.." + ); + ( "Parser.TOKEN.DOT.DOT", + "symbol '..'" + ); + ( "Parser.TOKEN.QUOTE", + "quote symbol" + ); + ( "Parser.TOKEN.STAR", + "symbol '*'" + ); + ( "Parser.TOKEN.HIGH.PRECEDENCE.TYAPP", + "type application " + ); + ( "Parser.TOKEN.COLON", + "symbol ':'" + ); + ( "Parser.TOKEN.COLON.EQUALS", + "symbol ':='" + ); + ( "Parser.TOKEN.LARROW", + "symbol '<-'" + ); + ( "Parser.TOKEN.EQUALS", + "symbol '='" + ); + ( "Parser.TOKEN.GREATER.BAR.RBRACK", + "symbol '>|]'" + ); + ( "Parser.TOKEN.MINUS", + "symbol '-'" + ); + ( "Parser.TOKEN.ADJACENT.PREFIX.OP", + "prefix operator" + ); + ( "Parser.TOKEN.FUNKY.OPERATOR.NAME", + "operator name" + ); + ( "Parser.TOKEN.COMMA", + "symbol ','" + ); + ( "Parser.TOKEN.DOT", + "symbol '.'" + ); + ( "Parser.TOKEN.BAR", + "symbol '|'" + ); + ( "Parser.TOKEN.HASH", + "symbol #" + ); + ( "Parser.TOKEN.UNDERSCORE", + "symbol '_'" + ); + ( "Parser.TOKEN.SEMICOLON", + "symbol ';'" + ); + ( "Parser.TOKEN.SEMICOLON.SEMICOLON", + "symbol ';;'" + ); + ( "Parser.TOKEN.LPAREN", + "symbol '('" + ); + ( "Parser.TOKEN.RPAREN", + "symbol ')'" + ); + ( "Parser.TOKEN.SPLICE.SYMBOL", + "symbol 'splice'" + ); + ( "Parser.TOKEN.LQUOTE", + "start of quotation" + ); + ( "Parser.TOKEN.LBRACK", + "symbol '['" + ); + ( "Parser.TOKEN.LBRACE.BAR", + "symbol '{|'" + ); + ( "Parser.TOKEN.LBRACK.BAR", + "symbol '[|'" + ); + ( "Parser.TOKEN.LBRACK.LESS", + "symbol '[<'" + ); + ( "Parser.TOKEN.LBRACE", + "symbol '{'" + ); + ( "Parser.TOKEN.LBRACE.LESS", + "symbol '{<'" + ); + ( "Parser.TOKEN.BAR.RBRACK", + "symbol '|]'" + ); + ( "Parser.TOKEN.BAR.RBRACE", + "symbol '|}'" + ); + ( "Parser.TOKEN.GREATER.RBRACE", + "symbol '>}'" + ); + ( "Parser.TOKEN.GREATER.RBRACK", + "symbol '>]'" + ); + ( "Parser.TOKEN.RQUOTE", + "end of quotation" + ); + ( "Parser.TOKEN.RBRACK", + "symbol ']'" + ); + ( "Parser.TOKEN.RBRACE", + "symbol '}'" + ); + ( "Parser.TOKEN.PUBLIC", + "keyword 'public'" + ); + ( "Parser.TOKEN.PRIVATE", + "keyword 'private'" + ); + ( "Parser.TOKEN.INTERNAL", + "keyword 'internal'" + ); + ( "Parser.TOKEN.FIXED", + "keyword 'fixed'" + ); + ( "Parser.TOKEN.CONSTRAINT", + "keyword 'constraint'" + ); + ( "Parser.TOKEN.INSTANCE", + "keyword 'instance'" + ); + ( "Parser.TOKEN.DELEGATE", + "keyword 'delegate'" + ); + ( "Parser.TOKEN.INHERIT", + "keyword 'inherit'" + ); + ( "Parser.TOKEN.CONSTRUCTOR", + "keyword 'constructor'" + ); + ( "Parser.TOKEN.DEFAULT", + "keyword 'default'" + ); + ( "Parser.TOKEN.OVERRIDE", + "keyword 'override'" + ); + ( "Parser.TOKEN.ABSTRACT", + "keyword 'abstract'" + ); + ( "Parser.TOKEN.CLASS", + "keyword 'class'" + ); + ( "Parser.TOKEN.MEMBER", + "keyword 'member'" + ); + ( "Parser.TOKEN.STATIC", + "keyword 'static'" + ); + ( "Parser.TOKEN.NAMESPACE", + "keyword 'namespace'" + ); + ( "Parser.TOKEN.OBLOCKBEGIN", + "start of structured construct" + ); + ( "Parser.TOKEN.OBLOCKEND", + "incomplete structured construct at or before this point" + ); + ( "BlockEndSentence", + "Incomplete structured construct at or before this point" + ); + ( "Parser.TOKEN.OTHEN", + "keyword 'then'" + ); + ( "Parser.TOKEN.OELSE", + "keyword 'else'" + ); + ( "Parser.TOKEN.OLET", + "keyword 'let' or 'use'" + ); + ( "Parser.TOKEN.BINDER", + "binder keyword" + ); + ( "Parser.TOKEN.ODO", + "keyword 'do'" + ); + ( "Parser.TOKEN.CONST", + "keyword 'const'" + ); + ( "Parser.TOKEN.OWITH", + "keyword 'with'" + ); + ( "Parser.TOKEN.OFUNCTION", + "keyword 'function'" + ); + ( "Parser.TOKEN.OFUN", + "keyword 'fun'" + ); + ( "Parser.TOKEN.ORESET", + "end of input" + ); + ( "Parser.TOKEN.ODUMMY", + "internal dummy token" + ); + ( "Parser.TOKEN.ODO.BANG", + "keyword 'do!'" + ); + ( "Parser.TOKEN.YIELD", + "yield" + ); + ( "Parser.TOKEN.YIELD.BANG", + "yield!" + ); + ( "Parser.TOKEN.OINTERFACE.MEMBER", + "keyword 'interface'" + ); + ( "Parser.TOKEN.ELIF", + "keyword 'elif'" + ); + ( "Parser.TOKEN.RARROW", + "symbol '->'" + ); + ( "Parser.TOKEN.SIG", + "keyword 'sig'" + ); + ( "Parser.TOKEN.STRUCT", + "keyword 'struct'" + ); + ( "Parser.TOKEN.UPCAST", + "keyword 'upcast'" + ); + ( "Parser.TOKEN.DOWNCAST", + "keyword 'downcast'" + ); + ( "Parser.TOKEN.NULL", + "keyword 'null'" + ); + ( "Parser.TOKEN.RESERVED", + "reserved keyword" + ); + ( "Parser.TOKEN.MODULE", + "keyword 'module'" + ); + ( "Parser.TOKEN.AND", + "keyword 'and'" + ); + ( "Parser.TOKEN.AS", + "keyword 'as'" + ); + ( "Parser.TOKEN.ASSERT", + "keyword 'assert'" + ); + ( "Parser.TOKEN.ASR", + "keyword 'asr'" + ); + ( "Parser.TOKEN.DOWNTO", + "keyword 'downto'" + ); + ( "Parser.TOKEN.EXCEPTION", + "keyword 'exception'" + ); + ( "Parser.TOKEN.FALSE", + "keyword 'false'" + ); + ( "Parser.TOKEN.FOR", + "keyword 'for'" + ); + ( "Parser.TOKEN.FUN", + "keyword 'fun'" + ); + ( "Parser.TOKEN.FUNCTION", + "keyword 'function'" + ); + ( "Parser.TOKEN.FINALLY", + "keyword 'finally'" + ); + ( "Parser.TOKEN.LAZY", + "keyword 'lazy'" + ); + ( "Parser.TOKEN.MATCH", + "keyword 'match'" + ); + ( "Parser.TOKEN.MATCH.BANG", + "keyword 'match!'" + ); + ( "Parser.TOKEN.MUTABLE", + "keyword 'mutable'" + ); + ( "Parser.TOKEN.NEW", + "keyword 'new'" + ); + ( "Parser.TOKEN.OF", + "keyword 'of'" + ); + ( "Parser.TOKEN.OPEN", + "keyword 'open'" + ); + ( "Parser.TOKEN.OR", + "keyword 'or'" + ); + ( "Parser.TOKEN.VOID", + "keyword 'void'" + ); + ( "Parser.TOKEN.EXTERN", + "keyword 'extern'" + ); + ( "Parser.TOKEN.INTERFACE", + "keyword 'interface'" + ); + ( "Parser.TOKEN.REC", + "keyword 'rec'" + ); + ( "Parser.TOKEN.TO", + "keyword 'to'" + ); + ( "Parser.TOKEN.TRUE", + "keyword 'true'" + ); + ( "Parser.TOKEN.TRY", + "keyword 'try'" + ); + ( "Parser.TOKEN.TYPE", + "keyword 'type'" + ); + ( "Parser.TOKEN.VAL", + "keyword 'val'" + ); + ( "Parser.TOKEN.INLINE", + "keyword 'inline'" + ); + ( "Parser.TOKEN.WHEN", + "keyword 'when'" + ); + ( "Parser.TOKEN.WHILE", + "keyword 'while'" + ); + ( "Parser.TOKEN.WITH", + "keyword 'with'" + ); + ( "Parser.TOKEN.IF", + "keyword 'if'" + ); + ( "Parser.TOKEN.DO", + "keyword 'do'" + ); + ( "Parser.TOKEN.GLOBAL", + "keyword 'global'" + ); + ( "Parser.TOKEN.DONE", + "keyword 'done'" + ); + ( "Parser.TOKEN.IN", + "keyword 'in'" + ); + ( "Parser.TOKEN.HIGH.PRECEDENCE.PAREN.APP", + "symbol '('" + ); + ( "Parser.TOKEN.HIGH.PRECEDENCE.BRACK.APP", + "symbol'['" + ); + ( "Parser.TOKEN.BEGIN", + "keyword 'begin'" + ); + ( "Parser.TOKEN.END", + "keyword 'end'" + ); + ( "Parser.TOKEN.HASH.ENDIF", + "directive" + ); + ( "Parser.TOKEN.INACTIVECODE", + "inactive code" + ); + ( "Parser.TOKEN.LEX.FAILURE", + "lex failure" + ); + ( "Parser.TOKEN.WHITESPACE", + "whitespace" + ); + ( "Parser.TOKEN.COMMENT", + "comment" + ); + ( "Parser.TOKEN.LINE.COMMENT", + "line comment" + ); + ( "Parser.TOKEN.STRING.TEXT", + "string text" + ); + ( "Parser.TOKEN.KEYWORD_STRING", + "compiler generated literal" + ); + ( "Parser.TOKEN.BYTEARRAY", + "byte array literal" + ); + ( "Parser.TOKEN.STRING", + "string literal" + ); + ( "Parser.TOKEN.EOF", + "end of input" + ); + ( "UnexpectedEndOfInput", + "Unexpected end of input" + ); + ( "Unexpected", + "Unexpected {0}" + ); + ( "NONTERM.interaction", + " in interaction" + ); + ( "NONTERM.hashDirective", + " in directive" + ); + ( "NONTERM.fieldDecl", + " in field declaration" + ); + ( "NONTERM.unionCaseRepr", + " in discriminated union case declaration" + ); + ( "NONTERM.localBinding", + " in binding" + ); + ( "NONTERM.hardwhiteLetBindings", + " in binding" + ); + ( "NONTERM.classDefnMember", + " in member definition" + ); + ( "NONTERM.defnBindings", + " in definitions" + ); + ( "NONTERM.classMemberSpfn", + " in member signature" + ); + ( "NONTERM.valSpfn", + " in value signature" + ); + ( "NONTERM.tyconSpfn", + " in type signature" + ); + ( "NONTERM.anonLambdaExpr", + " in lambda expression" + ); + ( "NONTERM.attrUnionCaseDecl", + " in union case" + ); + ( "NONTERM.cPrototype", + " in extern declaration" + ); + ( "NONTERM.objectImplementationMembers", + " in object expression" + ); + ( "NONTERM.ifExprCases", + " in if/then/else expression" + ); + ( "NONTERM.openDecl", + " in open declaration" + ); + ( "NONTERM.fileModuleSpec", + " in module or namespace signature" + ); + ( "NONTERM.patternClauses", + " in pattern matching" + ); + ( "NONTERM.beginEndExpr", + " in begin/end expression" + ); + ( "NONTERM.recdExpr", + " in record expression" + ); + ( "NONTERM.tyconDefn", + " in type definition" + ); + ( "NONTERM.exconCore", + " in exception definition" + ); + ( "NONTERM.typeNameInfo", + " in type name" + ); + ( "NONTERM.attributeList", + " in attribute list" + ); + ( "NONTERM.quoteExpr", + " in quotation literal" + ); + ( "NONTERM.typeConstraint", + " in type constraint" + ); + ( "NONTERM.Category.ImplementationFile", + " in implementation file" + ); + ( "NONTERM.Category.Definition", + " in definition" + ); + ( "NONTERM.Category.SignatureFile", + " in signature file" + ); + ( "NONTERM.Category.Pattern", + " in pattern" + ); + ( "NONTERM.Category.Expr", + " in expression" + ); + ( "NONTERM.Category.Type", + " in type" + ); + ( "NONTERM.typeArgsActual", + " in type arguments" + ); + ( "FixKeyword", + "keyword " + ); + ( "FixSymbol", + "symbol " + ); + ( "FixReplace", + " (due to indentation-aware syntax)" + ); + ( "TokenName1", + ". Expected {0} or other token." + ); + ( "TokenName1TokenName2", + ". Expected {0}, {1} or other token." + ); + ( "TokenName1TokenName2TokenName3", + ". Expected {0}, {1}, {2} or other token." + ); + ( "RuntimeCoercionSourceSealed1", + "The type '{0}' cannot be used as the source of a type test or runtime coercion" + ); + ( "RuntimeCoercionSourceSealed2", + "The type '{0}' does not have any proper subtypes and cannot be used as the source of a type test or runtime coercion." + ); + ( "CoercionTargetSealed", + "The type '{0}' does not have any proper subtypes and need not be used as the target of a static coercion" + ); + ( "UpcastUnnecessary", + "This upcast is unnecessary - the types are identical" + ); + ( "TypeTestUnnecessary", + "This type test or downcast will always hold" + ); + ( "OverrideDoesntOverride1", + "The member '{0}' does not have the correct type to override any given virtual method" + ); + ( "OverrideDoesntOverride2", + "The member '{0}' does not have the correct type to override the corresponding abstract method." + ); + ( "OverrideDoesntOverride3", + " The required signature is '{0}'." + ); + ( "OverrideDoesntOverride4", + "The member '{0}' is specialized with 'unit' but 'unit' can't be used as return type of an abstract method parameterized on return type." + ); + ( "UnionCaseWrongArguments", + "This constructor is applied to {0} argument(s) but expects {1}" + ); + ( "UnionPatternsBindDifferentNames", + "The two sides of this 'or' pattern bind different sets of variables" + ); + ( "ValueNotContained", + "Module '{0}' contains\n {1} \nbut its signature specifies\n {2} \n{3}." + ); + ( "RequiredButNotSpecified", + "Module '{0}' requires a {1} '{2}'" + ); + ( "UseOfAddressOfOperator", + "The use of native pointers may result in unverifiable .NET IL code" + ); + ( "DefensiveCopyWarning", + "{0}" + ); + ( "DeprecatedThreadStaticBindingWarning", + "Thread static and context static 'let' bindings are deprecated. Instead use a declaration of the form 'static val mutable : ' in a class. Add the 'DefaultValue' attribute to this declaration to indicate that the value is initialized to the default value on each new thread." + ); + ( "FunctionValueUnexpected", + "This expression is a function value, i.e. is missing arguments. Its type is {0}." + ); + ( "UnitTypeExpected", + "The result of this expression has type '{0}' and is implicitly ignored. Consider using 'ignore' to discard this value explicitly, e.g. 'expr |> ignore', or 'let' to bind the result to a name, e.g. 'let result = expr'." + ); + ( "UnitTypeExpectedWithEquality", + "The result of this equality expression has type '{0}' and is implicitly discarded. Consider using 'let' to bind the result to a name, e.g. 'let result = expression'." + ); + ( "UnitTypeExpectedWithPossiblePropertySetter", + "The result of this equality expression has type '{0}' and is implicitly discarded. Consider using 'let' to bind the result to a name, e.g. 'let result = expression'. If you intended to set a value to a property, then use the '<-' operator e.g. '{1}.{2} <- expression'." + ); + ( "UnitTypeExpectedWithPossibleAssignment", + "The result of this equality expression has type '{0}' and is implicitly discarded. Consider using 'let' to bind the result to a name, e.g. 'let result = expression'. If you intended to mutate a value, then mark the value 'mutable' and use the '<-' operator e.g. '{1} <- expression'." + ); + ( "UnitTypeExpectedWithPossibleAssignmentToMutable", + "The result of this equality expression has type '{0}' and is implicitly discarded. Consider using 'let' to bind the result to a name, e.g. 'let result = expression'. If you intended to mutate a value, then use the '<-' operator e.g. '{1} <- expression'." + ); + ( "RecursiveUseCheckedAtRuntime", + "This recursive use will be checked for initialization-soundness at runtime. This warning is usually harmless, and may be suppressed by using '#nowarn \"21\"' or '--nowarn:21'." + ); + ( "LetRecUnsound1", + "The value '{0}' will be evaluated as part of its own definition" + ); + ( "LetRecUnsound2", + "This value will be eventually evaluated as part of its own definition. You may need to make the value lazy or a function. Value '{0}'{1}." + ); + ( "LetRecUnsoundInner", + " will evaluate '{0}'" + ); + ( "LetRecEvaluatedOutOfOrder", + "Bindings may be executed out-of-order because of this forward reference." + ); + ( "LetRecCheckedAtRuntime", + "This and other recursive references to the object(s) being defined will be checked for initialization-soundness at runtime through the use of a delayed reference. This is because you are defining one or more recursive objects, rather than recursive functions. This warning may be suppressed by using '#nowarn \"40\"' or '--nowarn:40'." + ); + ( "SelfRefObjCtor1", + "Recursive references to the object being defined will be checked for initialization soundness at runtime through the use of a delayed reference. Consider placing self-references in members or within a trailing expression of the form ' then '." + ); + ( "SelfRefObjCtor2", + "Recursive references to the object being defined will be checked for initialization soundness at runtime through the use of a delayed reference. Consider placing self-references within 'do' statements after the last 'let' binding in the construction sequence." + ); + ( "VirtualAugmentationOnNullValuedType", + "The containing type can use 'null' as a representation value for its nullary union case. Invoking an abstract or virtual member or an interface implementation on a null value will lead to an exception. If necessary add a dummy data value to the nullary constructor to avoid 'null' being used as a representation for this type." + ); + ( "NonVirtualAugmentationOnNullValuedType", + "The containing type can use 'null' as a representation value for its nullary union case. This member will be compiled as a static member." + ); + ( "NonUniqueInferredAbstractSlot1", + "The member '{0}' doesn't correspond to a unique abstract slot based on name and argument count alone" + ); + ( "NonUniqueInferredAbstractSlot2", + ". Multiple implemented interfaces have a member with this name and argument count" + ); + ( "NonUniqueInferredAbstractSlot3", + ". Consider implementing interfaces '{0}' and '{1}' explicitly." + ); + ( "NonUniqueInferredAbstractSlot4", + ". Additional type annotations may be required to indicate the relevant override. This warning can be disabled using '#nowarn \"70\"' or '--nowarn:70'." + ); + ( "Failure1", + "parse error" + ); + ( "Failure2", + "parse error: unexpected end of file" + ); + ( "Failure3", + "{0}" + ); + ( "Failure4", + "internal error: {0}" + ); + ( "FullAbstraction", + "{0}" + ); + ( "MatchIncomplete1", + "Incomplete pattern matches on this expression." + ); + ( "MatchIncomplete2", + " For example, the value '{0}' may indicate a case not covered by the pattern(s)." + ); + ( "MatchIncomplete3", + " For example, the value '{0}' may indicate a case not covered by the pattern(s). However, a pattern rule with a 'when' clause might successfully match this value." + ); + ( "MatchIncomplete4", + " Unmatched elements will be ignored." + ); + ( "EnumMatchIncomplete1", + "Enums may take values outside known cases." + ); + ( "RuleNeverMatched", + "This rule will never be matched" + ); + ( "ValNotMutable", + "This value is not mutable. Consider using the mutable keyword, e.g. 'let mutable {0} = expression'." + ); + ( "ValNotLocal", + "This value is not local" + ); + ( "Obsolete1", + "This construct is deprecated" + ); + ( "Obsolete2", + ". {0}" + ); + ( "Experimental", + "{0}. This warning can be disabled using '--nowarn:57' or '#nowarn \"57\"'." + ); + ( "PossibleUnverifiableCode", + "Uses of this construct may result in the generation of unverifiable .NET IL code. This warning can be disabled using '--nowarn:9' or '#nowarn \"9\"'." + ); + ( "Deprecated", + "This construct is deprecated: {0}" + ); + ( "LibraryUseOnly", + "This construct is deprecated: it is only for use in the F# library" + ); + ( "MissingFields", + "The following fields require values: {0}" + ); + ( "ValueRestriction1", + "Value restriction. The value '{0}' has generic type\n {1} \nEither make the arguments to '{2}' explicit or, if you do not intend for it to be generic, add a type annotation." + ); + ( "ValueRestriction2", + "Value restriction. The value '{0}' has generic type\n {1} \nEither make '{2}' into a function with explicit arguments or, if you do not intend for it to be generic, add a type annotation." + ); + ( "ValueRestriction3", + "Value restriction. This member has been inferred to have generic type\n {0} \nConstructors and property getters/setters cannot be more generic than the enclosing type. Add a type annotation to indicate the exact types involved." + ); + ( "ValueRestriction4", + "Value restriction. The value '{0}' has been inferred to have generic type\n {1} \nEither make the arguments to '{2}' explicit or, if you do not intend for it to be generic, add a type annotation." + ); + ( "ValueRestriction5", + "Value restriction. The value '{0}' has been inferred to have generic type\n {1} \nEither define '{2}' as a simple data term, make it a function with explicit arguments or, if you do not intend for it to be generic, add a type annotation." + ); + ( "RecoverableParseError", + "syntax error" + ); + ( "ReservedKeyword", + "{0}" + ); + ( "IndentationProblem", + "{0}" + ); + ( "OverrideInIntrinsicAugmentation", + "Override implementations in augmentations are now deprecated. Override implementations should be given as part of the initial declaration of a type." + ); + ( "OverrideInExtrinsicAugmentation", + "Override implementations should be given as part of the initial declaration of a type." + ); + ( "IntfImplInIntrinsicAugmentation", + "Interface implementations in augmentations are now deprecated. Interface implementations should be given on the initial declaration of a type." + ); + ( "IntfImplInExtrinsicAugmentation", + "Interface implementations should be given on the initial declaration of a type." + ); + ( "UnresolvedReferenceNoRange", + "A required assembly reference is missing. You must add a reference to assembly '{0}'." + ); + ( "UnresolvedPathReferenceNoRange", + "The type referenced through '{0}' is defined in an assembly that is not referenced. You must add a reference to assembly '{1}'." + ); + ( "HashIncludeNotAllowedInNonScript", + "#I directives may only occur in F# script files (extensions .fsx or .fsscript). Either move this code to a script file, add a '-I' compiler option for this reference or delimit the directive with delimit it with '#if INTERACTIVE'/'#endif'." + ); + ( "HashReferenceNotAllowedInNonScript", + "#r directives may only occur in F# script files (extensions .fsx or .fsscript). Either move this code to a script file or replace this reference with the '-r' compiler option. If this directive is being executed as user input, you may delimit it with '#if INTERACTIVE'/'#endif'." + ); + ( "HashDirectiveNotAllowedInNonScript", + "This directive may only be used in F# script files (extensions .fsx or .fsscript). Either remove the directive, move this code to a script file or delimit the directive with '#if INTERACTIVE'/'#endif'." + ); + ( "FileNameNotResolved", + "Unable to find the file '{0}' in any of\n {1}" + ); + ( "AssemblyNotResolved", + "Assembly reference '{0}' was not found or is invalid" + ); + ( "HashLoadedSourceHasIssues1", + "One or more warnings in loaded file.\n" + ); + ( "HashLoadedSourceHasIssues2", + "One or more errors in loaded file.\n" + ); + ( "HashLoadedScriptConsideredSource", + "Loaded files may only be F# source files (extension .fs). This F# script file (.fsx or .fsscript) will be treated as an F# source file" + ); + ( "InvalidInternalsVisibleToAssemblyName1", + "Invalid assembly name '{0}' from InternalsVisibleTo attribute in {1}" + ); + ( "InvalidInternalsVisibleToAssemblyName2", + "Invalid assembly name '{0}' from InternalsVisibleTo attribute (assembly filename not available)" + ); + ( "LoadedSourceNotFoundIgnoring", + "Could not load file '{0}' because it does not exist or is inaccessible" + ); + ( "MSBuildReferenceResolutionError", + "{0} (Code={1})" + ); + ( "TargetInvocationExceptionWrapper", + "internal error: {0}" + ); + ] \ No newline at end of file diff --git a/fcs/fcs-fable/SR.fs b/fcs/fcs-fable/SR.fs new file mode 100644 index 00000000000..39ca804f113 --- /dev/null +++ b/fcs/fcs-fable/SR.fs @@ -0,0 +1,28 @@ +//------------------------------------------------------------------------ +// From SR.fs +//------------------------------------------------------------------------ + +namespace FSharp.Compiler + +module SR = + let GetString(name: string) = + match SR.Resources.resources.TryGetValue(name) with + | true, value -> value + | _ -> "Missing FSStrings error message for: " + name + +module DiagnosticMessage = + type ResourceString<'T>(sfmt: string, fmt: string) = + member x.Format = + let a = fmt.Split('%') + |> Array.filter (fun s -> String.length s > 0) + |> Array.map (fun s -> box("%" + s)) + let tmp = System.String.Format(sfmt, a) + let fmt = Printf.StringFormat<'T>(tmp) + sprintf fmt + + let postProcessString (s: string) = + s.Replace("\\n","\n").Replace("\\t","\t") + + let DeclareResourceString (messageID: string, fmt: string) = + let messageString = SR.GetString(messageID) |> postProcessString + ResourceString<'T>(messageString, fmt) diff --git a/fcs/fcs-fable/System.Collections.Concurrent.fs b/fcs/fcs-fable/System.Collections.Concurrent.fs new file mode 100644 index 00000000000..50db210f7d3 --- /dev/null +++ b/fcs/fcs-fable/System.Collections.Concurrent.fs @@ -0,0 +1,70 @@ +//------------------------------------------------------------------------ +// shims for things not yet implemented in Fable +//------------------------------------------------------------------------ + +namespace System.Collections.Concurrent + +open System.Collections.Generic + +/// not actually thread safe, just an extension of Dictionary +type ConcurrentDictionary<'Key, 'Value when 'Key: equality>(comparer: IEqualityComparer<'Key>) = + inherit Dictionary<'Key, 'Value>(comparer) + + new () = + let comparer = { + new IEqualityComparer<'Key> with + member __.GetHashCode(x) = x.GetHashCode() + member __.Equals(x, y) = x.Equals(y) } + ConcurrentDictionary(comparer) + + new (_concurrencyLevel: int, _capacity: int) = + ConcurrentDictionary() + new (_concurrencyLevel: int, comparer: IEqualityComparer<'Key>) = + ConcurrentDictionary(comparer) + new (_concurrencyLevel: int, _capacity: int, comparer: IEqualityComparer<'Key>) = + ConcurrentDictionary(comparer) + + member x.TryAdd (key: 'Key, value: 'Value): bool = + if x.ContainsKey(key) + then false + else x.Add(key, value); true + + member x.TryRemove (key: 'Key): bool * 'Value = + match x.TryGetValue(key) with + | true, v -> (x.Remove(key), v) + | _ as res -> res + + member x.GetOrAdd (key: 'Key, valueFactory: 'Key -> 'Value): 'Value = + match x.TryGetValue(key) with + | true, v -> v + | _ -> let v = valueFactory(key) in x.Add(key, v); v + + // member x.GetOrAdd (key: 'Key, value: 'Value): 'Value = + // match x.TryGetValue(key) with + // | true, v -> v + // | _ -> let v = value in x.Add(key, v); v + + // member x.GetOrAdd<'Arg> (key: 'Key, valueFactory: 'Key * 'Arg -> 'Value, arg: 'Arg): 'Value = + // match x.TryGetValue(key) with + // | true, v -> v + // | _ -> let v = valueFactory(key, arg) in x.Add(key, v); v + + // member x.TryUpdate (key: 'Key, value: 'Value, comparisonValue: 'Value): bool = + // match x.TryGetValue(key) with + // | true, v when v = comparisonValue -> x.[key] <- value; true + // | _ -> false + + // member x.AddOrUpdate (key: 'Key, value: 'Value, updateFactory: 'Key * 'Value -> 'Value): 'Value = + // match x.TryGetValue(key) with + // | true, v -> let v = updateFactory(key, v) in x.[key] <- v; v + // | _ -> let v = value in x.Add(key, v); v + + // member x.AddOrUpdate (key: 'Key, valueFactory: 'Key -> 'Value, updateFactory: 'Key * 'Value -> 'Value): 'Value = + // match x.TryGetValue(key) with + // | true, v -> let v = updateFactory(key, v) in x.[key] <- v; v + // | _ -> let v = valueFactory(key) in x.Add(key, v); v + + // member x.AddOrUpdate (key: 'Key, valueFactory: 'Key * 'Arg -> 'Value, updateFactory: 'Key * 'Arg * 'Value -> 'Value, arg: 'Arg): 'Value = + // match x.TryGetValue(key) with + // | true, v -> let v = updateFactory(key, arg, v) in x.[key] <- v; v + // | _ -> let v = valueFactory(key, arg) in x.Add(key, v); v diff --git a/fcs/fcs-fable/System.Collections.Generic.fs b/fcs/fcs-fable/System.Collections.Generic.fs new file mode 100644 index 00000000000..7b7d06cc6c6 --- /dev/null +++ b/fcs/fcs-fable/System.Collections.Generic.fs @@ -0,0 +1,18 @@ +//------------------------------------------------------------------------ +// shims for things not yet implemented in Fable +//------------------------------------------------------------------------ + +namespace System.Collections.Generic + +type Queue<'T> = + inherit List<'T> + + new () = Queue() + + member x.Enqueue (item: 'T) = + x.Add(item) + + member x.Dequeue () = + let item = x.Item(0) + x.RemoveAt(0) + item diff --git a/fcs/fcs-fable/System.IO.fs b/fcs/fcs-fable/System.IO.fs new file mode 100644 index 00000000000..3e37869f7e2 --- /dev/null +++ b/fcs/fcs-fable/System.IO.fs @@ -0,0 +1,56 @@ +//------------------------------------------------------------------------ +// shims for things not yet implemented in Fable +//------------------------------------------------------------------------ + +namespace System.IO + +module Path = + let Combine (path1: string, path2: string) = //TODO: proper xplat implementation + let path1 = + if (String.length path1) = 0 then path1 + else (path1.TrimEnd [|'\\';'/'|]) + "/" + path1 + (path2.TrimStart [|'\\';'/'|]) + + let ChangeExtension (path: string, ext: string) = + let i = path.LastIndexOf(".") + if i < 0 then path + else path.Substring(0, i) + ext + + let HasExtension (path: string) = + let i = path.LastIndexOf(".") + i >= 0 + + let GetExtension (path: string) = + let i = path.LastIndexOf(".") + if i < 0 then "" + else path.Substring(i) + + let GetInvalidPathChars () = //TODO: proper xplat implementation + Seq.toArray "<>\"|?*\b\t" + + let GetInvalidFileNameChars () = //TODO: proper xplat implementation + Seq.toArray "<>:\"|\\/?*\b\t" + + let GetFileName (path: string) = + let normPath = path.Replace("\\", "/").TrimEnd('/') + let i = normPath.LastIndexOf("/") + normPath.Substring(i + 1) + + let GetFileNameWithoutExtension (path: string) = + let filename = GetFileName path + let i = filename.LastIndexOf(".") + if i < 0 then filename + else filename.Substring(0, i) + + let GetDirectoryName (path: string) = //TODO: proper xplat implementation + let normPath = path.Replace("\\", "/") + let i = normPath.LastIndexOf("/") + if i <= 0 then "" + else normPath.Substring(0, i) + + let IsPathRooted (path: string) = //TODO: proper xplat implementation + let normPath = path.Replace("\\", "/").TrimEnd('/') + normPath.StartsWith("/") + + let DirectorySeparatorChar = '/' + let AltDirectorySeparatorChar = '/' diff --git a/fcs/fcs-fable/System.fs b/fcs/fcs-fable/System.fs new file mode 100644 index 00000000000..a0bf5606eb5 --- /dev/null +++ b/fcs/fcs-fable/System.fs @@ -0,0 +1,29 @@ +//------------------------------------------------------------------------ +// shims for things not yet implemented in Fable +//------------------------------------------------------------------------ + +namespace System + +module Diagnostics = + type Trace() = + static member TraceInformation(_s) = () //TODO: proper implementation + +module Reflection = + type AssemblyName(assemblyName: string) = + member x.Name = assemblyName //TODO: proper implementation + +type WeakReference<'T>(v: 'T) = + member x.TryGetTarget () = (true, v) + +type StringComparer(comp: System.StringComparison) = + static member Ordinal = StringComparer(System.StringComparison.Ordinal) + static member OrdinalIgnoreCase = StringComparer(System.StringComparison.OrdinalIgnoreCase) + interface System.Collections.Generic.IEqualityComparer with + member x.Equals(a,b) = System.String.Compare(a, b, comp) = 0 + member x.GetHashCode(a) = + match comp with + | System.StringComparison.Ordinal -> hash a + | System.StringComparison.OrdinalIgnoreCase -> hash (a.ToLowerInvariant()) + | _ -> failwithf "Unsupported StringComparison: %A" comp + interface System.Collections.Generic.IComparer with + member x.Compare(a,b) = System.String.Compare(a, b, comp) diff --git a/fcs/fcs-fable/TcImports_shim.fs b/fcs/fcs-fable/TcImports_shim.fs new file mode 100644 index 00000000000..767448a4f82 --- /dev/null +++ b/fcs/fcs-fable/TcImports_shim.fs @@ -0,0 +1,271 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +// Open up the compiler as an incremental service for parsing, +// type checking and intellisense-like environment-reporting. + +namespace FSharp.Compiler.SourceCodeServices + +open System +open System.Collections.Generic +open System.Collections.Concurrent +open System.Diagnostics +open System.IO +open System.Reflection +open System.Text + +open Microsoft.FSharp.Core.Printf +open FSharp.Compiler +open FSharp.Compiler.AbstractIL +open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.AbstractIL.ILBinaryReader +open FSharp.Compiler.AbstractIL.Diagnostics +open FSharp.Compiler.AbstractIL.Internal +open FSharp.Compiler.AbstractIL.Internal.Library + +open FSharp.Compiler.AccessibilityLogic +open FSharp.Compiler.Ast +open FSharp.Compiler.CompileOps +open FSharp.Compiler.CompileOptions +#if !FABLE_COMPILER +open FSharp.Compiler.Driver +#endif +open FSharp.Compiler.ErrorLogger +open FSharp.Compiler.Lib +open FSharp.Compiler.PrettyNaming +open FSharp.Compiler.Parser +open FSharp.Compiler.Range +open FSharp.Compiler.Lexhelp +open FSharp.Compiler.Layout +open FSharp.Compiler.Tast +open FSharp.Compiler.Tastops +open FSharp.Compiler.TcGlobals +open FSharp.Compiler.Infos +open FSharp.Compiler.InfoReader +open FSharp.Compiler.NameResolution +open FSharp.Compiler.TypeChecker +open FSharp.Compiler.SourceCodeServices.SymbolHelpers + +open Internal.Utilities +open Internal.Utilities.Collections +open FSharp.Compiler.Layout.TaggedTextOps + + +//------------------------------------------------------------------------- +// TcImports shim +//------------------------------------------------------------------------- + +module TcImports = + + let internal BuildTcImports (tcConfig: TcConfig, references: string[], readAllBytes: string -> byte[]) = + let tcImports = TcImports () + let ilGlobals = IL.EcmaMscorlibILGlobals + + let sigDataReaders ilModule = + [ for resource in ilModule.Resources.AsList do + if IsSignatureDataResource resource then + let _ccuName = GetSignatureDataResourceName resource + yield resource.GetBytes() ] + + let optDataReaders ilModule = + [ for resource in ilModule.Resources.AsList do + if IsOptimizationDataResource resource then + let _ccuName = GetOptimizationDataResourceName resource + yield resource.GetBytes() ] + + let LoadMod (ccuName: string) = + let fileName = + if ccuName.EndsWith(".dll", StringComparison.OrdinalIgnoreCase) + then ccuName + else ccuName + ".dll" + let bytes = readAllBytes fileName + let opts: ILReaderOptions = + { ilGlobals = ilGlobals + metadataOnly = MetadataOnlyFlag.Yes + reduceMemoryUsage = ReduceMemoryFlag.Yes + pdbDirPath = None + tryGetMetadataSnapshot = (fun _ -> None) } + + let reader = ILBinaryReader.OpenILModuleReaderFromBytes fileName bytes opts + reader.ILModuleDef //reader.ILAssemblyRefs + + let GetSignatureData (fileName:string, ilScopeRef, ilModule:ILModuleDef option, bytes:byte[]) = + TastPickle.unpickleObjWithDanglingCcus fileName ilScopeRef ilModule TastPickle.unpickleCcuInfo bytes + + let GetOptimizationData (fileName:string, ilScopeRef, ilModule:ILModuleDef option, bytes:byte[]) = + TastPickle.unpickleObjWithDanglingCcus fileName ilScopeRef ilModule Optimizer.u_CcuOptimizationInfo bytes + + let memoize_mod = new MemoizationTable<_,_> (LoadMod, keyComparer=HashIdentity.Structural) + + let LoadSigData ccuName = + let ilModule = memoize_mod.Apply ccuName + let ilShortAssemName = ilModule.ManifestOfAssembly.Name + let ilScopeRef = ILScopeRef.Assembly (mkSimpleAssemblyRef ilShortAssemName) + let fileName = ilModule.Name //TODO: try with ".sigdata" extension + match sigDataReaders ilModule with + | [] -> None + | bytes::_ -> Some (GetSignatureData (fileName, ilScopeRef, Some ilModule, bytes)) + + let LoadOptData ccuName = + let ilModule = memoize_mod.Apply ccuName + let ilShortAssemName = ilModule.ManifestOfAssembly.Name + let ilScopeRef = ILScopeRef.Assembly (mkSimpleAssemblyRef ilShortAssemName) + let fileName = ilModule.Name //TODO: try with ".optdata" extension + match optDataReaders ilModule with + | [] -> None + | bytes::_ -> Some (GetOptimizationData (fileName, ilScopeRef, Some ilModule, bytes)) + + let memoize_sig = new MemoizationTable<_,_> (LoadSigData, keyComparer=HashIdentity.Structural) + let memoize_opt = new MemoizationTable<_,_> (LoadOptData, keyComparer=HashIdentity.Structural) + + let GetCustomAttributesOfIlModule (ilModule: ILModuleDef) = + (match ilModule.Manifest with Some m -> m.CustomAttrs | None -> ilModule.CustomAttrs).AsList + + let GetAutoOpenAttributes ilg ilModule = + ilModule |> GetCustomAttributesOfIlModule |> List.choose (TryFindAutoOpenAttr ilg) + + let GetInternalsVisibleToAttributes ilg ilModule = + ilModule |> GetCustomAttributesOfIlModule |> List.choose (TryFindInternalsVisibleToAttr ilg) + + let HasAnyFSharpSignatureDataAttribute ilModule = + let attrs = GetCustomAttributesOfIlModule ilModule + List.exists IsSignatureDataVersionAttr attrs + + let mkCcuInfo ilg ilScopeRef ilModule ccu : ImportedAssembly = + { ILScopeRef = ilScopeRef + FSharpViewOfMetadata = ccu + AssemblyAutoOpenAttributes = GetAutoOpenAttributes ilg ilModule + AssemblyInternalsVisibleToAttributes = GetInternalsVisibleToAttributes ilg ilModule +#if !NO_EXTENSIONTYPING + IsProviderGenerated = false + TypeProviders = [] +#endif + FSharpOptimizationData = notlazy None } + + let GetCcuIL m ccuName = + let auxModuleLoader = function + | ILScopeRef.Local -> failwith "Unsupported reference" + | ILScopeRef.Module x -> memoize_mod.Apply x.Name + | ILScopeRef.Assembly x -> memoize_mod.Apply x.Name + let ilModule = memoize_mod.Apply ccuName + let ilShortAssemName = ilModule.ManifestOfAssembly.Name + let ilScopeRef = ILScopeRef.Assembly (mkSimpleAssemblyRef ilShortAssemName) + let fileName = ilModule.Name + let invalidateCcu = new Event<_>() + let ccu = Import.ImportILAssembly( + tcImports.GetImportMap, m, auxModuleLoader, ilScopeRef, + tcConfig.implicitIncludeDir, Some fileName, ilModule, invalidateCcu.Publish) + let ccuInfo = mkCcuInfo ilGlobals ilScopeRef ilModule ccu + ccuInfo, None + + let GetCcuFS m ccuName = + let sigdata = memoize_sig.Apply ccuName + let ilModule = memoize_mod.Apply ccuName + let ilShortAssemName = ilModule.ManifestOfAssembly.Name + let ilScopeRef = ILScopeRef.Assembly (mkSimpleAssemblyRef ilShortAssemName) + let fileName = ilModule.Name + let GetRawTypeForwarders ilModule = + match ilModule.Manifest with + | Some manifest -> manifest.ExportedTypes + | None -> mkILExportedTypes [] +#if !NO_EXTENSIONTYPING + let invalidateCcu = new Event<_>() +#endif + let minfo: PickledCcuInfo = sigdata.Value.RawData //TODO: handle missing sigdata + let codeDir = minfo.compileTimeWorkingDir + let ccuData: CcuData = + { ILScopeRef = ilScopeRef + Stamp = newStamp() + FileName = Some fileName + QualifiedName = Some (ilScopeRef.QualifiedName) + SourceCodeDirectory = codeDir + IsFSharp = true + Contents = minfo.mspec +#if !NO_EXTENSIONTYPING + InvalidateEvent=invalidateCcu.Publish + IsProviderGenerated = false + ImportProvidedType = (fun ty -> Import.ImportProvidedType (tcImports.GetImportMap()) m ty) +#endif + UsesFSharp20PlusQuotations = minfo.usesQuotations + MemberSignatureEquality = (fun ty1 ty2 -> Tastops.typeEquivAux EraseAll (tcImports.GetTcGlobals()) ty1 ty2) + TryGetILModuleDef = (fun () -> Some ilModule) + TypeForwarders = Import.ImportILAssemblyTypeForwarders(tcImports.GetImportMap, m, GetRawTypeForwarders ilModule) + } + + let optdata = lazy ( + match memoize_opt.Apply ccuName with + | None -> None + | Some data -> + let findCcuInfo name = tcImports.FindCcu (m, name) + Some (data.OptionalFixup findCcuInfo) ) + + let ccu = CcuThunk.Create(ilShortAssemName, ccuData) + let ccuInfo = mkCcuInfo ilGlobals ilScopeRef ilModule ccu + let ccuOptInfo = { ccuInfo with FSharpOptimizationData = optdata } + ccuOptInfo, sigdata + + let rec GetCcu m ccuName = + let ilModule = memoize_mod.Apply ccuName + if HasAnyFSharpSignatureDataAttribute ilModule then + GetCcuFS m ccuName + else + GetCcuIL m ccuName + + let fixupCcuInfo refCcusUnfixed = + let refCcus = refCcusUnfixed |> List.map fst + let findCcuInfo name = + refCcus + |> List.tryFind (fun (x: ImportedAssembly) -> x.FSharpViewOfMetadata.AssemblyName = name) + |> Option.map (fun x -> x.FSharpViewOfMetadata) + let fixup (data: TastPickle.PickledDataWithReferences<_>) = + data.OptionalFixup findCcuInfo |> ignore + refCcusUnfixed |> List.choose snd |> List.iter fixup + refCcus + + let m = range.Zero + let refCcusUnfixed = List.ofArray references |> List.map (GetCcu m) + let refCcus = fixupCcuInfo refCcusUnfixed + let sysCcus = refCcus |> List.filter (fun x -> x.FSharpViewOfMetadata.AssemblyName <> "FSharp.Core") + let fslibCcu = refCcus |> List.find (fun x -> x.FSharpViewOfMetadata.AssemblyName = "FSharp.Core") + + let ccuInfos = [fslibCcu] @ sysCcus + let ccuMap = ccuInfos |> List.map (fun ccuInfo -> ccuInfo.FSharpViewOfMetadata.AssemblyName, ccuInfo) |> Map.ofList + + // search over all imported CCUs for each cached type + let ccuHasType (ccu: CcuThunk) (nsname: string list) (tname: string) = + let findEntity (entityOpt: Entity option) n = + match entityOpt with + | None -> None + | Some entity -> entity.ModuleOrNamespaceType.AllEntitiesByCompiledAndLogicalMangledNames.TryFind n + let entityOpt = (Some ccu.Contents, nsname) ||> List.fold findEntity + match entityOpt with + | Some ns -> + match Map.tryFind tname ns.ModuleOrNamespaceType.TypesByMangledName with + | Some _ -> true + | None -> false + | None -> false + + // Search for a type + let tryFindSysTypeCcu nsname typeName = + let search = sysCcus |> List.tryFind (fun ccuInfo -> ccuHasType ccuInfo.FSharpViewOfMetadata nsname typeName) + match search with + | Some x -> Some x.FSharpViewOfMetadata + | None -> +#if DEBUG + printfn "Cannot find type %s.%s" (String.concat "." nsname) typeName +#endif + None + + let tcGlobals = TcGlobals ( + tcConfig.compilingFslib, ilGlobals, fslibCcu.FSharpViewOfMetadata, + tcConfig.implicitIncludeDir, tcConfig.mlCompatibility, + tcConfig.isInteractive, tryFindSysTypeCcu, tcConfig.emitDebugInfoInQuotations, + tcConfig.noDebugData, tcConfig.pathMap, tcConfig.langVersion) + +#if DEBUG + // the global_g reference cell is used only for debug printing + do global_g := Some tcGlobals +#endif + // do this prior to parsing, since parsing IL assembly code may refer to mscorlib + do tcImports.SetCcuMap(ccuMap) + do tcImports.SetTcGlobals(tcGlobals) + tcImports, tcGlobals diff --git a/fcs/fcs-fable/ast_print.fs b/fcs/fcs-fable/ast_print.fs new file mode 100644 index 00000000000..bf936a8d48d --- /dev/null +++ b/fcs/fcs-fable/ast_print.fs @@ -0,0 +1,101 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +namespace FSharp.Compiler.SourceCodeServices + +//------------------------------------------------------------------------- +// AstPrint +//------------------------------------------------------------------------- + +module AstPrint = + + let attribsOfSymbol (s:FSharpSymbol) = + [ match s with + | :? FSharpField as v -> + yield "field" + if v.IsCompilerGenerated then yield "compgen" + if v.IsDefaultValue then yield "default" + if v.IsMutable then yield "mutable" + if v.IsVolatile then yield "volatile" + if v.IsStatic then yield "static" + if v.IsLiteral then yield sprintf "%A" v.LiteralValue.Value + + | :? FSharpEntity as v -> + v.TryFullName |> ignore // check there is no failure here + match v.BaseType with + | Some t when t.HasTypeDefinition && t.TypeDefinition.TryFullName.IsSome -> + yield sprintf "inherits %s" t.TypeDefinition.FullName + | _ -> () + if v.IsNamespace then yield "namespace" + if v.IsFSharpModule then yield "module" + if v.IsByRef then yield "byref" + if v.IsClass then yield "class" + if v.IsDelegate then yield "delegate" + if v.IsEnum then yield "enum" + if v.IsFSharpAbbreviation then yield "abbrev" + if v.IsFSharpExceptionDeclaration then yield "exception" + if v.IsFSharpRecord then yield "record" + if v.IsFSharpUnion then yield "union" + if v.IsInterface then yield "interface" + if v.IsMeasure then yield "measure" +#if !NO_EXTENSIONTYPING + if v.IsProvided then yield "provided" + if v.IsStaticInstantiation then yield "static_inst" + if v.IsProvidedAndErased then yield "erased" + if v.IsProvidedAndGenerated then yield "generated" +#endif + if v.IsUnresolved then yield "unresolved" + if v.IsValueType then yield "valuetype" + + | :? FSharpMemberOrFunctionOrValue as v -> + yield "owner: " + match v.DeclaringEntity with | Some e -> e.CompiledName | _ -> "" + if v.IsActivePattern then yield "active_pattern" + if v.IsDispatchSlot then yield "dispatch_slot" + if v.IsModuleValueOrMember && not v.IsMember then yield "val" + if v.IsMember then yield "member" + if v.IsProperty then yield "property" + if v.IsExtensionMember then yield "extension_member" + if v.IsPropertyGetterMethod then yield "property_getter" + if v.IsPropertySetterMethod then yield "property_setter" + if v.IsEvent then yield "event" + if v.EventForFSharpProperty.IsSome then yield "property_event" + if v.IsEventAddMethod then yield "event_add" + if v.IsEventRemoveMethod then yield "event_remove" + if v.IsTypeFunction then yield "type_func" + if v.IsCompilerGenerated then yield "compiler_gen" + if v.IsImplicitConstructor then yield "implicit_ctor" + if v.IsMutable then yield "mutable" + if v.IsOverrideOrExplicitInterfaceImplementation then yield "override_impl" + if not v.IsInstanceMember then yield "static" + if v.IsInstanceMember && not v.IsInstanceMemberInCompiledCode && not v.IsExtensionMember then yield "funky" + if v.IsExplicitInterfaceImplementation then yield "interface_impl" + yield sprintf "%A" v.InlineAnnotation + // if v.IsConstructorThisValue then yield "ctorthis" + // if v.IsMemberThisValue then yield "this" + // if v.LiteralValue.IsSome then yield "literal" + | _ -> () ] + + let rec printFSharpDecls prefix decls = seq { + let mutable i = 0 + for decl in decls do + i <- i + 1 + match decl with + | FSharpImplementationFileDeclaration.Entity (e, sub) -> + yield sprintf "%s%i) ENTITY: %s %A" prefix i e.CompiledName (attribsOfSymbol e) + if not (Seq.isEmpty e.Attributes) then + yield sprintf "%sattributes: %A" prefix (Seq.toList e.Attributes) + if not (Seq.isEmpty e.DeclaredInterfaces) then + yield sprintf "%sinterfaces: %A" prefix (Seq.toList e.DeclaredInterfaces) + yield "" + yield! printFSharpDecls (prefix + "\t") sub + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue (meth, args, body) -> + yield sprintf "%s%i) METHOD: %s %A" prefix i meth.CompiledName (attribsOfSymbol meth) + yield sprintf "%stype: %A" prefix meth.FullType + yield sprintf "%sargs: %A" prefix args + // if not meth.IsCompilerGenerated then + yield sprintf "%sbody: %A" prefix body + yield "" + | FSharpImplementationFileDeclaration.InitAction (expr) -> + yield sprintf "%s%i) ACTION" prefix i + yield sprintf "%s%A" prefix expr + yield "" + } diff --git a/fcs/fcs-fable/codegen/codegen.fsproj b/fcs/fcs-fable/codegen/codegen.fsproj new file mode 100644 index 00000000000..0977258a960 --- /dev/null +++ b/fcs/fcs-fable/codegen/codegen.fsproj @@ -0,0 +1,47 @@ + + + $(MSBuildProjectDirectory)\..\..\..\src + + + + + + Exe + netcoreapp3.0 + + + + + --module FSharp.Compiler.AbstractIL.Internal.AsciiParser --open FSharp.Compiler.AbstractIL --internal --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing + ilpars.fsy + + + --module FSharp.Compiler.Parser --open FSharp.Compiler --internal --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing + pars.fsy + + + --unicode --lexlib Internal.Utilities.Text.Lexing + AbsIL/illex.fsl + + + --unicode --lexlib Internal.Utilities.Text.Lexing + ParserAndUntypedAST/lex.fsl + + + --unicode --lexlib Internal.Utilities.Text.Lexing + ParserAndUntypedAST/pplex.fsl + + + --module FSharp.Compiler.PPParser --open FSharp.Compiler --internal --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing + ParserAndUntypedAST/pppars.fsy + + + + + + \ No newline at end of file diff --git a/fcs/fcs-fable/codegen/fssrgen.fsx b/fcs/fcs-fable/codegen/fssrgen.fsx new file mode 100644 index 00000000000..529a0a1d543 --- /dev/null +++ b/fcs/fcs-fable/codegen/fssrgen.fsx @@ -0,0 +1,495 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +module FsSrGen +open System +open System.IO + +let PrintErr(filename, line, msg) = + printfn "%s(%d): error : %s" filename line msg + +let Err(filename, line, msg) = + PrintErr(filename, line, msg) + printfn "Note that the syntax of each line is one of these three alternatives:" + printfn "# comment" + printfn "ident,\"string\"" + printfn "errNum,ident,\"string\"" + failwith (sprintf "there were errors in the file '%s'" filename) + +let xmlBoilerPlateString = @" + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + text/microsoft-resx + + + 2.0 + + + System.Resources.ResXResourceReader, System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + + + System.Resources.ResXResourceWriter, System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + +" + + +type HoleType = string + + +// The kinds of 'holes' we can do +let ComputeHoles filename lineNum (txt:string) : ResizeArray * string = + // takes in a %d%s kind of string, returns array of HoleType and {0}{1} kind of string + let mutable i = 0 + let mutable holeNumber = 0 + let mutable holes = ResizeArray() // order + let sb = new System.Text.StringBuilder() + let AddHole holeType = + sb.Append(sprintf "{%d}" holeNumber) |> ignore + holeNumber <- holeNumber + 1 + holes.Add(holeType) + while i < txt.Length do + if txt.[i] = '%' then + if i+1 = txt.Length then + Err(filename, lineNum, "(at end of string) % must be followed by d, f, s, or %") + else + match txt.[i+1] with + | 'd' -> AddHole "System.Int32" + | 'f' -> AddHole "System.Double" + | 's' -> AddHole "System.String" + | '%' -> sb.Append('%') |> ignore + | c -> Err(filename, lineNum, sprintf "'%%%c' is not a valid sequence, only %%d %%f %%s or %%%%" c) + i <- i + 2 + else + match txt.[i] with + | '{' -> sb.Append "{{" |> ignore + | '}' -> sb.Append "}}" |> ignore + | c -> sb.Append c |> ignore + i <- i + 1 + //printfn "holes.Length = %d, lineNum = %d" holes.Length //lineNum txt + (holes, sb.ToString()) + +let Unquote (s : string) = + if s.StartsWith "\"" && s.EndsWith "\"" then s.Substring(1, s.Length - 2) + else failwith "error message string should be quoted" + +let ParseLine filename lineNum (txt:string) = + let mutable errNum = None + let identB = new System.Text.StringBuilder() + let mutable i = 0 + // parse optional error number + if i < txt.Length && System.Char.IsDigit txt.[i] then + let numB = new System.Text.StringBuilder() + while i < txt.Length && System.Char.IsDigit txt.[i] do + numB.Append txt.[i] |> ignore + i <- i + 1 + errNum <- Some(int (numB.ToString())) + if i = txt.Length || not(txt.[i] = ',') then + Err(filename, lineNum, sprintf "After the error number '%d' there should be a comma" errNum.Value) + // Skip the comma + i <- i + 1 + // parse short identifier + if i < txt.Length && not(System.Char.IsLetter(txt.[i])) then + Err(filename, lineNum, sprintf "The first character in the short identifier should be a letter, but found '%c'" txt.[i]) + while i < txt.Length && System.Char.IsLetterOrDigit txt.[i] do + identB.Append txt.[i] |> ignore + i <- i + 1 + let ident = identB.ToString() + if ident.Length = 0 then + Err(filename, lineNum, "Did not find the short identifier") + else + if i = txt.Length || not(txt.[i] = ',') then + Err(filename, lineNum, sprintf "After the identifier '%s' there should be a comma" ident) + else + // Skip the comma + i <- i + 1 + if i = txt.Length then + Err(filename, lineNum, sprintf "After the identifier '%s' and comma, there should be the quoted string resource" ident) + else + let str = + try + System.String.Format(Unquote(txt.Substring i)) // Format turns e.g '\n' into that char, but also requires that we 'escape' curlies in the original .txt file, e.g. "{{" + with + e -> Err(filename, lineNum, sprintf "Error calling System.String.Format (note that curly braces must be escaped, and there cannot be trailing space on the line): >>>%s<<< -- %s" (txt.Substring i) e.Message) + let holes, netFormatString = ComputeHoles filename lineNum str + (lineNum, (errNum,ident), str, holes.ToArray(), netFormatString) + +let stringBoilerPlatePrefix = @" +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Reflection +open System.Reflection +// (namespaces below for specific case of using the tool to compile FSharp.Core itself) +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Text +open Microsoft.FSharp.Collections +open Printf +" +let StringBoilerPlate filename = + + @" + // BEGIN BOILERPLATE + + static let getCurrentAssembly () = + #if FX_RESHAPED_REFLECTION + typeof.GetTypeInfo().Assembly + #else + System.Reflection.Assembly.GetExecutingAssembly() + #endif + + static let getTypeInfo (t: System.Type) = + #if FX_RESHAPED_REFLECTION + t.GetTypeInfo() + #else + t + #endif + + static let resources = lazy (new System.Resources.ResourceManager(""" + filename + @""", getCurrentAssembly())) + + static let GetString(name:string) = + let s = resources.Value.GetString(name, System.Globalization.CultureInfo.CurrentUICulture) + #if DEBUG + if null = s then + System.Diagnostics.Debug.Assert(false, sprintf ""**RESOURCE ERROR**: Resource token %s does not exist!"" name) + #endif + s + + static let mkFunctionValue (tys: System.Type[]) (impl:obj->obj) = + FSharpValue.MakeFunction(FSharpType.MakeFunctionType(tys.[0],tys.[1]), impl) + + static let funTyC = typeof<(obj -> obj)>.GetGenericTypeDefinition() + + static let isNamedType(ty:System.Type) = not (ty.IsArray || ty.IsByRef || ty.IsPointer) + static let isFunctionType (ty1:System.Type) = + isNamedType(ty1) && getTypeInfo(ty1).IsGenericType && (ty1.GetGenericTypeDefinition()).Equals(funTyC) + + static let rec destFunTy (ty:System.Type) = + if isFunctionType ty then + ty, ty.GetGenericArguments() + else + match getTypeInfo(ty).BaseType with + | null -> failwith ""destFunTy: not a function type"" + | b -> destFunTy b + + static let buildFunctionForOneArgPat (ty: System.Type) impl = + let _,tys = destFunTy ty + let rty = tys.[1] + // PERF: this technique is a bit slow (e.g. in simple cases, like 'sprintf ""%x""') + mkFunctionValue tys (fun inp -> impl rty inp) + + static let capture1 (fmt:string) i args ty (go : obj list -> System.Type -> int -> obj) : obj = + match fmt.[i] with + | '%' -> go args ty (i+1) + | 'd' + | 'f' + | 's' -> buildFunctionForOneArgPat ty (fun rty n -> go (n::args) rty (i+1)) + | _ -> failwith ""bad format specifier"" + + // newlines and tabs get converted to strings when read from a resource file + // this will preserve their original intention + static let postProcessString (s : string) = + s.Replace(""\\n"",""\n"").Replace(""\\t"",""\t"").Replace(""\\r"",""\r"").Replace(""\\\"""", ""\"""") + + static let createMessageString (messageString : string) (fmt : Printf.StringFormat<'T>) : 'T = + let fmt = fmt.Value // here, we use the actual error string, as opposed to the one stored as fmt + let len = fmt.Length + + /// Function to capture the arguments and then run. + let rec capture args ty i = + if i >= len || (fmt.[i] = '%' && i+1 >= len) then + let b = new System.Text.StringBuilder() + b.AppendFormat(messageString, [| for x in List.rev args -> x |]) |> ignore + box(b.ToString()) + // REVIEW: For these purposes, this should be a nop, but I'm leaving it + // in incase we ever decide to support labels for the error format string + // E.g., ""%s%d"" + elif System.Char.IsSurrogatePair(fmt,i) then + capture args ty (i+2) + else + match fmt.[i] with + | '%' -> + let i = i+1 + capture1 fmt i args ty capture + | _ -> + capture args ty (i+1) + + (unbox (capture [] (typeof<'T>) 0) : 'T) + + static let mutable swallowResourceText = false + + static let GetStringFunc((messageID : string),(fmt : Printf.StringFormat<'T>)) : 'T = + if swallowResourceText then + sprintf fmt + else + let mutable messageString = GetString(messageID) + messageString <- postProcessString messageString + createMessageString messageString fmt + + /// If set to true, then all error messages will just return the filled 'holes' delimited by ',,,'s - this is for language-neutral testing (e.g. localization-invariant baselines). + static member SwallowResourceText with get () = swallowResourceText + and set (b) = swallowResourceText <- b + // END BOILERPLATE +" + +let RunMain(filename:string, outFilename, outXmlFilenameOpt, projectNameOpt) = + try + let justfilename = System.IO.Path.GetFileNameWithoutExtension(filename) + if justfilename |> Seq.exists (fun c -> not(System.Char.IsLetterOrDigit(c))) then + Err(filename, 0, sprintf "The filename '%s' is not allowed; only letters and digits can be used, as the filename also becomes the namespace for the SR class" justfilename) + + printfn "fssrgen.fsx: Reading %s" filename + let lines = System.IO.File.ReadAllLines(filename) + |> Array.mapi (fun i s -> i,s) // keep line numbers + |> Array.filter (fun (i,s) -> not(s.StartsWith "#")) // filter out comments + + printfn "fssrgen.fsx: Parsing %s" filename + let stringInfos = lines |> Array.map (fun (i,s) -> ParseLine filename i s) + // now we have array of (lineNum, ident, str, holes, netFormatString) // str has %d, netFormatString has {0} + + printfn "fssrgen.fsx: Validating %s" filename + // validate that all the idents are unique + let allIdents = new System.Collections.Generic.Dictionary() + for (line,(_,ident),_,_,_) in stringInfos do + if allIdents.ContainsKey(ident) then + Err(filename,line,sprintf "Identifier '%s' is already used previously on line %d - each identifier must be unique" ident allIdents.[ident]) + allIdents.Add(ident,line) + + printfn "fssrgen.fsx: Validating uniqueness of %s" filename + // validate that all the strings themselves are unique + let allStrs = new System.Collections.Generic.Dictionary() + for (line,(_,ident),str,_,_) in stringInfos do + if allStrs.ContainsKey(str) then + let prevLine,prevIdent = allStrs.[str] + Err(filename,line,sprintf "String '%s' already appears on line %d with identifier '%s' - each string must be unique" str prevLine prevIdent) + allStrs.Add(str,(line,ident)) + + printfn "fssrgen.fsx: Generating %s" outFilename + + use out = new System.IO.StringWriter() + fprintfn out "// This is a generated file; the original input is '%s'" filename + fprintfn out "namespace %s" justfilename + if Option.isNone outXmlFilenameOpt then + fprintfn out "type internal SR private() =" + else + fprintfn out "%s" stringBoilerPlatePrefix + fprintfn out "type internal SR private() =" + let theResourceName = match projectNameOpt with Some p -> sprintf "%s.%s" p justfilename | None -> justfilename + fprintfn out "%s" (StringBoilerPlate theResourceName) + + printfn "fssrgen.fsx: Generating resource methods for %s" outFilename + // gen each resource method + stringInfos |> Seq.iter (fun (lineNum, (optErrNum,ident), str, holes, netFormatString) -> + let formalArgs = System.Text.StringBuilder() + let actualArgs = System.Text.StringBuilder() + let firstTime = ref true + let n = ref 0 + formalArgs.Append "(" |> ignore + for hole in holes do + if !firstTime then + firstTime := false + else + formalArgs.Append ", " |> ignore + actualArgs.Append " " |> ignore + formalArgs.Append(sprintf "a%d : %s" !n hole) |> ignore + actualArgs.Append(sprintf "a%d" !n) |> ignore + n := !n + 1 + formalArgs.Append ")" |> ignore + fprintfn out " /// %s" str + fprintfn out " /// (Originally from %s:%d)" filename (lineNum+1) + let justPercentsFromFormatString = + (holes |> Array.fold (fun acc holeType -> + acc + match holeType with + | "System.Int32" -> ",,,%d" + | "System.Double" -> ",,,%f" + | "System.String" -> ",,,%s" + | _ -> failwith "unreachable") "") + ",,," + let errPrefix = match optErrNum with + | None -> "" + | Some n -> sprintf "%d, " n + if Option.isNone outXmlFilenameOpt then + fprintfn out " static member %s%s = (%ssprintf \"%s\" %s)" ident (formalArgs.ToString()) errPrefix str (actualArgs.ToString()) + else + fprintfn out " static member %s%s = (%sGetStringFunc(\"%s\",\"%s\") %s)" ident (formalArgs.ToString()) errPrefix ident justPercentsFromFormatString (actualArgs.ToString()) + ) + + if Option.isSome outXmlFilenameOpt then + printfn "fssrgen.fsx: Generating .resx for %s" outFilename + fprintfn out "" + // gen validation method + fprintfn out " /// Call this method once to validate that all known resources are valid; throws if not" + fprintfn out " static member RunStartupValidation() =" + stringInfos |> Seq.iter (fun (lineNum, (optErrNum,ident), str, holes, netFormatString) -> + fprintfn out " ignore(GetString(\"%s\"))" ident + ) + fprintfn out " ()" // in case there are 0 strings, we need the generated code to parse + + let outFileNewText = out.ToString() + let nothingChanged = try File.Exists(outFilename) && File.ReadAllText(outFilename) = outFileNewText with _ -> false + if not nothingChanged then + File.WriteAllText(outFilename, outFileNewText, System.Text.Encoding.UTF8) + + if Option.isSome outXmlFilenameOpt then + // gen resx + let xd = new System.Xml.XmlDocument() + xd.LoadXml(xmlBoilerPlateString) + stringInfos |> Seq.iter (fun (lineNum, (optErrNum,ident), str, holes, netFormatString) -> + let xn = xd.CreateElement("data") + xn.SetAttribute("name",ident) |> ignore + xn.SetAttribute("xml:space","preserve") |> ignore + let xnc = xd.CreateElement "value" + xn.AppendChild xnc |> ignore + xnc.AppendChild(xd.CreateTextNode netFormatString) |> ignore + xd.LastChild.AppendChild xn |> ignore + ) + let outXmlFileNewText = + use outXmlStream = new System.IO.StringWriter() + xd.Save outXmlStream + outXmlStream.ToString() + let outXmlFile = outXmlFilenameOpt.Value + let nothingChanged = try File.Exists(outXmlFile) && File.ReadAllText(outXmlFile) = outXmlFileNewText with _ -> false + if not nothingChanged then + File.WriteAllText(outXmlFile, outXmlFileNewText, System.Text.Encoding.Unicode) + + + printfn "fssrgen.fsx: Done %s" outFilename + 0 + with e -> + PrintErr(filename, 0, sprintf "An exception occurred when processing '%s'\n%s" filename (e.ToString())) + 1 + +#if COMPILED +[] +#endif +let Main args = + + match args |> List.ofArray with + | [ inputFile; outFile; ] -> + let filename = System.IO.Path.GetFullPath(inputFile) + let outFilename = System.IO.Path.GetFullPath(outFile) + + RunMain(filename, outFilename, None, None) + + | [ inputFile; outFile; outXml ] -> + let filename = System.IO.Path.GetFullPath inputFile + let outFilename = System.IO.Path.GetFullPath outFile + let outXmlFilename = System.IO.Path.GetFullPath outXml + + RunMain(filename, outFilename, Some outXmlFilename, None) + + | [ inputFile; outFile; outXml; projectName ] -> + let filename = System.IO.Path.GetFullPath inputFile + let outFilename = System.IO.Path.GetFullPath outFile + let outXmlFilename = System.IO.Path.GetFullPath outXml + + RunMain(filename, outFilename, Some outXmlFilename, Some projectName) + + | _ -> + printfn "Error: invalid arguments." + printfn "Usage: " + 1 +#if !COMPILED +printfn "fssrgen: args = %A" fsi.CommandLineArgs +Main (fsi.CommandLineArgs |> Seq.skip 1 |> Seq.toArray) +#endif diff --git a/fcs/fcs-fable/codegen/fssrgen.targets b/fcs/fcs-fable/codegen/fssrgen.targets new file mode 100644 index 00000000000..c28706b5d6a --- /dev/null +++ b/fcs/fcs-fable/codegen/fssrgen.targets @@ -0,0 +1,35 @@ + + + + + ProcessFsSrGen;$(PrepareForBuildDependsOn) + + + + + + + + + + + + false + + + diff --git a/fcs/fcs-fable/fcs-fable.fsproj b/fcs/fcs-fable/fcs-fable.fsproj new file mode 100644 index 00000000000..af50f4b1935 --- /dev/null +++ b/fcs/fcs-fable/fcs-fable.fsproj @@ -0,0 +1,237 @@ + + + $(MSBuildProjectDirectory)/../../src + + + + netstandard2.0 + $(DefineConstants);FABLE_COMPILER + $(DefineConstants);FX_NO_CORHOST_SIGNER + $(DefineConstants);FX_NO_PDB_READER + $(DefineConstants);FX_NO_PDB_WRITER + $(DefineConstants);FX_NO_WEAKTABLE + $(DefineConstants);NO_EXTENSIONTYPING + $(DefineConstants);NO_INLINE_IL_PARSER + $(OtherFlags) --warnon:1182 + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fcs/fcs-fable/service_slim.fs b/fcs/fcs-fable/service_slim.fs new file mode 100644 index 00000000000..9540a630f43 --- /dev/null +++ b/fcs/fcs-fable/service_slim.fs @@ -0,0 +1,320 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +// Open up the compiler as an incremental service for parsing, +// type checking and intellisense-like environment-reporting. + +namespace FSharp.Compiler.SourceCodeServices + +open System +open System.Collections.Generic +open System.Collections.Concurrent +open System.Diagnostics +open System.IO +open System.Reflection +open System.Text + +open Microsoft.FSharp.Core.Printf +open FSharp.Compiler +open FSharp.Compiler.AbstractIL +open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.AbstractIL.ILBinaryReader +open FSharp.Compiler.AbstractIL.Diagnostics +open FSharp.Compiler.AbstractIL.Internal +open FSharp.Compiler.AbstractIL.Internal.Library + +open FSharp.Compiler.AccessibilityLogic +open FSharp.Compiler.Ast +open FSharp.Compiler.CompileOps +open FSharp.Compiler.CompileOptions +#if !FABLE_COMPILER +open FSharp.Compiler.Driver +#endif +open FSharp.Compiler.ErrorLogger +open FSharp.Compiler.Lib +open FSharp.Compiler.PrettyNaming +open FSharp.Compiler.Parser +open FSharp.Compiler.Range +open FSharp.Compiler.Lexhelp +open FSharp.Compiler.Layout +open FSharp.Compiler.Tast +open FSharp.Compiler.Tastops +open FSharp.Compiler.TcGlobals +open FSharp.Compiler.Text +open FSharp.Compiler.Infos +open FSharp.Compiler.InfoReader +open FSharp.Compiler.NameResolution +open FSharp.Compiler.TypeChecker +open FSharp.Compiler.SourceCodeServices.SymbolHelpers + +open Internal.Utilities +open Internal.Utilities.Collections +open FSharp.Compiler.Layout.TaggedTextOps + + +//------------------------------------------------------------------------- +// InteractiveChecker +//------------------------------------------------------------------------- + +type internal TcResult = TcEnv * TopAttribs * TypedImplFile option * ModuleOrNamespaceType +type internal TcErrors = FSharpErrorInfo[] + +type InteractiveChecker internal (tcConfig, tcGlobals, tcImports, tcInitialState, ctok, reactorOps, parseCache, checkCache) = + let userOpName = "Unknown" + let suggestNamesForErrors = true + + static member Create(references: string[], readAllBytes: string -> byte[], defines: string[], optimize: bool) = + let otherOptions = [| + for d in defines do yield "-d:" + d + yield "--optimize" + (if optimize then "+" else "-") + |] + InteractiveChecker.Create(references, readAllBytes, otherOptions) + + static member Create(references: string[], readAllBytes: string -> byte[], otherOptions: string[]) = + let projectFileName = "Project" + let toRefOption (fileName: string) = + if fileName.EndsWith(".dll", StringComparison.OrdinalIgnoreCase) + then "-r:" + fileName + else "-r:" + fileName + ".dll" + let otherOptions = references |> Array.map toRefOption |> Array.append otherOptions + let projectOptions: FSharpProjectOptions = { + ProjectFileName = projectFileName + ProjectId = None + SourceFiles = [| |] + OtherOptions = otherOptions + ReferencedProjects = [| |] + IsIncompleteTypeCheckEnvironment = false + UseScriptResolutionRules = false + LoadTime = System.DateTime.MaxValue + UnresolvedReferences = None + OriginalLoadReferences = [] + ExtraProjectInfo = None + Stamp = None + } + InteractiveChecker.Create(readAllBytes, projectOptions) + + static member Create(readAllBytes: string -> byte[], projectOptions: FSharpProjectOptions) = + let references = + projectOptions.OtherOptions + |> Array.filter (fun s -> s.StartsWith("-r:")) + |> Array.map (fun s -> s.Replace("-r:", "")) + + let tcConfig = + let tcConfigB = TcConfigBuilder.Initial + tcConfigB.implicitIncludeDir <- Path.GetDirectoryName (projectOptions.ProjectFileName) + let sourceFiles = projectOptions.SourceFiles |> Array.toList + let argv = projectOptions.OtherOptions |> Array.toList + let _sourceFiles = ApplyCommandLineArgs(tcConfigB, sourceFiles, argv) + TcConfig.Create(tcConfigB, validate=false) + + let ctok = CompilationThreadToken() + let tcImports, tcGlobals = + TcImports.BuildTcImports (tcConfig, references, readAllBytes) + + let niceNameGen = NiceNameGenerator() + let assemblyName = projectOptions.ProjectFileName |> System.IO.Path.GetFileNameWithoutExtension + let tcInitialEnv = GetInitialTcEnv (assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals) + let tcInitialState = GetInitialTcState (rangeStartup, assemblyName, tcConfig, tcGlobals, tcImports, niceNameGen, tcInitialEnv) + + let reactorOps = + { new IReactorOperations with + member __.EnqueueAndAwaitOpAsync (userOpName, opName, opArg, op) = + async.Return (Cancellable.runWithoutCancellation (op ctok)) + member __.EnqueueOp (userOpName, opName, opArg, op) = (op ctok) } + + // parse cache, keyed on file name and source hash + let parseCache = ConcurrentDictionary(HashIdentity.Structural) + // type check cache, keyed on file name + let checkCache = ConcurrentDictionary(HashIdentity.Structural) + + InteractiveChecker (tcConfig, tcGlobals, tcImports, tcInitialState, ctok, reactorOps, parseCache, checkCache) + + member private x.MakeProjectResults (projectFileName: string, parseResults: FSharpParseFileResults[], tcState: TcState, errors: FSharpErrorInfo[], + symbolUses: TcSymbolUses list, topAttrsOpt: TopAttribs option, tcImplFilesOpt: TypedImplFile list option) = + let assemblyRef = mkSimpleAssemblyRef "stdin" + let assemblyDataOpt = None + let access = tcState.TcEnvFromImpls.AccessRights + let dependencyFiles = parseResults |> Seq.map (fun x -> x.DependencyFiles) |> Array.concat + let details = (tcGlobals, tcImports, tcState.Ccu, tcState.CcuSig, symbolUses, topAttrsOpt, assemblyDataOpt, assemblyRef, access, tcImplFilesOpt, dependencyFiles) + let keepAssemblyContents = true + FSharpCheckProjectResults (projectFileName, Some tcConfig, keepAssemblyContents, errors, Some details) + + member private x.ClearStaleCache (fileName: string, parsingOptions: FSharpParsingOptions) = + let fileIndex = parsingOptions.SourceFiles |> Array.findIndex ((=) fileName) + let filesAbove = parsingOptions.SourceFiles |> Array.take fileIndex + // backup all cached typecheck entries above file + let cachedAbove = filesAbove |> Array.choose (fun key -> + match checkCache.TryGetValue(key) with + | true, value -> Some (key, value) + | false, _ -> None) + // remove all parse cache entries with the same file name + let staleParseKeys = parseCache.Keys |> Seq.filter (fun (n,_) -> n = fileName) |> Seq.toArray + staleParseKeys |> Array.iter (fun key -> parseCache.TryRemove(key) |> ignore) + checkCache.Clear(); // clear all typecheck cache + // restore all cached typecheck entries above file + cachedAbove |> Array.iter (fun (key, value) -> checkCache.TryAdd(key, value) |> ignore) + + member private x.ParseFile (fileName: string, source: string, parsingOptions: FSharpParsingOptions) = + let parseCacheKey = fileName, hash source + parseCache.GetOrAdd(parseCacheKey, fun _ -> + x.ClearStaleCache(fileName, parsingOptions) + let sourceText = SourceText.ofString source + let parseErrors, parseTreeOpt, anyErrors = ParseAndCheckFile.parseFile (sourceText, fileName, parsingOptions, userOpName, suggestNamesForErrors) + let dependencyFiles = [||] // interactions have no dependencies + FSharpParseFileResults (parseErrors, parseTreeOpt, anyErrors, dependencyFiles) ) + + member private x.TypeCheckOneInput (parseResults: FSharpParseFileResults, tcSink: TcResultsSink, tcState: TcState, moduleNamesDict: ModuleNamesDict) = + let input = parseResults.ParseTree.Value + let capturingErrorLogger = CompilationErrorLogger("TypeCheckFile", tcConfig.errorSeverityOptions) + let errorLogger = GetErrorLoggerFilteringByScopedPragmas(false, GetScopedPragmasForInput(input), capturingErrorLogger) + use _errorScope = new CompilationGlobalsScope (errorLogger, BuildPhase.TypeCheck) + + let checkForErrors () = parseResults.ParseHadErrors || errorLogger.ErrorCount > 0 + let prefixPathOpt = None + + let input, moduleNamesDict = input |> DeduplicateParsedInputModuleName moduleNamesDict + let tcResult, tcState = + TypeCheckOneInputEventually (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input) + |> Eventually.force ctok + + let fileName = parseResults.FileName + let tcErrors = ErrorHelpers.CreateErrorInfos (tcConfig.errorSeverityOptions, false, fileName, (capturingErrorLogger.GetErrors()), suggestNamesForErrors) + (tcResult, tcErrors), (tcState, moduleNamesDict) + + member private x.CheckFile (projectFileName: string, parseResults: FSharpParseFileResults, tcState: TcState, moduleNamesDict: ModuleNamesDict) = + match parseResults.ParseTree with + | Some _input -> + let sink = TcResultsSinkImpl(tcGlobals) + let tcSink = TcResultsSink.WithSink sink + let (tcResult, tcErrors), (tcState, moduleNamesDict) = + x.TypeCheckOneInput (parseResults, tcSink, tcState, moduleNamesDict) + let fileName = parseResults.FileName + checkCache.[fileName] <- ((tcResult, tcErrors), (tcState, moduleNamesDict)) + + let loadClosure = None + let textSnapshotInfo = None + let keepAssemblyContents = true + + let tcEnvAtEnd, _topAttrs, implFile, ccuSigForFile = tcResult + let errors = Array.append parseResults.Errors tcErrors + + let scope = TypeCheckInfo (tcConfig, tcGlobals, ccuSigForFile, tcState.Ccu, tcImports, tcEnvAtEnd.AccessRights, + projectFileName, fileName, sink.GetResolutions(), sink.GetSymbolUses(), tcEnvAtEnd.NameEnv, + loadClosure, reactorOps, textSnapshotInfo, implFile, sink.GetOpenDeclarations()) + FSharpCheckFileResults (fileName, errors, Some scope, parseResults.DependencyFiles, None, reactorOps, keepAssemblyContents) + |> Some + | None -> + None + + member private x.TypeCheckClosedInputSet (parseResults: FSharpParseFileResults[], tcState) = + let cachedTypeCheck (tcState, moduleNamesDict) (parseRes: FSharpParseFileResults) = + let checkCacheKey = parseRes.FileName + let typeCheckOneInput _fileName = + x.TypeCheckOneInput (parseRes, TcResultsSink.NoSink, tcState, moduleNamesDict) + checkCache.GetOrAdd(checkCacheKey, typeCheckOneInput) + let results, (tcState, moduleNamesDict) = + ((tcState, Map.empty), parseResults) ||> Array.mapFold cachedTypeCheck + let tcResults, tcErrors = Array.unzip results + let (tcEnvAtEndOfLastFile, topAttrs, implFiles, _ccuSigsForFiles), tcState = + TypeCheckMultipleInputsFinish(tcResults |> Array.toList, tcState) + let tcState, declaredImpls = TypeCheckClosedInputSetFinish (implFiles, tcState) + tcState, topAttrs, declaredImpls, tcEnvAtEndOfLastFile, moduleNamesDict, tcErrors + + /// Errors grouped by file, sorted by line, column + member private x.ErrorsByFile (fileNames: string[], errorList: FSharpErrorInfo[] list) = + let errorMap = errorList |> Array.concat |> Array.groupBy (fun x -> x.FileName) |> Map.ofArray + let errors = fileNames |> Array.choose errorMap.TryFind + errors |> Array.iter (Array.sortInPlaceBy (fun x -> x.StartLineAlternate, x.StartColumn)) + errors |> Array.concat + + /// Clears parse and typecheck caches. + member x.ClearCache () = + parseCache.Clear() + checkCache.Clear() + + /// Parses and checks single file only, left as is for backwards compatibility. + /// Despite the name, there is no support for #load etc. + member x.ParseAndCheckScript (projectFileName: string, fileName: string, source: string) = + let sourceText = SourceText.ofString source + let fileNames = [| fileName |] + let parsingOptions = FSharpParsingOptions.FromTcConfig(tcConfig, fileNames, false) + let parseResults = x.ParseFile (fileName, source, parsingOptions) + let moduleNamesDict = Map.empty + let loadClosure = None + let backgroundErrors = [||] + let textSnapshotInfo = None + let tcState = tcInitialState + let tcResults = ParseAndCheckFile.CheckOneFile( + parseResults, sourceText, fileName, projectFileName, tcConfig, tcGlobals, tcImports, tcState, + moduleNamesDict, loadClosure, backgroundErrors, reactorOps, textSnapshotInfo, userOpName, suggestNamesForErrors) + match tcResults with + | tcErrors, Result.Ok tcFileInfo -> + let errors = Array.append parseResults.Errors tcErrors + let tcImplFilesOpt = match tcFileInfo.ImplementationFile with Some x -> Some [x] | None -> None + let typeCheckResults = FSharpCheckFileResults (fileName, errors, Some tcFileInfo, parseResults.DependencyFiles, None, reactorOps, true) + let symbolUses = [tcFileInfo.ScopeSymbolUses] + let projectResults = x.MakeProjectResults (projectFileName, [|parseResults|], tcState, errors, symbolUses, None, tcImplFilesOpt) + parseResults, typeCheckResults, projectResults + | _ -> + failwith "unexpected aborted" + + /// Parses and checks the whole project, good for compilers (Fable etc.) + /// Does not retain name resolutions and symbol uses which are quite memory hungry (so no intellisense etc.). + /// Already parsed files will be cached so subsequent compilations will be faster. + member x.ParseAndCheckProject (projectFileName: string, fileNames: string[], sources: string[]) = + // parse files + let parsingOptions = FSharpParsingOptions.FromTcConfig(tcConfig, fileNames, false) + let parseFile (fileName, source) = x.ParseFile (fileName, source, parsingOptions) + let parseResults = Array.zip fileNames sources |> Array.map parseFile + + // type check files + let tcState, topAttrs, tcImplFiles, _tcEnvAtEnd, _moduleNamesDict, tcErrors = + x.TypeCheckClosedInputSet (parseResults, tcInitialState) + + // make project results + let parseErrors = parseResults |> Array.collect (fun p -> p.Errors) + let typedErrors = tcErrors |> Array.concat + let errors = x.ErrorsByFile (fileNames, [ parseErrors; typedErrors ]) + let symbolUses = [] //TODO: + let projectResults = x.MakeProjectResults (projectFileName, parseResults, tcState, errors, symbolUses, Some topAttrs, Some tcImplFiles) + + projectResults + + /// Parses and checks file in project, will compile and cache all the files up to this one + /// (if not already done before), or fetch them from cache. Returns partial project results, + /// up to and including the file requested. Returns parse and typecheck results containing + /// name resolutions and symbol uses for the file requested only, so intellisense etc. works. + member x.ParseAndCheckFileInProject (fileName: string, projectFileName: string, fileNames: string[], sources: string[]) = + // get files before file + let fileIndex = fileNames |> Array.findIndex ((=) fileName) + let fileNamesBeforeFile = fileNames |> Array.take fileIndex + let sourcesBeforeFile = sources |> Array.take fileIndex + + // parse files before file + let parsingOptions = FSharpParsingOptions.FromTcConfig(tcConfig, fileNames, false) + let parseFile (fileName, source) = x.ParseFile (fileName, source, parsingOptions) + let parseResults = Array.zip fileNamesBeforeFile sourcesBeforeFile |> Array.map parseFile + + // type check files before file + let tcState, topAttrs, tcImplFiles, _tcEnvAtEnd, moduleNamesDict, tcErrors = + x.TypeCheckClosedInputSet (parseResults, tcInitialState) + + // parse and type check file + let parseFileResults = parseFile (fileName, sources.[fileIndex]) + let checkFileResults = x.CheckFile (projectFileName, parseFileResults, tcState, moduleNamesDict) + let (tcResult, _tcErrors), (tcState, _moduleNamesDict) = checkCache.[fileName] + let _tcEnvAtEndFile, topAttrsFile, implFile, _ccuSigForFile = tcResult + + // collect errors + let parseErrorsBefore = parseResults |> Array.collect (fun p -> p.Errors) + let typedErrorsBefore = tcErrors |> Array.concat + let newErrors = match checkFileResults with | Some res -> res.Errors | None -> [||] + let errors = x.ErrorsByFile (fileNames, [ parseErrorsBefore; typedErrorsBefore; newErrors ]) + + // make partial project results + let parseResults = Array.append parseResults [| parseFileResults |] + let tcImplFiles = List.append tcImplFiles (Option.toList implFile) + let topAttrs = CombineTopAttrs topAttrsFile topAttrs + let symbolUses = [] //TODO: + let projectResults = x.MakeProjectResults (projectFileName, parseResults, tcState, errors, symbolUses, Some topAttrs, Some tcImplFiles) + + parseFileResults, checkFileResults, projectResults diff --git a/fcs/fcs-fable/test/.gitignore b/fcs/fcs-fable/test/.gitignore new file mode 100644 index 00000000000..66d36d51d64 --- /dev/null +++ b/fcs/fcs-fable/test/.gitignore @@ -0,0 +1,7 @@ +# Output +out*/ + +# Node +node_modules/ +package-lock.json +yarn.lock \ No newline at end of file diff --git a/fcs/fcs-fable/test/Metadata.fs b/fcs/fcs-fable/test/Metadata.fs new file mode 100644 index 00000000000..fc78841d8c0 --- /dev/null +++ b/fcs/fcs-fable/test/Metadata.fs @@ -0,0 +1,198 @@ +module Metadata + +let references_core = [| + "Fable.Core" + "FSharp.Core" + "mscorlib" + "netstandard" + "System.Collections" + "System.Collections.Concurrent" + "System.ComponentModel" + "System.ComponentModel.Primitives" + "System.ComponentModel.TypeConverter" + "System.Console" + "System.Core" + "System.Diagnostics.Debug" + "System.Diagnostics.Tracing" + "System.Globalization" + "System" + "System.IO" + "System.Numerics" + "System.Reflection" + "System.Reflection.Extensions" + "System.Reflection.Metadata" + "System.Reflection.Primitives" + "System.Reflection.TypeExtensions" + "System.Runtime" + "System.Runtime.Extensions" + "System.Runtime.Numerics" + "System.Text.Encoding" + "System.Text.Encoding.Extensions" + "System.Text.RegularExpressions" + "System.Threading" + "System.Threading.Tasks" + "System.ValueTuple" + |] + +let references_net45 = [| + "Fable.Core" + "Fable.Import.Browser" + "FSharp.Core" + "mscorlib" + "System" + "System.Core" + "System.Data" + "System.IO" + "System.Xml" + "System.Numerics" + |] + +let references_full = [| + "Fable.Core" + "Fable.Import.Browser" + "FSharp.Core" + "Microsoft.CSharp" + "Microsoft.VisualBasic" + "Microsoft.Win32.Primitives" + "mscorlib" + "netstandard" + "System.AppContext" + "System.Buffers" + "System.Collections.Concurrent" + "System.Collections" + "System.Collections.Immutable" + "System.Collections.NonGeneric" + "System.Collections.Specialized" + "System.ComponentModel.Annotations" + //"System.ComponentModel.Composition" // removed in 2.1.300 + "System.ComponentModel.DataAnnotations" + "System.ComponentModel" + "System.ComponentModel.EventBasedAsync" + "System.ComponentModel.Primitives" + "System.ComponentModel.TypeConverter" + "System.Configuration" + "System.Console" + "System.Core" + "System.Data.Common" + "System.Data" + "System.Diagnostics.Contracts" + "System.Diagnostics.Debug" + "System.Diagnostics.DiagnosticSource" + "System.Diagnostics.FileVersionInfo" + "System.Diagnostics.Process" + "System.Diagnostics.StackTrace" + "System.Diagnostics.TextWriterTraceListener" + "System.Diagnostics.Tools" + "System.Diagnostics.TraceSource" + "System.Diagnostics.Tracing" + "System" + "System.Drawing" + "System.Drawing.Primitives" + "System.Dynamic.Runtime" + "System.Globalization.Calendars" + "System.Globalization" + "System.Globalization.Extensions" + //"System.IO.Compression.Brotli" // added in 2.1.300 + "System.IO.Compression" + "System.IO.Compression.FileSystem" + "System.IO.Compression.ZipFile" + "System.IO" + "System.IO.FileSystem" + "System.IO.FileSystem.DriveInfo" + "System.IO.FileSystem.Primitives" + "System.IO.FileSystem.Watcher" + "System.IO.IsolatedStorage" + "System.IO.MemoryMappedFiles" + "System.IO.Pipes" + "System.IO.UnmanagedMemoryStream" + "System.Linq" + "System.Linq.Expressions" + "System.Linq.Parallel" + "System.Linq.Queryable" + //"System.Memory" // added in 2.1.300 + "System.Net" + "System.Net.Http" + "System.Net.HttpListener" + "System.Net.Mail" + "System.Net.NameResolution" + "System.Net.NetworkInformation" + "System.Net.Ping" + "System.Net.Primitives" + "System.Net.Requests" + "System.Net.Security" + "System.Net.ServicePoint" + "System.Net.Sockets" + "System.Net.WebClient" + "System.Net.WebHeaderCollection" + "System.Net.WebProxy" + "System.Net.WebSockets.Client" + "System.Net.WebSockets" + "System.Numerics" + "System.Numerics.Vectors" + "System.ObjectModel" + "System.Reflection.DispatchProxy" + "System.Reflection" + "System.Reflection.Emit" + "System.Reflection.Emit.ILGeneration" + "System.Reflection.Emit.Lightweight" + "System.Reflection.Extensions" + "System.Reflection.Metadata" + "System.Reflection.Primitives" + "System.Reflection.TypeExtensions" + "System.Resources.Reader" + "System.Resources.ResourceManager" + "System.Resources.Writer" + "System.Runtime.CompilerServices.VisualC" + "System.Runtime" + "System.Runtime.Extensions" + "System.Runtime.Handles" + "System.Runtime.InteropServices" + "System.Runtime.InteropServices.RuntimeInformation" + "System.Runtime.InteropServices.WindowsRuntime" + "System.Runtime.Loader" + "System.Runtime.Numerics" + "System.Runtime.Serialization" + "System.Runtime.Serialization.Formatters" + "System.Runtime.Serialization.Json" + "System.Runtime.Serialization.Primitives" + "System.Runtime.Serialization.Xml" + "System.Security.Claims" + "System.Security.Cryptography.Algorithms" + "System.Security.Cryptography.Csp" + "System.Security.Cryptography.Encoding" + "System.Security.Cryptography.Primitives" + "System.Security.Cryptography.X509Certificates" + "System.Security" + "System.Security.Principal" + "System.Security.SecureString" + "System.ServiceModel.Web" + "System.ServiceProcess" + "System.Text.Encoding" + "System.Text.Encoding.Extensions" + "System.Text.RegularExpressions" + "System.Threading" + "System.Threading.Overlapped" + "System.Threading.Tasks.Dataflow" + "System.Threading.Tasks" + "System.Threading.Tasks.Extensions" + "System.Threading.Tasks.Parallel" + "System.Threading.Thread" + "System.Threading.ThreadPool" + "System.Threading.Timer" + "System.Transactions" + "System.Transactions.Local" + "System.ValueTuple" + "System.Web" + "System.Web.HttpUtility" + "System.Windows" + "System.Xml" + "System.Xml.Linq" + "System.Xml.ReaderWriter" + "System.Xml.Serialization" + "System.Xml.XDocument" + "System.Xml.XmlDocument" + "System.Xml.XmlSerializer" + "System.Xml.XPath" + "System.Xml.XPath.XDocument" + "WindowsBase" + |] diff --git a/fcs/fcs-fable/test/Platform.fs b/fcs/fcs-fable/test/Platform.fs new file mode 100644 index 00000000000..a3878b1a860 --- /dev/null +++ b/fcs/fcs-fable/test/Platform.fs @@ -0,0 +1,92 @@ +module Fable.Compiler.Platform + +#if DOTNET_FILE_SYSTEM && !FABLE_COMPILER + +open System.IO + +let readAllBytes (filePath: string) = File.ReadAllBytes(filePath) +let readAllText (filePath: string) = File.ReadAllText(filePath, System.Text.Encoding.UTF8) +let writeAllText (filePath: string) (text: string) = File.WriteAllText(filePath, text) + +let measureTime (f: 'a -> 'b) x = + let sw = System.Diagnostics.Stopwatch.StartNew() + let res = f x + sw.Stop() + sw.ElapsedMilliseconds, res + +let normalizeFullPath (path: string) = + let path = if System.String.IsNullOrWhiteSpace path then "." else path + Path.GetFullPath(path).Replace('\\', '/') + +let getRelativePath (path: string) (pathTo: string) = + let path = if System.String.IsNullOrWhiteSpace path then "." else path + Path.GetRelativePath(path, pathTo).Replace('\\', '/') + +#else + +open Fable.Core.JsInterop + +module JS = + type IFileSystem = + abstract readFileSync: string -> byte[] + abstract readFileSync: string * string -> string + abstract writeFileSync: string * string -> unit + + type IProcess = + abstract hrtime: unit -> float [] + abstract hrtime: float[] -> float[] + + type IPath = + abstract resolve: string -> string + abstract relative: string * string -> string + + let FileSystem: IFileSystem = importAll "fs" + let Process: IProcess = importAll "process" + let Path: IPath = importAll "path" + +let readAllBytes (filePath: string) = JS.FileSystem.readFileSync(filePath) +let readAllText (filePath: string) = JS.FileSystem.readFileSync(filePath, "utf8").TrimStart('\uFEFF') +let writeAllText (filePath: string) (text: string) = JS.FileSystem.writeFileSync(filePath, text) + +let measureTime (f: 'a -> 'b) x = + let startTime = JS.Process.hrtime() + let res = f x + let elapsed = JS.Process.hrtime(startTime) + int64 (elapsed.[0] * 1e3 + elapsed.[1] / 1e6), res + +let normalizeFullPath (path: string) = + JS.Path.resolve(path).Replace('\\', '/') + +let getRelativePath (path: string) (pathTo: string) = + JS.Path.relative(path, pathTo).Replace('\\', '/') + +#endif + +module Path = + + let Combine (path1: string, path2: string) = + let path1 = + if path1.Length = 0 then path1 + else (path1.TrimEnd [|'\\';'/'|]) + "/" + path1 + (path2.TrimStart [|'\\';'/'|]) + + let ChangeExtension (path: string, ext: string) = + let i = path.LastIndexOf(".") + if i < 0 then path + else path.Substring(0, i) + ext + + let GetFileName (path: string) = + let normPath = path.Replace("\\", "/").TrimEnd('/') + let i = normPath.LastIndexOf("/") + normPath.Substring(i + 1) + + let GetFileNameWithoutExtension (path: string) = + let path = GetFileName path + let i = path.LastIndexOf(".") + path.Substring(0, i) + + let GetDirectoryName (path: string) = + let normPath = path.Replace("\\", "/") + let i = normPath.LastIndexOf("/") + if i < 0 then "" + else normPath.Substring(0, i) diff --git a/fcs/fcs-fable/test/ProjectParser.fs b/fcs/fcs-fable/test/ProjectParser.fs new file mode 100644 index 00000000000..eac497e38b3 --- /dev/null +++ b/fcs/fcs-fable/test/ProjectParser.fs @@ -0,0 +1,176 @@ +module Fable.Compiler.ProjectParser + +open Fable.Compiler.Platform +open System.Collections.Generic +open System.Text.RegularExpressions + +let (|Regex|_|) (pattern: string) (input: string) = + let m = Regex.Match(input, pattern) + if m.Success then + let mutable groups = [] + for i = m.Groups.Count - 1 downto 0 do + groups <- m.Groups.[i].Value::groups + Some groups + else None + +let parseCompilerOptions projectText = + + // get project type + let m = Regex.Match(projectText, @"]*>([^<]*)<\/OutputType[^>]*>") + let target = if m.Success then m.Groups.[1].Value.Trim().ToLowerInvariant() else "" + + // get warning level + let m = Regex.Match(projectText, @"]*>([^<]*)<\/WarningLevel[^>]*>") + let warnLevel = if m.Success then m.Groups.[1].Value.Trim() else "" + + // get treat warnings as errors + let m = Regex.Match(projectText, @"]*>([^<]*)<\/TreatWarningsAsErrors[^>]*>") + let treatWarningsAsErrors = m.Success && m.Groups.[1].Value.Trim().ToLowerInvariant() = "true" + + // get conditional defines + let defines = + Regex.Matches(projectText, @"]*>([^<]*)<\/DefineConstants[^>]*>") + |> Seq.collect (fun m -> m.Groups.[1].Value.Split(';')) + |> Seq.append ["FABLE_COMPILER"] + |> Seq.map (fun s -> s.Trim()) + |> Seq.distinct + |> Seq.except ["$(DefineConstants)"; ""] + |> Seq.toArray + + // get disabled warnings + let nowarns = + Regex.Matches(projectText, @"]*>([^<]*)<\/NoWarn[^>]*>") + |> Seq.collect (fun m -> m.Groups.[1].Value.Split(';')) + |> Seq.map (fun s -> s.Trim()) + |> Seq.distinct + |> Seq.except ["$(NoWarn)"; ""] + |> Seq.toArray + + // get warnings as errors + let warnAsErrors = + Regex.Matches(projectText, @"]*>([^<]*)<\/WarningsAsErrors[^>]*>") + |> Seq.collect (fun m -> m.Groups.[1].Value.Split(';')) + |> Seq.map (fun s -> s.Trim()) + |> Seq.distinct + |> Seq.except ["$(WarningsAsErrors)"; ""] + |> Seq.toArray + + // get other flags + let otherFlags = + Regex.Matches(projectText, @"]*>([^<]*)<\/OtherFlags[^>]*>") + |> Seq.collect (fun m -> m.Groups.[1].Value.Split(' ')) + |> Seq.map (fun s -> s.Trim()) + |> Seq.distinct + |> Seq.except ["$(OtherFlags)"; ""] + |> Seq.toArray + + let otherOptions = [| + if target.Length > 0 then + yield "--target:" + target + if warnLevel.Length > 0 then + yield "--warn:" + warnLevel + if treatWarningsAsErrors then + yield "--warnaserror+" + for d in defines do yield "-d:" + d + for n in nowarns do yield "--nowarn:" + n + for e in warnAsErrors do yield "--warnaserror:" + e + for o in otherFlags do yield o + |] + otherOptions + +let parseProjectScript projectFileName = + let projectText = readAllText projectFileName + let projectDir = Path.GetDirectoryName projectFileName + let dllRefs, srcFiles = + (([||], [||]), projectText.Split('\n')) + ||> Array.fold (fun (dllRefs, srcFiles) line -> + match line.Trim() with + | Regex @"^#r\s+""(.*?)""$" [_;path] + when not(path.EndsWith("Fable.Core.dll")) -> + Array.append [|Path.Combine(projectDir, path)|] dllRefs, srcFiles + | Regex @"^#load\s+""(.*?)""$" [_;path] -> + dllRefs, Array.append [|Path.Combine(projectDir, path)|] srcFiles + | _ -> dllRefs, srcFiles) + let projectRefs = [||] + let sourceFiles = Array.append srcFiles [|Path.GetFileName projectFileName|] + let otherOptions = [| "--define:FABLE_COMPILER" |] + (dllRefs, projectRefs, sourceFiles, otherOptions) + +let parseProjectFile projectFileName = + let projectText = readAllText projectFileName + + // remove all comments + let projectText = Regex.Replace(projectText, @"", "") + + // get project references + let projectRefs = + Regex.Matches(projectText, @"]*Include\s*=\s*(""[^""]*|'[^']*)") + |> Seq.map (fun m -> m.Groups.[1].Value.TrimStart('"').TrimStart(''').Trim().Replace("\\", "/")) + |> Seq.toArray + + // replace some variables + let projectText = projectText.Replace(@"$(MSBuildProjectDirectory)", ".") + let m = Regex.Match(projectText, @"]*>([^<]*)<\/FSharpSourcesRoot[^>]*>") + let sourcesRoot = if m.Success then m.Groups.[1].Value.Replace("\\", "/") else "" + let projectText = projectText.Replace(@"$(FSharpSourcesRoot)", sourcesRoot) + + // get source files + let sourceFilesRegex = @"]*Include\s*=\s*(""[^""]*|'[^']*)" + let sourceFiles = + Regex.Matches(projectText, sourceFilesRegex) + |> Seq.map (fun m -> m.Groups.[1].Value.TrimStart('"').TrimStart(''').Trim().Replace("\\", "/")) + |> Seq.toArray + + let dllRefs = [||] + let otherOptions = parseCompilerOptions projectText + (dllRefs, projectRefs, sourceFiles, otherOptions) + +let makeHashSetIgnoreCase () = + let equalityComparerIgnoreCase = + { new IEqualityComparer with + member __.Equals(x, y) = x.ToLowerInvariant() = y.ToLowerInvariant() + member __.GetHashCode(x) = hash (x.ToLowerInvariant()) } + HashSet(equalityComparerIgnoreCase) + +let dedupProjectRefs (projSet: HashSet) projectRefs = + let newRefs = projectRefs |> Array.filter (fun x -> projSet.Contains(x) |> not) + projSet.UnionWith(newRefs) + newRefs + +let dedupFileNames (fileSet: HashSet) fileNames = + let padName (fileName: string) = + let pos = fileName.LastIndexOf(".") + let nm = if pos < 0 then fileName else fileName.Substring(0, pos) + let ext = if pos < 0 then "" else fileName.Substring(pos) + nm + "_" + ext + let rec dedup fileName = + if fileSet.Contains(fileName) then + dedup (padName fileName) + else + fileSet.Add(fileName) |> ignore + fileName + fileNames |> Array.map dedup + +let rec parseProject (projSet: HashSet) (projectFileName: string) = + let (dllRefs, projectRefs, sourceFiles, otherOptions) = + if projectFileName.EndsWith(".fsx") + then parseProjectScript projectFileName + else parseProjectFile projectFileName + + let projectFileDir = Path.GetDirectoryName projectFileName + let isAbsolutePath (path: string) = path.StartsWith("/") || path.IndexOf(":") = 1 + let makePath path = + if isAbsolutePath path then path + else Path.Combine(projectFileDir, path) + |> normalizeFullPath + + let sourcePaths = sourceFiles |> Array.map makePath + let sourceTexts = sourcePaths |> Array.map readAllText + + // parse and combine all referenced projects into one big project + let parsedProjects = projectRefs |> Array.map makePath |> dedupProjectRefs projSet |> Array.map (parseProject projSet) + let sourcePaths = sourcePaths |> Array.append (parsedProjects |> Array.collect (fun (_,x,_,_) -> x)) + let sourceTexts = sourceTexts |> Array.append (parsedProjects |> Array.collect (fun (_,_,x,_) -> x)) + let otherOptions = otherOptions |> Array.append (parsedProjects |> Array.collect (fun (_,_,_,x) -> x)) + + (dllRefs, sourcePaths, sourceTexts, otherOptions |> Array.distinct) diff --git a/fcs/fcs-fable/test/bench/Properties/launchSettings.json b/fcs/fcs-fable/test/bench/Properties/launchSettings.json new file mode 100644 index 00000000000..787bc4e16ee --- /dev/null +++ b/fcs/fcs-fable/test/bench/Properties/launchSettings.json @@ -0,0 +1,9 @@ +{ + "profiles": { + "fcs-fable-bench": { + "commandName": "Project", + "commandLineArgs": "../../fcs-fable.fsproj", + "workingDirectory": "$(SolutionDir)" + } + } +} \ No newline at end of file diff --git a/fcs/fcs-fable/test/bench/bench.fs b/fcs/fcs-fable/test/bench/bench.fs new file mode 100644 index 00000000000..f16c22a2539 --- /dev/null +++ b/fcs/fcs-fable/test/bench/bench.fs @@ -0,0 +1,110 @@ +module Fable.Compiler.App + +open FSharp.Compiler.SourceCodeServices +open Fable.Compiler.Platform +open Fable.Compiler.ProjectParser + +let references = Metadata.references_core +let metadataPath = "/Projects/Fable/src/fable-metadata/lib/" // .NET BCL binaries + +let printErrors showWarnings (errors: FSharpErrorInfo[]) = + let isWarning (e: FSharpErrorInfo) = + e.Severity = FSharpErrorSeverity.Warning + let printError (e: FSharpErrorInfo) = + let errorType = (if isWarning e then "Warning" else "Error") + printfn "%s (%d,%d--%d,%d): %s: %s" e.FileName e.EndLineAlternate + e.StartColumn e.EndLineAlternate e.EndColumn errorType e.Message + let warnings, errors = errors |> Array.partition isWarning + let hasErrors = not (Array.isEmpty errors) + if showWarnings then + warnings |> Array.iter printError + if hasErrors then + errors |> Array.iter printError + failwith "Too many errors." + +let parseFiles projectFileName outDir optimize = + // parse project + let projSet = makeHashSetIgnoreCase () + let (dllRefs, fileNames, sources, otherOptions) = parseProject projSet projectFileName + + // dedup file names + let fileSet = makeHashSetIgnoreCase () + let fileNames = dedupFileNames fileSet fileNames + + // create checker + let readAllBytes dllName = readAllBytes (metadataPath + dllName) + let optimizeFlag = "--optimize" + (if optimize then "+" else "-") + let otherOptions = otherOptions |> Array.append [| optimizeFlag |] + let createChecker () = InteractiveChecker.Create(references, readAllBytes, otherOptions) + let ms0, checker = measureTime createChecker () + printfn "--------------------------------------------" + printfn "InteractiveChecker created in %d ms" ms0 + + // parse F# files to AST + let parseFSharpProject () = checker.ParseAndCheckProject(projectFileName, fileNames, sources) + let ms1, projectResults = measureTime parseFSharpProject () + printfn "Project: %s, FCS time: %d ms" projectFileName ms1 + printfn "--------------------------------------------" + let showWarnings = false // supress warnings for clarity + projectResults.Errors |> printErrors showWarnings + + // // modify last file + // sources.[sources.Length - 1] <- sources.[sources.Length - 1] + "\n" + // let parseFSharpProject () = checker.ParseAndCheckProject(projectFileName, fileNames, sources) + // let ms1, projectResults = measureTime parseFSharpProject () + // printfn "Project: %s, FCS time: %d ms (modified last file)" projectFileName ms1 + + // // modify middle file + // sources.[sources.Length / 2] <- sources.[sources.Length / 2] + "\n" + // let parseFSharpProject () = checker.ParseAndCheckProject(projectFileName, fileNames, sources) + // let ms1, projectResults = measureTime parseFSharpProject () + // printfn "Project: %s, FCS time: %d ms (modified middle file)" projectFileName ms1 + + // // modify first file + // sources.[0] <- sources.[0] + "\n" + // let parseFSharpProject () = checker.ParseAndCheckProject(projectFileName, fileNames, sources) + // let ms1, projectResults = measureTime parseFSharpProject () + // printfn "Project: %s, FCS time: %d ms (modified first file)" projectFileName ms1 + + // // clear cache + // checker.ClearCache() + + // // after clear cache + // sources.[0] <- sources.[0] + "\n" + // let parseFSharpProject () = checker.ParseAndCheckProject(projectFileName, fileNames, sources) + // let ms1, projectResults = measureTime parseFSharpProject () + // printfn "Project: %s, FCS time: %d ms (after clear cache)" projectFileName ms1 + + // exclude signature files + let fileNames = fileNames |> Array.filter (fun x -> not (x.EndsWith(".fsi"))) + + // this is memory intensive, only do it once + let implFiles = if optimize + then projectResults.GetOptimizedAssemblyContents().ImplementationFiles + else projectResults.AssemblyContents.ImplementationFiles + + // for each file + for implFile in implFiles do + printfn "%s" implFile.FileName + + // printfn "--------------------------------------------" + // let fsAst = implFile.Declarations |> AstPrint.printFSharpDecls "" |> String.concat "\n" + // printfn "%s" fsAst + +let parseArguments (argv: string[]) = + let usage = "Usage: bench [--options]" + let opts, args = argv |> Array.partition (fun s -> s.StartsWith("--")) + match args with + | [| projectFileName |] -> + let outDir = "./out-test" + let optimize = opts |> Array.contains "--optimize-fcs" + parseFiles projectFileName outDir optimize + | _ -> printfn "%s" usage + +[] +let main argv = + try + parseArguments argv + with ex -> + printfn "Error: %A" ex.Message + 0 diff --git a/fcs/fcs-fable/test/bench/fcs-fable-bench.fsproj b/fcs/fcs-fable/test/bench/fcs-fable-bench.fsproj new file mode 100644 index 00000000000..8da2825cfc3 --- /dev/null +++ b/fcs/fcs-fable/test/bench/fcs-fable-bench.fsproj @@ -0,0 +1,26 @@ + + + + Exe + netcoreapp3.0 + $(DefineConstants);DOTNET_FILE_SYSTEM + true + + + + + + + + + + + + + + + + + + + diff --git a/fcs/fcs-fable/test/bench/fcs-fable-bench.sln b/fcs/fcs-fable/test/bench/fcs-fable-bench.sln new file mode 100644 index 00000000000..213e74fbe71 --- /dev/null +++ b/fcs/fcs-fable/test/bench/fcs-fable-bench.sln @@ -0,0 +1,37 @@ + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 15 +VisualStudioVersion = 15.0.28307.106 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "fcs-fable-bench", "fcs-fable-bench.fsproj", "{83F34C34-6804-4436-923E-E2C539AA59F0}" +EndProject +Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "fcs-fable", "../../fcs-fable.fsproj", "{7D5BC9E3-CEE5-4E1B-BF4E-67553841FD37}" +EndProject +Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "fcs-fable-test", "../fcs-fable-test.fsproj", "{C270F69E-224E-4438-8EF3-5AB59FF11453}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Any CPU = Debug|Any CPU + Release|Any CPU = Release|Any CPU + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {83F34C34-6804-4436-923E-E2C539AA59F0}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {83F34C34-6804-4436-923E-E2C539AA59F0}.Debug|Any CPU.Build.0 = Debug|Any CPU + {83F34C34-6804-4436-923E-E2C539AA59F0}.Release|Any CPU.ActiveCfg = Release|Any CPU + {83F34C34-6804-4436-923E-E2C539AA59F0}.Release|Any CPU.Build.0 = Release|Any CPU + {7D5BC9E3-CEE5-4E1B-BF4E-67553841FD37}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {7D5BC9E3-CEE5-4E1B-BF4E-67553841FD37}.Debug|Any CPU.Build.0 = Debug|Any CPU + {7D5BC9E3-CEE5-4E1B-BF4E-67553841FD37}.Release|Any CPU.ActiveCfg = Release|Any CPU + {7D5BC9E3-CEE5-4E1B-BF4E-67553841FD37}.Release|Any CPU.Build.0 = Release|Any CPU + {C270F69E-224E-4438-8EF3-5AB59FF11453}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {C270F69E-224E-4438-8EF3-5AB59FF11453}.Debug|Any CPU.Build.0 = Debug|Any CPU + {C270F69E-224E-4438-8EF3-5AB59FF11453}.Release|Any CPU.ActiveCfg = Release|Any CPU + {C270F69E-224E-4438-8EF3-5AB59FF11453}.Release|Any CPU.Build.0 = Release|Any CPU + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection + GlobalSection(ExtensibilityGlobals) = postSolution + SolutionGuid = {BC5C2845-7FCA-4814-93C2-F5910096D973} + EndGlobalSection +EndGlobal diff --git a/fcs/fcs-fable/test/fcs-fable-test.fsproj b/fcs/fcs-fable/test/fcs-fable-test.fsproj new file mode 100644 index 00000000000..2bfc78370e7 --- /dev/null +++ b/fcs/fcs-fable/test/fcs-fable-test.fsproj @@ -0,0 +1,25 @@ + + + + Exe + netcoreapp3.0 + $(DefineConstants);DOTNET_FILE_SYSTEM + true + + + + + + + + + + + + + + + + + + diff --git a/fcs/fcs-fable/test/package.json b/fcs/fcs-fable/test/package.json new file mode 100644 index 00000000000..afcf9cfbf45 --- /dev/null +++ b/fcs/fcs-fable/test/package.json @@ -0,0 +1,14 @@ +{ + "private": true, + "scripts": { + "build-test": "dotnet build -c Release fcs-fable-test.fsproj", + "build-bench": "dotnet build -c Release bench/fcs-fable-bench.fsproj", + "build-node": "fable fcs-fable-test.fsproj out-test --commonjs", + "test-node": "node out-test/test", + "test-dotnet": "dotnet run -c Release -p fcs-fable-test.fsproj", + "bench-dotnet": "dotnet run -c Release -p bench/fcs-fable-bench.fsproj ../fcs-fable.fsproj" + }, + "devDependencies": { + "fable-compiler-js": "^1.0.5" + } +} diff --git a/fcs/fcs-fable/test/splitter.config.js b/fcs/fcs-fable/test/splitter.config.js new file mode 100644 index 00000000000..428407dfe0a --- /dev/null +++ b/fcs/fcs-fable/test/splitter.config.js @@ -0,0 +1,28 @@ +const path = require("path"); + +const useCommonjs = process.argv.find(v => v === "--commonjs"); +console.log("Compiling to " + (useCommonjs ? "commonjs" : "ES2015 modules") + "...") + +const babelOptions = useCommonjs + ? { plugins: ["@babel/plugin-transform-modules-commonjs"] } + : {}; + +const fableOptions = { + define: [ + "FX_NO_CORHOST_SIGNER", + "FX_NO_PDB_READER", + "FX_NO_PDB_WRITER", + "FX_NO_WEAKTABLE", + "NO_EXTENSIONTYPING", + "NO_INLINE_IL_PARSER" + ], + // extra: { saveAst: "./ast" } +}; + +module.exports = { + entry: path.join(__dirname, "./fcs-fable-test.fsproj"), + outDir: path.join(__dirname, "./out-test"), + // port: 61225, + babel: babelOptions, + fable: fableOptions, +}; diff --git a/fcs/fcs-fable/test/test.fs b/fcs/fcs-fable/test/test.fs new file mode 100644 index 00000000000..95f36933697 --- /dev/null +++ b/fcs/fcs-fable/test/test.fs @@ -0,0 +1,65 @@ +module Fable.Compiler.App + +open FSharp.Compiler +open FSharp.Compiler.SourceCodeServices +open Fable.Compiler.Platform + +let references = Metadata.references_core +let metadataPath = "/Projects/Fable/src/fable-metadata/lib/" // .NET BCL binaries + +[] +let main argv = + printfn "Parsing begins..." + + let defines = [||] + let optimize = false + let readAllBytes dllName = readAllBytes (metadataPath + dllName) + let checker = InteractiveChecker.Create(references, readAllBytes, defines, optimize) + + let projectFileName = "project" + let fileName = "test_script.fsx" + let source = readAllText fileName + + //let parseResults, typeCheckResults, projectResults = + // checker.ParseAndCheckScript(projectFileName, fileName, source) + let parseResults, tcResultsOpt, projectResults = + checker.ParseAndCheckFileInProject(fileName, projectFileName, [|fileName|], [|source|]) + + // print errors + projectResults.Errors |> Array.iter (fun e -> printfn "%A: %A" (e.Severity) e) + + match tcResultsOpt with + | Some typeCheckResults -> + + printfn "Typed AST (optimize=%A):" optimize + // let implFiles = typeCheckResults.ImplementationFile |> Option.toArray + let implFiles = + let assemblyContents = + if not optimize then projectResults.AssemblyContents + else projectResults.GetOptimizedAssemblyContents() + assemblyContents.ImplementationFiles + let decls = implFiles + |> Seq.collect (fun file -> AstPrint.printFSharpDecls "" file.Declarations) + |> String.concat "\n" + decls |> printfn "%s" + // writeAllText (fileName + ".ast.txt") decls + + let inputLines = source.Split('\n') + + async { + // Get tool tip at the specified location + let! tip = typeCheckResults.GetToolTipText(4, 7, inputLines.[3], ["foo"], FSharpTokenTag.IDENT) + (sprintf "%A" tip).Replace("\n","") |> printfn "\n---> ToolTip Text = %A" // should be "FSharpToolTipText [...]" + + // Get declarations (autocomplete) for msg + let partialName = { QualifyingIdents = []; PartialIdent = "msg"; EndColumn = 17; LastDotPos = None } + let! decls = typeCheckResults.GetDeclarationListInfo(Some parseResults, 6, inputLines.[5], partialName, (fun _ -> []), fun _ -> false) + [ for item in decls.Items -> item.Name ] |> printfn "\n---> msg AutoComplete = %A" // should be string methods + + // Get declarations (autocomplete) for canvas + let partialName = { QualifyingIdents = []; PartialIdent = "canvas"; EndColumn = 10; LastDotPos = None } + let! decls = typeCheckResults.GetDeclarationListInfo(Some parseResults, 8, inputLines.[7], partialName, (fun _ -> []), fun _ -> false) + [ for item in decls.Items -> item.Name ] |> printfn "\n---> canvas AutoComplete = %A" + } |> Async.StartImmediate + | _ -> () + 0 diff --git a/fcs/fcs-fable/test/test_script.fsx b/fcs/fcs-fable/test/test_script.fsx new file mode 100644 index 00000000000..344a81772ef --- /dev/null +++ b/fcs/fcs-fable/test/test_script.fsx @@ -0,0 +1,9 @@ +open System +open Fable.Import + +let foo() = + let msg = String.Concat("Hello"," ","world") + let len = msg.Length + // let canvas = Browser.document.createElement_canvas () + // canvas.width <- 1000. + () \ No newline at end of file diff --git a/global.json b/global.json index 1e7325d7682..0bf92d79716 100644 --- a/global.json +++ b/global.json @@ -1,6 +1,6 @@ { "tools": { - "dotnet": "3.0.100-preview6-012264", + "dotnet": "3.0.100", "vs": { "version": "16.1", "components": [ diff --git a/package-lock.json b/package-lock.json new file mode 100644 index 00000000000..48e341a0954 --- /dev/null +++ b/package-lock.json @@ -0,0 +1,3 @@ +{ + "lockfileVersion": 1 +} diff --git a/src/absil/il.fs b/src/absil/il.fs index ce513a5af04..721fba507d2 100644 --- a/src/absil/il.fs +++ b/src/absil/il.fs @@ -405,6 +405,7 @@ type ILAssemblyRef(data) = assemRefVersion=version assemRefLocale=locale } +#if !FABLE_COMPILER static member FromAssemblyName (aname: AssemblyName) = let locale = None @@ -426,6 +427,7 @@ type ILAssemblyRef(data) = let retargetable = aname.Flags = AssemblyNameFlags.Retargetable ILAssemblyRef.Create (aname.Name, None, publicKey, retargetable, version, locale) +#endif member aref.QualifiedName = let b = StringBuilder(100) @@ -1589,12 +1591,16 @@ let inline conditionalAdd condition flagToAdd source = if condition then source let NoMetadataIdx = -1 -[] +[] type ILMethodDef (name: string, attributes: MethodAttributes, implAttributes: MethodImplAttributes, callingConv: ILCallingConv, parameters: ILParameters, ret: ILReturn, body: ILLazyMethodBody, isEntryPoint: bool, genericParams: ILGenericParameterDefs, securityDeclsStored: ILSecurityDeclsStored, customAttrsStored: ILAttributesStored, metadataIndex: int32) = - new (name, attributes, implAttributes, callingConv, parameters, ret, body, isEntryPoint, genericParams, securityDecls, customAttrs) = + static member CreateStored (name, attributes, implAttributes, callingConv, parameters, ret, body, isEntryPoint, genericParams, securityDeclsStored, customAttrsStored, metadataIndex) = + ILMethodDef(name, attributes, implAttributes, callingConv, parameters, ret, body, isEntryPoint, genericParams, + securityDeclsStored, customAttrsStored, metadataIndex) + + static member Create (name, attributes, implAttributes, callingConv, parameters, ret, body, isEntryPoint, genericParams, securityDecls, customAttrs) = ILMethodDef (name, attributes, implAttributes, callingConv, parameters, ret, body, isEntryPoint, genericParams, storeILSecurityDecls securityDecls, storeILCustomAttrs customAttrs, NoMetadataIdx) @@ -1628,7 +1634,7 @@ type ILMethodDef (name: string, attributes: MethodAttributes, implAttributes: Me ?body: ILLazyMethodBody, ?securityDecls: ILSecurityDecls, ?isEntryPoint: bool, ?genericParams: ILGenericParameterDefs, ?customAttrs: ILAttributes) = - ILMethodDef (name = defaultArg name x.Name, + ILMethodDef.Create (name = defaultArg name x.Name, attributes = defaultArg attributes x.Attributes, implAttributes = defaultArg implAttributes x.ImplAttributes, callingConv = defaultArg callingConv x.CallingConv, @@ -1744,12 +1750,15 @@ type ILMethodDefs(f : (unit -> ILMethodDef[])) = member x.FindByNameAndArity (nm, arity) = x.FindByName nm |> List.filter (fun x -> List.length x.Parameters = arity) -[] +[] type ILEventDef(eventType: ILType option, name: string, attributes: EventAttributes, addMethod: ILMethodRef, removeMethod: ILMethodRef, fireMethod: ILMethodRef option, otherMethods: ILMethodRef list, customAttrsStored: ILAttributesStored, metadataIndex: int32) = - new (eventType, name, attributes, addMethod, removeMethod, fireMethod, otherMethods, customAttrs) = + static member CreateStored (eventType, name, attributes, addMethod, removeMethod, fireMethod, otherMethods, customAttrsStored, metadataIndex) = + ILEventDef(eventType, name, attributes, addMethod, removeMethod, fireMethod, otherMethods, customAttrsStored, metadataIndex) + + static member Create (eventType, name, attributes, addMethod, removeMethod, fireMethod, otherMethods, customAttrs) = ILEventDef(eventType, name, attributes, addMethod, removeMethod, fireMethod, otherMethods, storeILCustomAttrs customAttrs, NoMetadataIdx) member __.EventType = eventType @@ -1764,7 +1773,7 @@ type ILEventDef(eventType: ILType option, name: string, attributes: EventAttribu member x.CustomAttrs = customAttrsStored.GetCustomAttrs x.MetadataIndex member x.With(?eventType, ?name, ?attributes, ?addMethod, ?removeMethod, ?fireMethod, ?otherMethods, ?customAttrs) = - ILEventDef(eventType= defaultArg eventType x.EventType, + ILEventDef.Create(eventType= defaultArg eventType x.EventType, name= defaultArg name x.Name, attributes= defaultArg attributes x.Attributes, addMethod=defaultArg addMethod x.AddMethod, @@ -1790,12 +1799,15 @@ type ILEventDefs = member x.LookupByName s = let (ILEvents t) = x in t.[s] -[] +[] type ILPropertyDef(name: string, attributes: PropertyAttributes, setMethod: ILMethodRef option, getMethod: ILMethodRef option, callingConv: ILThisConvention, propertyType: ILType, init: ILFieldInit option, args: ILTypes, customAttrsStored: ILAttributesStored, metadataIndex: int32) = - new (name, attributes, setMethod, getMethod, callingConv, propertyType, init, args, customAttrs) = + static member CreateStored (name, attributes, setMethod, getMethod, callingConv, propertyType, init, args, customAttrsStored, metadataIndex) = + ILPropertyDef(name, attributes, setMethod, getMethod, callingConv, propertyType, init, args, customAttrsStored, metadataIndex) + + static member Create (name, attributes, setMethod, getMethod, callingConv, propertyType, init, args, customAttrs) = ILPropertyDef(name, attributes, setMethod, getMethod, callingConv, propertyType, init, args, storeILCustomAttrs customAttrs, NoMetadataIdx) member x.Name = name @@ -1811,7 +1823,7 @@ type ILPropertyDef(name: string, attributes: PropertyAttributes, setMethod: ILMe member x.MetadataIndex = metadataIndex member x.With(?name, ?attributes, ?setMethod, ?getMethod, ?callingConv, ?propertyType, ?init, ?args, ?customAttrs) = - ILPropertyDef(name=defaultArg name x.Name, + ILPropertyDef.Create(name=defaultArg name x.Name, attributes=defaultArg attributes x.Attributes, setMethod=defaultArg setMethod x.SetMethod, getMethod=defaultArg getMethod x.GetMethod, @@ -1848,13 +1860,17 @@ let convertFieldAccess (ilMemberAccess: ILMemberAccess) = | ILMemberAccess.Private -> FieldAttributes.Private | ILMemberAccess.Public -> FieldAttributes.Public -[] +[] type ILFieldDef(name: string, fieldType: ILType, attributes: FieldAttributes, data: byte[] option, literalValue: ILFieldInit option, offset: int32 option, marshal: ILNativeType option, customAttrsStored: ILAttributesStored, metadataIndex: int32) = - new (name, fieldType, attributes, data, literalValue, offset, marshal, customAttrs) = + static member CreateStored (name, fieldType, attributes, data, literalValue, offset, marshal, customAttrsStored, metadataIndex) = + ILFieldDef(name, fieldType, attributes, data, literalValue, offset, marshal, customAttrsStored, metadataIndex) + + static member Create (name, fieldType, attributes, data, literalValue, offset, marshal, customAttrs) = ILFieldDef(name, fieldType, attributes, data, literalValue, offset, marshal, storeILCustomAttrs customAttrs, NoMetadataIdx) + member __.Name=name member __.FieldType = fieldType member __.Attributes=attributes @@ -1867,7 +1883,7 @@ type ILFieldDef(name: string, fieldType: ILType, attributes: FieldAttributes, da member x.MetadataIndex = metadataIndex member x.With(?name: string, ?fieldType: ILType, ?attributes: FieldAttributes, ?data: byte[] option, ?literalValue: ILFieldInit option, ?offset: int32 option, ?marshal: ILNativeType option, ?customAttrs: ILAttributes) = - ILFieldDef(name=defaultArg name x.Name, + ILFieldDef.Create(name=defaultArg name x.Name, fieldType=defaultArg fieldType x.FieldType, attributes=defaultArg attributes x.Attributes, data=defaultArg data x.Data, @@ -2024,14 +2040,17 @@ let convertInitSemantics (init: ILTypeInit) = | ILTypeInit.BeforeField -> TypeAttributes.BeforeFieldInit | ILTypeInit.OnAny -> enum 0 -[] +[] type ILTypeDef(name: string, attributes: TypeAttributes, layout: ILTypeDefLayout, implements: ILTypes, genericParams: ILGenericParameterDefs, extends: ILType option, methods: ILMethodDefs, nestedTypes: ILTypeDefs, fields: ILFieldDefs, methodImpls: ILMethodImplDefs, events: ILEventDefs, properties: ILPropertyDefs, securityDeclsStored: ILSecurityDeclsStored, customAttrsStored: ILAttributesStored, metadataIndex: int32) = let mutable customAttrsStored = customAttrsStored - new (name, attributes, layout, implements, genericParams, extends, methods, nestedTypes, fields, methodImpls, events, properties, securityDecls, customAttrs) = + static member CreateStored (name, attributes, layout, implements, genericParams, extends, methods, nestedTypes, fields, methodImpls, events, properties, securityDeclsStored, customAttrsStored, metadataIndex) = + ILTypeDef (name, attributes, layout, implements, genericParams, extends, methods, nestedTypes, fields, methodImpls, events, properties, securityDeclsStored, customAttrsStored, metadataIndex) + + static member Create (name, attributes, layout, implements, genericParams, extends, methods, nestedTypes, fields, methodImpls, events, properties, securityDecls, customAttrs) = ILTypeDef (name, attributes, layout, implements, genericParams, extends, methods, nestedTypes, fields, methodImpls, events, properties, storeILSecurityDecls securityDecls, storeILCustomAttrs customAttrs, NoMetadataIdx) member __.Name = name @@ -2051,7 +2070,7 @@ type ILTypeDef(name: string, attributes: TypeAttributes, layout: ILTypeDefLayout member __.MetadataIndex = metadataIndex member x.With(?name, ?attributes, ?layout, ?implements, ?genericParams, ?extends, ?methods, ?nestedTypes, ?fields, ?methodImpls, ?events, ?properties, ?customAttrs, ?securityDecls) = - ILTypeDef(name=defaultArg name x.Name, + ILTypeDef.Create(name=defaultArg name x.Name, attributes=defaultArg attributes x.Attributes, layout=defaultArg layout x.Layout, genericParams = defaultArg genericParams x.GenericParams, @@ -2148,10 +2167,15 @@ and [] ILPreTypeDef(nameSpace: string list, name: string, metadataIndex: | ILTypeDefStored.Given td -> store <- td td +#if FABLE_COMPILER + | ILTypeDefStored.Computed f -> store <- f(); store + | ILTypeDefStored.Reader f -> store <- f x.MetadataIndex; store +#else | ILTypeDefStored.Computed f -> LazyInitializer.EnsureInitialized(&store, Func<_>(fun () -> f())) | ILTypeDefStored.Reader f -> LazyInitializer.EnsureInitialized(&store, Func<_>(fun () -> f x.MetadataIndex)) +#endif | _ -> store and ILTypeDefStored = @@ -2217,8 +2241,10 @@ type ILResource = /// Read the bytes from a resource local to an assembly member r.GetBytes() = match r.Location with +#if !FABLE_COMPILER | ILResourceLocation.LocalIn (file, start, len) -> File.ReadBinaryChunk(file, start, len) +#endif | ILResourceLocation.LocalOut bytes -> bytes | _ -> failwith "GetBytes" @@ -2432,7 +2458,11 @@ let formatCodeLabel (x: int) = "L"+string x // ++GLOBAL MUTABLE STATE (concurrency safe) let codeLabelCount = ref 0 +#if FABLE_COMPILER +let generateCodeLabel() = codeLabelCount := !codeLabelCount + 1; !codeLabelCount +#else let generateCodeLabel() = Interlocked.Increment codeLabelCount +#endif let instrIsRet i = match i with @@ -2915,7 +2945,7 @@ let methBodyAbstract = mkMethBodyAux MethodBody.Abstract let methBodyNative = mkMethBodyAux MethodBody.Native let mkILCtor (access, args, impl) = - ILMethodDef(name=".ctor", + ILMethodDef.Create(name=".ctor", attributes=(convertMemberAccess access ||| MethodAttributes.SpecialName ||| MethodAttributes.RTSpecialName), implAttributes=MethodImplAttributes.Managed, callingConv=ILCallingConv.Instance, @@ -2960,7 +2990,7 @@ let mkILNonGenericEmptyCtor tag superTy = // -------------------------------------------------------------------- let mkILStaticMethod (genparams, nm, access, args, ret, impl) = - ILMethodDef(genericParams=genparams, + ILMethodDef.Create(genericParams=genparams, name=nm, attributes=(convertMemberAccess access ||| MethodAttributes.Static), implAttributes=MethodImplAttributes.Managed, @@ -2976,7 +3006,7 @@ let mkILNonGenericStaticMethod (nm, access, args, ret, impl) = mkILStaticMethod (mkILEmptyGenericParams, nm, access, args, ret, impl) let mkILClassCtor impl = - ILMethodDef(name=".cctor", + ILMethodDef.Create(name=".cctor", attributes=(MethodAttributes.Private ||| MethodAttributes.Static ||| MethodAttributes.SpecialName ||| MethodAttributes.RTSpecialName), implAttributes=MethodImplAttributes.Managed, callingConv=ILCallingConv.Static, @@ -2997,7 +3027,7 @@ let mk_ospec (ty: ILType, callconv, nm, genparams, formal_args, formal_ret) = OverridesSpec (mkILMethRef (ty.TypeRef, callconv, nm, genparams, formal_args, formal_ret), ty) let mkILGenericVirtualMethod (nm, access, genparams, actual_args, actual_ret, impl) = - ILMethodDef(name=nm, + ILMethodDef.Create(name=nm, attributes= (convertMemberAccess access ||| MethodAttributes.CheckAccessOnOverride ||| @@ -3016,7 +3046,7 @@ let mkILNonGenericVirtualMethod (nm, access, args, ret, impl) = mkILGenericVirtualMethod (nm, access, mkILEmptyGenericParams, args, ret, impl) let mkILGenericNonVirtualMethod (nm, access, genparams, actual_args, actual_ret, impl) = - ILMethodDef(name=nm, + ILMethodDef.Create(name=nm, attributes=(convertMemberAccess access ||| MethodAttributes.HideBySig), implAttributes=MethodImplAttributes.Managed, genericParams=genparams, @@ -3103,7 +3133,7 @@ let prependInstrsToClassCtor instrs tag cd = cdef_cctorCode2CodeOrCreate tag (prependInstrsToMethod instrs) cd let mkILField (isStatic, nm, ty, (init: ILFieldInit option), (at: byte [] option), access, isLiteral) = - ILFieldDef(name=nm, + ILFieldDef.Create(name=nm, fieldType=ty, attributes= (convertFieldAccess access ||| @@ -3226,7 +3256,7 @@ let mkILSimpleStorageCtor (tag, baseTySpec, ty, extraParams, flds, access) = let mkILStorageCtor (tag, preblock, ty, flds, access) = mkILStorageCtorWithParamNames (tag, preblock, ty, [], addParamNames flds, access) let mkILGenericClass (nm, access, genparams, extends, impl, methods, fields, nestedTypes, props, events, attrs, init) = - ILTypeDef(name=nm, + ILTypeDef.Create(name=nm, attributes=(convertTypeAccessFlags access ||| TypeAttributes.AutoLayout ||| TypeAttributes.Class ||| (match init with | ILTypeInit.BeforeField -> TypeAttributes.BeforeFieldInit | _ -> enum 0) ||| TypeAttributes.AnsiClass), genericParams= genparams, @@ -3243,7 +3273,7 @@ let mkILGenericClass (nm, access, genparams, extends, impl, methods, fields, nes securityDecls=emptyILSecurityDecls) let mkRawDataValueTypeDef (iltyp_ValueType: ILType) (nm, size, pack) = - ILTypeDef(name = nm, + ILTypeDef.Create(name = nm, genericParams= [], attributes = (TypeAttributes.NotPublic ||| TypeAttributes.Sealed ||| TypeAttributes.ExplicitLayout ||| TypeAttributes.BeforeFieldInit ||| TypeAttributes.AnsiClass), @@ -3834,7 +3864,11 @@ type ILTypeSigParser (tstring : string) = yield grabScopeComponent() // culture yield grabScopeComponent() // public key token ] |> String.concat "," +#if FABLE_COMPILER + ILScopeRef.Assembly(mkSimpleAssemblyRef scope) +#else ILScopeRef.Assembly(ILAssemblyRef.FromAssemblyName(AssemblyName scope)) +#endif else ILScopeRef.Local @@ -3982,7 +4016,11 @@ let decodeILAttribData (ilg: ILGlobals) (ca: ILAttribute) = pieces.[0], None let scoref = match rest with +#if FABLE_COMPILER + | Some aname -> ILScopeRef.Assembly(mkSimpleAssemblyRef aname) +#else | Some aname -> ILScopeRef.Assembly (ILAssemblyRef.FromAssemblyName (AssemblyName aname)) +#endif | None -> ilg.primaryAssemblyScopeRef let tref = mkILTyRef (scoref, unqualified_tname) @@ -4256,11 +4294,17 @@ let parseILVersion (vstr : string) = versionComponents.[3] <- defaultRevision.ToString() vstr <- String.Join (".", versionComponents) +#if FABLE_COMPILER + let parts = vstr.Split([|'.'|]) + let versions = Array.append (Array.map uint16 parts) [|0us;0us;0us;0us|] + ILVersionInfo (versions.[0], versions.[1], versions.[2], versions.[3]) +#else let version = System.Version vstr let zero32 n = if n < 0 then 0us else uint16 n // since the minor revision will be -1 if none is specified, we need to truncate to 0 to not break existing code let minorRevision = if version.Revision = -1 then 0us else uint16 version.MinorRevision ILVersionInfo (zero32 version.Major, zero32 version.Minor, zero32 version.Build, minorRevision) +#endif let compareILVersions (version1 : ILVersionInfo) (version2 : ILVersionInfo) = let c = compare version1.Major version2.Major diff --git a/src/absil/il.fsi b/src/absil/il.fsi index 87fd66932a6..f130091751b 100644 --- a/src/absil/il.fsi +++ b/src/absil/il.fsi @@ -66,7 +66,9 @@ type ILVersionInfo = [] type ILAssemblyRef = static member Create: name: string * hash: byte[] option * publicKey: PublicKey option * retargetable: bool * version: ILVersionInfo option * locale: string option -> ILAssemblyRef +#if !FABLE_COMPILER static member FromAssemblyName: System.Reflection.AssemblyName -> ILAssemblyRef +#endif member Name: string /// The fully qualified name of the assembly reference, e.g. mscorlib, Version=1.0.3705 etc. @@ -960,16 +962,16 @@ type ILLazyMethodBody = member Contents: MethodBody /// IL Method definitions. -[] +[] type ILMethodDef = /// Functional creation of a value, with delayed reading of some elements via a metadata index - new: name: string * attributes: MethodAttributes * implAttributes: MethodImplAttributes * callingConv: ILCallingConv * + static member CreateStored: name: string * attributes: MethodAttributes * implAttributes: MethodImplAttributes * callingConv: ILCallingConv * parameters: ILParameters * ret: ILReturn * body: ILLazyMethodBody * isEntryPoint:bool * genericParams: ILGenericParameterDefs * securityDeclsStored: ILSecurityDeclsStored * customAttrsStored: ILAttributesStored * metadataIndex: int32 -> ILMethodDef /// Functional creation of a value, immediate - new: name: string * attributes: MethodAttributes * implAttributes: MethodImplAttributes * callingConv: ILCallingConv * + static member Create: name: string * attributes: MethodAttributes * implAttributes: MethodImplAttributes * callingConv: ILCallingConv * parameters: ILParameters * ret: ILReturn * body: ILLazyMethodBody * isEntryPoint:bool * genericParams: ILGenericParameterDefs * securityDecls: ILSecurityDecls * customAttrs: ILAttributes -> ILMethodDef @@ -1063,16 +1065,16 @@ type ILMethodDefs = member FindByName: string -> ILMethodDef list /// Field definitions. -[] +[] type ILFieldDef = /// Functional creation of a value using delayed reading via a metadata index - new: name: string * fieldType: ILType * attributes: FieldAttributes * data: byte[] option * + static member CreateStored: name: string * fieldType: ILType * attributes: FieldAttributes * data: byte[] option * literalValue: ILFieldInit option * offset: int32 option * marshal: ILNativeType option * customAttrsStored: ILAttributesStored * metadataIndex: int32 -> ILFieldDef /// Functional creation of a value, immediate - new: name: string * fieldType: ILType * attributes: FieldAttributes * data: byte[] option * + static member Create: name: string * fieldType: ILType * attributes: FieldAttributes * data: byte[] option * literalValue: ILFieldInit option * offset: int32 option * marshal: ILNativeType option * customAttrs: ILAttributes -> ILFieldDef @@ -1112,16 +1114,16 @@ type ILFieldDefs = member LookupByName: string -> ILFieldDef list /// Event definitions. -[] +[] type ILEventDef = /// Functional creation of a value, using delayed reading via a metadata index, for ilread.fs - new: eventType: ILType option * name: string * attributes: EventAttributes * addMethod: ILMethodRef * + static member CreateStored: eventType: ILType option * name: string * attributes: EventAttributes * addMethod: ILMethodRef * removeMethod: ILMethodRef * fireMethod: ILMethodRef option * otherMethods: ILMethodRef list * customAttrsStored: ILAttributesStored * metadataIndex: int32 -> ILEventDef /// Functional creation of a value, immediate - new: eventType: ILType option * name: string * attributes: EventAttributes * addMethod: ILMethodRef * + static member Create: eventType: ILType option * name: string * attributes: EventAttributes * addMethod: ILMethodRef * removeMethod: ILMethodRef * fireMethod: ILMethodRef option * otherMethods: ILMethodRef list * customAttrs: ILAttributes -> ILEventDef @@ -1148,16 +1150,16 @@ type ILEventDefs = member LookupByName: string -> ILEventDef list /// Property definitions -[] +[] type ILPropertyDef = /// Functional creation of a value, using delayed reading via a metadata index, for ilread.fs - new: name: string * attributes: PropertyAttributes * setMethod: ILMethodRef option * getMethod: ILMethodRef option * + static member CreateStored: name: string * attributes: PropertyAttributes * setMethod: ILMethodRef option * getMethod: ILMethodRef option * callingConv: ILThisConvention * propertyType: ILType * init: ILFieldInit option * args: ILTypes * customAttrsStored: ILAttributesStored * metadataIndex: int32 -> ILPropertyDef /// Functional creation of a value, immediate - new: name: string * attributes: PropertyAttributes * setMethod: ILMethodRef option * getMethod: ILMethodRef option * + static member Create: name: string * attributes: PropertyAttributes * setMethod: ILMethodRef option * getMethod: ILMethodRef option * callingConv: ILThisConvention * propertyType: ILType * init: ILFieldInit option * args: ILTypes * customAttrs: ILAttributes -> ILPropertyDef @@ -1253,16 +1255,16 @@ type ILTypeDefs = member FindByName: string -> ILTypeDef /// Represents IL Type Definitions. -and [] +and [] ILTypeDef = /// Functional creation of a value, using delayed reading via a metadata index, for ilread.fs - new: name: string * attributes: TypeAttributes * layout: ILTypeDefLayout * implements: ILTypes * genericParams: ILGenericParameterDefs * + static member CreateStored: name: string * attributes: TypeAttributes * layout: ILTypeDefLayout * implements: ILTypes * genericParams: ILGenericParameterDefs * extends: ILType option * methods: ILMethodDefs * nestedTypes: ILTypeDefs * fields: ILFieldDefs * methodImpls: ILMethodImplDefs * events: ILEventDefs * properties: ILPropertyDefs * securityDeclsStored: ILSecurityDeclsStored * customAttrsStored: ILAttributesStored * metadataIndex: int32 -> ILTypeDef /// Functional creation of a value, immediate - new: name: string * attributes: TypeAttributes * layout: ILTypeDefLayout * implements: ILTypes * genericParams: ILGenericParameterDefs * + static member Create: name: string * attributes: TypeAttributes * layout: ILTypeDefLayout * implements: ILTypes * genericParams: ILGenericParameterDefs * extends: ILType option * methods: ILMethodDefs * nestedTypes: ILTypeDefs * fields: ILFieldDefs * methodImpls: ILMethodImplDefs * events: ILEventDefs * properties: ILPropertyDefs * securityDecls: ILSecurityDecls * customAttrs: ILAttributes -> ILTypeDef diff --git a/src/absil/ildiag.fs b/src/absil/ildiag.fs index de7411fbf9b..7cca91ba7f9 100644 --- a/src/absil/ildiag.fs +++ b/src/absil/ildiag.fs @@ -6,6 +6,12 @@ module internal FSharp.Compiler.AbstractIL.Diagnostics open Internal.Utilities +#if FABLE_COMPILER +let dprintf fmt = printf fmt +let dprintfn fmt = printfn fmt +let dprintn s = printfn "%s" s +#else + let diagnosticsLog = ref (Some stdout) let setDiagnosticsChannel s = diagnosticsLog := s @@ -21,3 +27,4 @@ let dprintf (fmt: Format<_,_,_,_>) = let dprintfn (fmt: Format<_,_,_,_>) = Printf.kfprintf dflushn (match !diagnosticsLog with None -> System.IO.TextWriter.Null | Some d -> d) fmt +#endif \ No newline at end of file diff --git a/src/absil/ildiag.fsi b/src/absil/ildiag.fsi index 4be1d87bc4c..850569d0546 100644 --- a/src/absil/ildiag.fsi +++ b/src/absil/ildiag.fsi @@ -11,7 +11,9 @@ module internal FSharp.Compiler.AbstractIL.Diagnostics open System.IO open Microsoft.FSharp.Core.Printf +#if !FABLE_COMPILER val public setDiagnosticsChannel: TextWriter option -> unit +#endif val public dprintfn: TextWriterFormat<'a> -> 'a val public dprintf: TextWriterFormat<'a> -> 'a diff --git a/src/absil/illib.fs b/src/absil/illib.fs index c4ded950d0d..e83e8a14ea6 100644 --- a/src/absil/illib.fs +++ b/src/absil/illib.fs @@ -43,6 +43,7 @@ let inline (===) x y = LanguagePrimitives.PhysicalEquality x y /// We set the limit to slightly under that to allow for some 'slop' let LOH_SIZE_THRESHOLD_BYTES = 84_900 +#if !FABLE_COMPILER // no Process support //--------------------------------------------------------------------- // Library: ReportTime //--------------------------------------------------------------------- @@ -56,13 +57,19 @@ let reportTime = let first = match !tFirst with None -> (tFirst := Some t; t) | Some t -> t printf "ilwrite: TIME %10.3f (total) %10.3f (delta) - %s\n" (t - first) (t - prev) descr tPrev := Some t +#endif //------------------------------------------------------------------------- // Library: projections //------------------------------------------------------------------------ -[] /// An efficient lazy for inline storage in a class type. Results in fewer thunks. +#if FABLE_COMPILER // no threading support +type InlineDelayInit<'T when 'T : not struct>(f: unit -> 'T) = + let store = lazy(f()) + member x.Value = store.Force() +#else +[] type InlineDelayInit<'T when 'T : not struct> = new (f: unit -> 'T) = {store = Unchecked.defaultof<'T>; func = Func<_>(f) } val mutable store : 'T @@ -75,6 +82,7 @@ type InlineDelayInit<'T when 'T : not struct> = let res = LazyInitializer.EnsureInitialized(&x.store, x.func) x.func <- Unchecked.defaultof<_> res +#endif //------------------------------------------------------------------------- // Library: projections @@ -299,7 +307,9 @@ module List = | _ -> true let mapq (f: 'T -> 'T) inp = +#if !FABLE_COMPILER assert not (typeof<'T>.IsValueType) +#endif match inp with | [] -> inp | [h1a] -> @@ -470,7 +480,11 @@ module ResizeArray = /// This is done to help prevent a stop-the-world collection of the single large array, instead allowing for a greater /// probability of smaller collections. Stop-the-world is still possible, just less likely. let mapToSmallArrayChunks f (inp: ResizeArray<'t>) = +#if FABLE_COMPILER + let itemSizeBytes = 8 +#else let itemSizeBytes = sizeof<'t> +#endif // rounding down here is good because it ensures we don't go over let maxArrayItemCount = LOH_SIZE_THRESHOLD_BYTES / itemSizeBytes @@ -527,7 +541,7 @@ module String = let lowerCaseFirstChar (str: string) = if String.IsNullOrEmpty str - || Char.IsLower(str, 0) then str else + || Char.IsLower(str.[0]) then str else let strArr = toCharArray str match Array.tryHead strArr with | None -> str @@ -556,17 +570,17 @@ module String = let split options (separator: string []) (value: string) = if isNull value then null else value.Split(separator, options) - let (|StartsWith|_|) pattern value = + let (|StartsWith|_|) (pattern: string) value = if String.IsNullOrWhiteSpace value then None elif value.StartsWithOrdinal pattern then Some() else None - let (|Contains|_|) pattern value = + let (|Contains|_|) (pattern: string) value = if String.IsNullOrWhiteSpace value then None - elif value.Contains pattern then + elif value.Contains(pattern) then Some() else None @@ -585,6 +599,7 @@ module String = // http://stackoverflow.com/questions/19365404/stringreader-omits-trailing-linebreak yield String.Empty |] +#endif module Dictionary = let inline newWithSize (size: int) = Dictionary<_, _>(size, HashIdentity.Structural) @@ -642,10 +657,12 @@ let AssumeAnyCallerThreadWithoutEvidence () = Unchecked.defaultof LockToken> () = Unchecked.defaultof<'LockTokenType> +#if !FABLE_COMPILER /// Encapsulates a lock associated with a particular token-type representing the acquisition of that lock. type Lock<'LockTokenType when 'LockTokenType :> LockToken>() = let lockObj = obj() member __.AcquireLock f = lock lockObj (fun () -> f (AssumeLockWithoutEvidence<'LockTokenType>())) +#endif //--------------------------------------------------- // Misc @@ -751,7 +768,11 @@ module Cancellable = /// Run the computation in a mode where it may not be cancelled. The computation never results in a /// ValueOrCancelled.Cancelled. let runWithoutCancellation comp = +#if FABLE_COMPILER + let res = run (System.Threading.CancellationToken()) comp +#else let res = run CancellationToken.None comp +#endif match res with | ValueOrCancelled.Cancelled _ -> failwith "unexpected cancellation" | ValueOrCancelled.Value r -> r @@ -855,6 +876,7 @@ module Eventually = let force ctok e = Option.get (forceWhile ctok (fun () -> true) e) +#if !FABLE_COMPILER /// Keep running the computation bit by bit until a time limit is reached. /// The runner gets called each time the computation is restarted /// @@ -889,6 +911,7 @@ module Eventually = return! loop r } loop e +#endif let rec bind k e = match e with @@ -1034,12 +1057,16 @@ type LazyWithContext<'T, 'ctxt> = match x.funcOrException with | null -> x.value | _ -> +#if FABLE_COMPILER // no threading support + x.UnsynchronizedForce(ctxt) +#else // Enter the lock in case another thread is in the process of evaluating the result Monitor.Enter x; try x.UnsynchronizedForce ctxt finally Monitor.Exit x +#endif member x.UnsynchronizedForce ctxt = match x.funcOrException with @@ -1267,6 +1294,7 @@ module Shim = type IFileSystem = +#if !FABLE_COMPILER /// A shim over File.ReadAllBytes abstract ReadAllBytesShim: fileName: string -> byte[] @@ -1278,6 +1306,7 @@ module Shim = /// A shim over FileStream with FileMode.Open, FileAccess.Write, FileShare.Read abstract FileStreamWriteExistingShim: fileName: string -> Stream +#endif /// Take in a filename with an absolute path, and return the same filename /// but canonicalized with respect to extra path separators (e.g. C:\\\\foo.txt) @@ -1290,6 +1319,7 @@ module Shim = /// A shim over Path.IsInvalidPath abstract IsInvalidPathShim: filename: string -> bool +#if !FABLE_COMPILER /// A shim over Path.GetTempPath abstract GetTempPathShim : unit -> string @@ -1310,11 +1340,13 @@ module Shim = /// Used to determine if a file will not be subject to deletion during the lifetime of a typical client process. abstract IsStableFileHeuristic: fileName: string -> bool +#endif type DefaultFileSystem() = interface IFileSystem with +#if !FABLE_COMPILER member __.AssemblyLoadFrom(fileName: string) = Assembly.UnsafeLoadFrom fileName @@ -1330,6 +1362,9 @@ module Shim = member __.FileStreamWriteExistingShim (fileName: string) = new FileStream(fileName, FileMode.Open, FileAccess.Write, FileShare.Read, 0x1000, false) :> Stream member __.GetFullPathShim (fileName: string) = System.IO.Path.GetFullPath fileName +#else //FABLE_COMPILER + member __.GetFullPathShim (fileName: string) = fileName +#endif member __.IsPathRootedShim (path: string) = Path.IsPathRooted path @@ -1348,6 +1383,7 @@ module Shim = let filename = Path.GetFileName path isInvalidDirectory directory || isInvalidFilename filename +#if !FABLE_COMPILER member __.GetTempPathShim() = Path.GetTempPath() member __.GetLastWriteTimeShim (fileName: string) = File.GetLastWriteTimeUtc fileName @@ -1363,9 +1399,12 @@ module Shim = directory.Contains("packages/") || directory.Contains("packages\\") || directory.Contains("lib/mono/") +#endif let mutable FileSystem = DefaultFileSystem() :> IFileSystem +#if !FABLE_COMPILER + type File with static member ReadBinaryChunk (fileName, start, len) = @@ -1377,3 +1416,4 @@ module Shim = n <- n + stream.Read(buffer, n, len-n) buffer +#endif diff --git a/src/absil/ilread.fs b/src/absil/ilread.fs index 38c1c5ff817..56d87bf4a3a 100644 --- a/src/absil/ilread.fs +++ b/src/absil/ilread.fs @@ -20,7 +20,9 @@ open Internal.Utilities open Internal.Utilities.Collections open FSharp.Compiler.AbstractIL open FSharp.Compiler.AbstractIL.Internal +#if !FABLE_COMPILER open FSharp.Compiler.AbstractIL.Internal.Support +#endif open FSharp.Compiler.AbstractIL.Diagnostics open FSharp.Compiler.AbstractIL.Internal.BinaryConstants open FSharp.Compiler.AbstractIL.IL @@ -33,10 +35,17 @@ open System.Reflection let checking = false let logging = false let _ = if checking then dprintn "warning: ILBinaryReader.checking is on" +#if FABLE_COMPILER +let noStableFileHeuristic = false +let alwaysMemoryMapFSC = false +let stronglyHeldReaderCacheSizeDefault = 30 +let stronglyHeldReaderCacheSize = stronglyHeldReaderCacheSizeDefault +#else let noStableFileHeuristic = try (System.Environment.GetEnvironmentVariable("FSharp_NoStableFileHeuristic") <> null) with _ -> false let alwaysMemoryMapFSC = try (System.Environment.GetEnvironmentVariable("FSharp_AlwaysMemoryMapCommandLineCompiler") <> null) with _ -> false let stronglyHeldReaderCacheSizeDefault = 30 let stronglyHeldReaderCacheSize = try (match System.Environment.GetEnvironmentVariable("FSharp_StronglyHeldBinaryReaderCacheSize") with null -> stronglyHeldReaderCacheSizeDefault | s -> int32 s) with _ -> stronglyHeldReaderCacheSizeDefault +#endif let singleOfBits (x: int32) = System.BitConverter.ToSingle(System.BitConverter.GetBytes x, 0) let doubleOfBits (x: int64) = System.BitConverter.Int64BitsToDouble x @@ -137,6 +146,8 @@ type BinaryFile = /// desired lifetime. abstract GetView: unit -> BinaryView +#if !FABLE_COMPILER + /// A view over a raw pointer to memory type RawMemoryView(obj: obj, start: nativeint, len: int) = inherit BinaryView() @@ -304,6 +315,8 @@ type MemoryMapFile(fileName: string, view: MemoryMapView, hMap: MemoryMapping.HA interface BinaryFile with override __.GetView() = (view :> BinaryView) +#endif //!FABLE_COMPILER + /// Read file from memory blocks type ByteView(bytes: byte[]) = inherit BinaryView() @@ -343,6 +356,8 @@ type ByteFile(fileName: string, bytes: byte[]) = interface BinaryFile with override bf.GetView() = view :> BinaryView +#if !FABLE_COMPILER + /// Same as ByteFile but holds the bytes weakly. The bytes will be re-read from the backing file when a view is requested. /// This is the default implementation used by F# Compiler Services when accessing "stable" binaries. It is not used /// by Visual Studio, where tryGetMetadataSnapshot provides a RawMemoryFile backed by Roslyn data. @@ -382,6 +397,7 @@ type WeakByteFile(fileName: string, chunk: (int * int) option) = (ByteView strongBytes :> BinaryView) +#endif //!FABLE_COMPILER let seekReadByte (mdv: BinaryView) addr = mdv.ReadByte addr let seekReadBytes (mdv: BinaryView) addr len = mdv.ReadBytes addr len @@ -1139,6 +1155,31 @@ type ILMetadataReader = securityDeclsReader_Assembly: ILSecurityDeclsStored typeDefReader: ILTypeDefStored } +#if FABLE_COMPILER // no byref parameters + +type byref<'T> = ref<'T> +let inline (~&) (x: ref<'T>) = x +let inline rowAddr (ctxt: ILMetadataReader) (tn: TableName) (idx: int) = + ref (ctxt.rowAddr tn idx) + +let seekReadUInt16Adv mdv (addr: byref) = + let res = seekReadUInt16 mdv !addr + addr := !addr + 2 + res + +let seekReadInt32Adv mdv (addr: byref) = + let res = seekReadInt32 mdv !addr + addr := !addr + 4 + res + +let seekReadUInt16AsInt32Adv mdv (addr: byref) = + let res = seekReadUInt16AsInt32 mdv !addr + addr := !addr + 2 + res + +#else + +let inline rowAddr (ctxt: ILMetadataReader) = ctxt.rowAddr let seekReadUInt16Adv mdv (addr: byref) = let res = seekReadUInt16 mdv addr @@ -1155,6 +1196,8 @@ let seekReadUInt16AsInt32Adv mdv (addr: byref) = addr <- addr+2 res +#endif + let seekReadTaggedIdx f nbits big mdv (addr: byref) = let tok = if big then seekReadInt32Adv mdv &addr else seekReadUInt16AsInt32Adv mdv &addr tokToTaggedIdx f nbits tok @@ -1186,7 +1229,7 @@ let seekReadBlobIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadId let seekReadModuleRow (ctxt: ILMetadataReader) mdv idx = if idx = 0 then failwith "cannot read Module table row 0" - let mutable addr = ctxt.rowAddr TableNames.Module idx + let mutable addr = rowAddr ctxt TableNames.Module idx let generation = seekReadUInt16Adv mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr let mvidIdx = seekReadGuidIdx ctxt mdv &addr @@ -1196,7 +1239,7 @@ let seekReadModuleRow (ctxt: ILMetadataReader) mdv idx = /// Read Table ILTypeRef. let seekReadTypeRefRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.TypeRef idx + let mutable addr = rowAddr ctxt TableNames.TypeRef idx let scopeIdx = seekReadResolutionScopeIdx ctxt mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr let namespaceIdx = seekReadStringIdx ctxt mdv &addr @@ -1207,7 +1250,7 @@ let seekReadTypeDefRow (ctxt: ILMetadataReader) idx = ctxt.seekReadTypeDefRow id let seekReadTypeDefRowUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() - let mutable addr = ctxt.rowAddr TableNames.TypeDef idx + let mutable addr = rowAddr ctxt TableNames.TypeDef idx let flags = seekReadInt32Adv mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr let namespaceIdx = seekReadStringIdx ctxt mdv &addr @@ -1218,7 +1261,7 @@ let seekReadTypeDefRowUncached ctxtH idx = /// Read Table Field. let seekReadFieldRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.Field idx + let mutable addr = rowAddr ctxt TableNames.Field idx let flags = seekReadUInt16AsInt32Adv mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr let typeIdx = seekReadBlobIdx ctxt mdv &addr @@ -1226,7 +1269,7 @@ let seekReadFieldRow (ctxt: ILMetadataReader) mdv idx = /// Read Table Method. let seekReadMethodRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.Method idx + let mutable addr = rowAddr ctxt TableNames.Method idx let codeRVA = seekReadInt32Adv mdv &addr let implflags = seekReadUInt16AsInt32Adv mdv &addr let flags = seekReadUInt16AsInt32Adv mdv &addr @@ -1237,7 +1280,7 @@ let seekReadMethodRow (ctxt: ILMetadataReader) mdv idx = /// Read Table Param. let seekReadParamRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.Param idx + let mutable addr = rowAddr ctxt TableNames.Param idx let flags = seekReadUInt16AsInt32Adv mdv &addr let seq = seekReadUInt16AsInt32Adv mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr @@ -1245,14 +1288,14 @@ let seekReadParamRow (ctxt: ILMetadataReader) mdv idx = /// Read Table InterfaceImpl. let seekReadInterfaceImplRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.InterfaceImpl idx + let mutable addr = rowAddr ctxt TableNames.InterfaceImpl idx let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr let intfIdx = seekReadTypeDefOrRefOrSpecIdx ctxt mdv &addr (tidx, intfIdx) /// Read Table MemberRef. let seekReadMemberRefRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.MemberRef idx + let mutable addr = rowAddr ctxt TableNames.MemberRef idx let mrpIdx = seekReadMemberRefParentIdx ctxt mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr let typeIdx = seekReadBlobIdx ctxt mdv &addr @@ -1263,7 +1306,7 @@ let seekReadConstantRow (ctxt: ILMetadataReader) idx = ctxt.seekReadConstantRow let seekReadConstantRowUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() - let mutable addr = ctxt.rowAddr TableNames.Constant idx + let mutable addr = rowAddr ctxt TableNames.Constant idx let kind = seekReadUInt16Adv mdv &addr let parentIdx = seekReadHasConstantIdx ctxt mdv &addr let valIdx = seekReadBlobIdx ctxt mdv &addr @@ -1272,7 +1315,7 @@ let seekReadConstantRowUncached ctxtH idx = /// Read Table CustomAttribute. let seekReadCustomAttributeRow (ctxt: ILMetadataReader) idx = let mdv = ctxt.mdfile.GetView() - let mutable addr = ctxt.rowAddr TableNames.CustomAttribute idx + let mutable addr = rowAddr ctxt TableNames.CustomAttribute idx let parentIdx = seekReadHasCustomAttributeIdx ctxt mdv &addr let typeIdx = seekReadCustomAttributeTypeIdx ctxt mdv &addr let valIdx = seekReadBlobIdx ctxt mdv &addr @@ -1280,14 +1323,14 @@ let seekReadCustomAttributeRow (ctxt: ILMetadataReader) idx = /// Read Table FieldMarshal. let seekReadFieldMarshalRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.FieldMarshal idx + let mutable addr = rowAddr ctxt TableNames.FieldMarshal idx let parentIdx = seekReadHasFieldMarshalIdx ctxt mdv &addr let typeIdx = seekReadBlobIdx ctxt mdv &addr (parentIdx, typeIdx) /// Read Table Permission. let seekReadPermissionRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.Permission idx + let mutable addr = rowAddr ctxt TableNames.Permission idx let action = seekReadUInt16Adv mdv &addr let parentIdx = seekReadHasDeclSecurityIdx ctxt mdv &addr let typeIdx = seekReadBlobIdx ctxt mdv &addr @@ -1295,7 +1338,7 @@ let seekReadPermissionRow (ctxt: ILMetadataReader) mdv idx = /// Read Table ClassLayout. let seekReadClassLayoutRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.ClassLayout idx + let mutable addr = rowAddr ctxt TableNames.ClassLayout idx let pack = seekReadUInt16Adv mdv &addr let size = seekReadInt32Adv mdv &addr let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr @@ -1303,27 +1346,27 @@ let seekReadClassLayoutRow (ctxt: ILMetadataReader) mdv idx = /// Read Table FieldLayout. let seekReadFieldLayoutRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.FieldLayout idx + let mutable addr = rowAddr ctxt TableNames.FieldLayout idx let offset = seekReadInt32Adv mdv &addr let fidx = seekReadUntaggedIdx TableNames.Field ctxt mdv &addr (offset, fidx) //// Read Table StandAloneSig. let seekReadStandAloneSigRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.StandAloneSig idx + let mutable addr = rowAddr ctxt TableNames.StandAloneSig idx let sigIdx = seekReadBlobIdx ctxt mdv &addr sigIdx /// Read Table EventMap. let seekReadEventMapRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.EventMap idx + let mutable addr = rowAddr ctxt TableNames.EventMap idx let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr let eventsIdx = seekReadUntaggedIdx TableNames.Event ctxt mdv &addr (tidx, eventsIdx) /// Read Table Event. let seekReadEventRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.Event idx + let mutable addr = rowAddr ctxt TableNames.Event idx let flags = seekReadUInt16AsInt32Adv mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr let typIdx = seekReadTypeDefOrRefOrSpecIdx ctxt mdv &addr @@ -1331,14 +1374,14 @@ let seekReadEventRow (ctxt: ILMetadataReader) mdv idx = /// Read Table PropertyMap. let seekReadPropertyMapRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.PropertyMap idx + let mutable addr = rowAddr ctxt TableNames.PropertyMap idx let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr let propsIdx = seekReadUntaggedIdx TableNames.Property ctxt mdv &addr (tidx, propsIdx) /// Read Table Property. let seekReadPropertyRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.Property idx + let mutable addr = rowAddr ctxt TableNames.Property idx let flags = seekReadUInt16AsInt32Adv mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr let typIdx = seekReadBlobIdx ctxt mdv &addr @@ -1349,7 +1392,7 @@ let seekReadMethodSemanticsRow (ctxt: ILMetadataReader) idx = ctxt.seekReadMetho let seekReadMethodSemanticsRowUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() - let mutable addr = ctxt.rowAddr TableNames.MethodSemantics idx + let mutable addr = rowAddr ctxt TableNames.MethodSemantics idx let flags = seekReadUInt16AsInt32Adv mdv &addr let midx = seekReadUntaggedIdx TableNames.Method ctxt mdv &addr let assocIdx = seekReadHasSemanticsIdx ctxt mdv &addr @@ -1357,7 +1400,7 @@ let seekReadMethodSemanticsRowUncached ctxtH idx = /// Read Table MethodImpl. let seekReadMethodImplRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.MethodImpl idx + let mutable addr = rowAddr ctxt TableNames.MethodImpl idx let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr let mbodyIdx = seekReadMethodDefOrRefIdx ctxt mdv &addr let mdeclIdx = seekReadMethodDefOrRefIdx ctxt mdv &addr @@ -1365,19 +1408,19 @@ let seekReadMethodImplRow (ctxt: ILMetadataReader) mdv idx = /// Read Table ILModuleRef. let seekReadModuleRefRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.ModuleRef idx + let mutable addr = rowAddr ctxt TableNames.ModuleRef idx let nameIdx = seekReadStringIdx ctxt mdv &addr nameIdx /// Read Table ILTypeSpec. let seekReadTypeSpecRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.TypeSpec idx + let mutable addr = rowAddr ctxt TableNames.TypeSpec idx let blobIdx = seekReadBlobIdx ctxt mdv &addr blobIdx /// Read Table ImplMap. let seekReadImplMapRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.ImplMap idx + let mutable addr = rowAddr ctxt TableNames.ImplMap idx let flags = seekReadUInt16AsInt32Adv mdv &addr let forwrdedIdx = seekReadMemberForwardedIdx ctxt mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr @@ -1386,14 +1429,14 @@ let seekReadImplMapRow (ctxt: ILMetadataReader) mdv idx = /// Read Table FieldRVA. let seekReadFieldRVARow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.FieldRVA idx + let mutable addr = rowAddr ctxt TableNames.FieldRVA idx let rva = seekReadInt32Adv mdv &addr let fidx = seekReadUntaggedIdx TableNames.Field ctxt mdv &addr (rva, fidx) /// Read Table Assembly. let seekReadAssemblyRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.Assembly idx + let mutable addr = rowAddr ctxt TableNames.Assembly idx let hash = seekReadInt32Adv mdv &addr let v1 = seekReadUInt16Adv mdv &addr let v2 = seekReadUInt16Adv mdv &addr @@ -1407,7 +1450,7 @@ let seekReadAssemblyRow (ctxt: ILMetadataReader) mdv idx = /// Read Table ILAssemblyRef. let seekReadAssemblyRefRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.AssemblyRef idx + let mutable addr = rowAddr ctxt TableNames.AssemblyRef idx let v1 = seekReadUInt16Adv mdv &addr let v2 = seekReadUInt16Adv mdv &addr let v3 = seekReadUInt16Adv mdv &addr @@ -1421,7 +1464,7 @@ let seekReadAssemblyRefRow (ctxt: ILMetadataReader) mdv idx = /// Read Table File. let seekReadFileRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.File idx + let mutable addr = rowAddr ctxt TableNames.File idx let flags = seekReadInt32Adv mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr let hashValueIdx = seekReadBlobIdx ctxt mdv &addr @@ -1429,7 +1472,7 @@ let seekReadFileRow (ctxt: ILMetadataReader) mdv idx = /// Read Table ILExportedTypeOrForwarder. let seekReadExportedTypeRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.ExportedType idx + let mutable addr = rowAddr ctxt TableNames.ExportedType idx let flags = seekReadInt32Adv mdv &addr let tok = seekReadInt32Adv mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr @@ -1439,7 +1482,7 @@ let seekReadExportedTypeRow (ctxt: ILMetadataReader) mdv idx = /// Read Table ManifestResource. let seekReadManifestResourceRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.ManifestResource idx + let mutable addr = rowAddr ctxt TableNames.ManifestResource idx let offset = seekReadInt32Adv mdv &addr let flags = seekReadInt32Adv mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr @@ -1451,14 +1494,14 @@ let seekReadNestedRow (ctxt: ILMetadataReader) idx = ctxt.seekReadNestedRow idx let seekReadNestedRowUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() - let mutable addr = ctxt.rowAddr TableNames.Nested idx + let mutable addr = rowAddr ctxt TableNames.Nested idx let nestedIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr let enclIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr (nestedIdx, enclIdx) /// Read Table GenericParam. let seekReadGenericParamRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.GenericParam idx + let mutable addr = rowAddr ctxt TableNames.GenericParam idx let seq = seekReadUInt16Adv mdv &addr let flags = seekReadUInt16Adv mdv &addr let ownerIdx = seekReadTypeOrMethodDefIdx ctxt mdv &addr @@ -1467,14 +1510,14 @@ let seekReadGenericParamRow (ctxt: ILMetadataReader) mdv idx = // Read Table GenericParamConstraint. let seekReadGenericParamConstraintRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.GenericParamConstraint idx + let mutable addr = rowAddr ctxt TableNames.GenericParamConstraint idx let pidx = seekReadUntaggedIdx TableNames.GenericParam ctxt mdv &addr let constraintIdx = seekReadTypeDefOrRefOrSpecIdx ctxt mdv &addr (pidx, constraintIdx) /// Read Table ILMethodSpec. let seekReadMethodSpecRow (ctxt: ILMetadataReader) mdv idx = - let mutable addr = ctxt.rowAddr TableNames.MethodSpec idx + let mutable addr = rowAddr ctxt TableNames.MethodSpec idx let mdorIdx = seekReadMethodDefOrRefIdx ctxt mdv &addr let instIdx = seekReadBlobIdx ctxt mdv &addr (mdorIdx, instIdx) @@ -1548,13 +1591,15 @@ let readBlobHeapAsDouble ctxt vidx = fst (sigptrGetDouble (readBlobHeap ctxt vid let readNativeResources (pectxt: PEReader) = [ if pectxt.nativeResourcesSize <> 0x0 && pectxt.nativeResourcesAddr <> 0x0 then let start = pectxt.anyV2P (pectxt.fileName + ": native resources", pectxt.nativeResourcesAddr) +#if !FABLE_COMPILER if pectxt.noFileOnDisk then let unlinkedResource = let linkedResource = seekReadBytes (pectxt.pefile.GetView()) start pectxt.nativeResourcesSize unlinkResource pectxt.nativeResourcesAddr linkedResource yield ILNativeResource.Out unlinkedResource else - yield ILNativeResource.In (pectxt.fileName, pectxt.nativeResourcesAddr, start, pectxt.nativeResourcesSize ) ] +#endif + yield ILNativeResource.In (pectxt.fileName, pectxt.nativeResourcesAddr, start, pectxt.nativeResourcesSize ) ] let getDataEndPointsDelayed (pectxt: PEReader) ctxtH = @@ -1796,7 +1841,7 @@ and typeDefReader ctxtH: ILTypeDefStored = let mimpls = seekReadMethodImpls ctxt numtypars idx let props = seekReadProperties ctxt numtypars idx let events = seekReadEvents ctxt numtypars idx - ILTypeDef(name=nm, + ILTypeDef.CreateStored(name=nm, genericParams=typars, attributes= enum(flags), layout = layout, @@ -1988,7 +2033,7 @@ and seekReadField ctxt mdv (numtypars, hasLayout) (idx: int) = let (flags, nameIdx, typeIdx) = seekReadFieldRow ctxt mdv idx let nm = readStringHeap ctxt nameIdx let isStatic = (flags &&& 0x0010) <> 0 - ILFieldDef(name = nm, + ILFieldDef.CreateStored(name = nm, fieldType= readBlobHeapAsFieldSig ctxt numtypars typeIdx, attributes = enum(flags), literalValue = (if (flags &&& 0x8000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_FieldDef, idx)))), @@ -2391,7 +2436,7 @@ and seekReadMethod (ctxt: ILMetadataReader) mdv numtypars (idx: int) = | None -> methBodyNotAvailable | Some pectxt -> seekReadMethodRVA pectxt ctxt (idx, nm, internalcall, noinline, aggressiveinline, numtypars) codeRVA - ILMethodDef(name=nm, + ILMethodDef.CreateStored(name=nm, attributes = enum(flags), implAttributes= enum(implflags), securityDeclsStored=ctxt.securityDeclsReader_MethodDef, @@ -2477,7 +2522,7 @@ and seekReadMethodSemantics ctxt id = and seekReadEvent ctxt mdv numtypars idx = let (flags, nameIdx, typIdx) = seekReadEventRow ctxt mdv idx - ILEventDef(eventType = seekReadOptionalTypeDefOrRef ctxt numtypars AsObject typIdx, + ILEventDef.CreateStored(eventType = seekReadOptionalTypeDefOrRef ctxt numtypars AsObject typIdx, name = readStringHeap ctxt nameIdx, attributes = enum(flags), addMethod= seekReadMethodSemantics ctxt (0x0008, TaggedIndex(hs_Event, idx)), @@ -2521,7 +2566,7 @@ and seekReadProperty ctxt mdv numtypars idx = | Some mref -> mref.CallingConv .ThisConv | None -> cc - ILPropertyDef(name=readStringHeap ctxt nameIdx, + ILPropertyDef.CreateStored(name=readStringHeap ctxt nameIdx, callingConv = cc2, attributes = enum(flags), setMethod=setter, @@ -3236,11 +3281,15 @@ and seekReadManifestResources (ctxt: ILMetadataReader) (mdv: BinaryView) (pectxt let start = pectxtEager.anyV2P ("resource", offset + pectxtEager.resourcesAddr) let resourceLength = seekReadInt32 pevEager start let offsetOfBytesFromStartOfPhysicalPEFile = start + 4 +#if FABLE_COMPILER + let bytes = seekReadBytes pevEager offsetOfBytesFromStartOfPhysicalPEFile resourceLength + ILResourceLocation.LocalOut bytes +#else if pectxtEager.noFileOnDisk then ILResourceLocation.LocalOut (seekReadBytes pevEager offsetOfBytesFromStartOfPhysicalPEFile resourceLength) else ILResourceLocation.LocalIn (ctxt.fileName, offsetOfBytesFromStartOfPhysicalPEFile, resourceLength) - +#endif | ILScopeRef.Module mref -> ILResourceLocation.File (mref, offset) | ILScopeRef.Assembly aref -> ILResourceLocation.Assembly aref @@ -3961,6 +4010,15 @@ type ILModuleReaderImpl(ilModule: ILModuleDef, ilAssemblyRefs: Lazy BinaryFile + let ilModule, ilAssemblyRefs, pdb = openPE (fileName, pefile, opts.pdbDirPath, (opts.reduceMemoryUsage = ReduceMemoryFlag.Yes), opts.ilGlobals, true) + new ILModuleReaderImpl(ilModule, ilAssemblyRefs, (fun () -> ClosePdbReader pdb)) :> ILModuleReader + +#else + // ++GLOBAL MUTABLE STATE (concurrency safe via locking) type ILModuleReaderCacheKey = ILModuleReaderCacheKey of string * DateTime * ILScopeRef * bool * ReduceMemoryFlag * MetadataOnlyFlag @@ -4140,3 +4198,5 @@ module Shim = OpenILModuleReader filename readerOptions let mutable AssemblyReader = DefaultAssemblyReader() :> IAssemblyReader + +#endif //!FABLE_COMPILER diff --git a/src/absil/ilread.fsi b/src/absil/ilread.fsi index 000b9cc34ff..8719f73307c 100644 --- a/src/absil/ilread.fsi +++ b/src/absil/ilread.fsi @@ -74,6 +74,7 @@ type ILModuleReader = /// ILModuleReader objects only need to be explicitly disposed if memory mapping is used, i.e. reduceMemoryUsage = false inherit System.IDisposable +#if !FABLE_COMPILER /// Open a binary reader, except first copy the entire contents of the binary into /// memory, close the file and ensure any subsequent reads happen from the in-memory store. @@ -82,6 +83,8 @@ val internal OpenILModuleReader: string -> ILReaderOptions -> ILModuleReader val internal ClearAllILModuleReaderCache : unit -> unit +#endif + /// Open a binary reader based on the given bytes. val internal OpenILModuleReaderFromBytes: fileNameForDebugOutput:string -> assemblyContents: byte[] -> options: ILReaderOptions -> ILModuleReader @@ -94,6 +97,8 @@ type Statistics = val GetStatistics : unit -> Statistics +#if !FABLE_COMPILER + [] module Shim = @@ -105,3 +110,5 @@ module Shim = interface IAssemblyReader val mutable AssemblyReader: IAssemblyReader + +#endif diff --git a/src/buildtools/buildtools.targets b/src/buildtools/buildtools.targets index 185fd4d0599..5c44c12cd40 100644 --- a/src/buildtools/buildtools.targets +++ b/src/buildtools/buildtools.targets @@ -20,7 +20,7 @@ BeforeTargets="CoreCompile"> - $(ArtifactsDir)\Bootstrap\fslex\fslex.dll + $(ArtifactsDir)\bin\fslex\Proto\netcoreapp2.1\fslex.dll @@ -43,7 +43,7 @@ BeforeTargets="CoreCompile"> - $(ArtifactsDir)\Bootstrap\fsyacc\fsyacc.dll + $(ArtifactsDir)\bin\fsyacc\Proto\netcoreapp2.1\fsyacc.dll diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 239015820aa..bd123fd559e 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -17,7 +17,9 @@ open Internal.Utilities.Text open FSharp.Compiler.AbstractIL open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILBinaryReader +#if !FABLE_COMPILER open FSharp.Compiler.AbstractIL.ILPdbWriter +#endif open FSharp.Compiler.AbstractIL.Internal open FSharp.Compiler.AbstractIL.Internal.Library open FSharp.Compiler.AbstractIL.Extensions.ILX @@ -48,7 +50,9 @@ open FSharp.Compiler.Tastops open FSharp.Compiler.TcGlobals open FSharp.Compiler.Text +#if !FABLE_COMPILER open FSharp.Compiler.DotNetFrameworkDependencies +#endif #if !NO_EXTENSIONTYPING open FSharp.Compiler.ExtensionTyping @@ -228,9 +232,11 @@ let GetRangeOfDiagnostic(err: PhasedDiagnostic) = | HashLoadedSourceHasIssues(_, _, m) | HashLoadedScriptConsideredSource m -> Some m +#if !FABLE_COMPILER // Strip TargetInvocationException wrappers | :? System.Reflection.TargetInvocationException as e -> RangeFromException e.InnerException +#endif #if !NO_EXTENSIONTYPING | :? TypeProviderError as e -> e.Range |> Some #endif @@ -357,9 +363,11 @@ let GetDiagnosticNumber(err: PhasedDiagnostic) = | PatternMatchCompilation.EnumMatchIncomplete _ -> 104 (* DO NOT CHANGE THE NUMBERS *) +#if !FABLE_COMPILER // Strip TargetInvocationException wrappers | :? System.Reflection.TargetInvocationException as e -> GetFromException e.InnerException +#endif | WrappedError(e, _) -> GetFromException e @@ -427,9 +435,11 @@ let SplitRelatedDiagnostics(err: PhasedDiagnostic) = | WrappedError (e, m) -> let e, related = SplitRelatedException e WrappedError(e.Exception, m)|>ToPhased, related +#if !FABLE_COMPILER // Strip TargetInvocationException wrappers | :? System.Reflection.TargetInvocationException as e -> SplitRelatedException e.InnerException +#endif | e -> ToPhased e, [] SplitRelatedException err.Exception @@ -437,7 +447,9 @@ let SplitRelatedDiagnostics(err: PhasedDiagnostic) = let DeclareMesssage = FSharp.Compiler.DiagnosticMessage.DeclareResourceString +#if !FABLE_COMPILER do FSComp.SR.RunStartupValidation() +#endif let SeeAlsoE() = DeclareResourceString("SeeAlso", "%s") let ConstraintSolverTupleDiffLengthsE() = DeclareResourceString("ConstraintSolverTupleDiffLengths", "%d%d") let ConstraintSolverInfiniteTypesE() = DeclareResourceString("ConstraintSolverInfiniteTypes", "%s%s") @@ -602,6 +614,19 @@ let getErrorString key = SR.GetString key let (|InvalidArgument|_|) (exn: exn) = match exn with :? ArgumentException as e -> Some e.Message | _ -> None +#if FABLE_COMPILER +type StringBuilder() = + let buf = System.Text.StringBuilder() + member x.Append(s: string) = buf.Append(s) |> ignore; x + member x.AppendLine() = x.Append("\n") + override x.ToString() = buf.ToString() + +module Printf = + let bprintf (sb: StringBuilder) = + let f (s:string) = sb.Append(s) |> ignore + Printf.kprintf f +#endif + let OutputPhasedErrorR (os: StringBuilder) (err: PhasedDiagnostic) (canSuggestNames: bool) = let suggestNames suggestionsF idText = @@ -1337,7 +1362,7 @@ let OutputPhasedErrorR (os: StringBuilder) (err: PhasedDiagnostic) (canSuggestNa os.Append(LetRecUnsound1E().Format v.DisplayName) |> ignore | LetRecUnsound (_, path, _) -> - let bos = new System.Text.StringBuilder() + let bos = new StringBuilder() (path.Tail @ [path.Head]) |> List.iter (fun (v: ValRef) -> bos.Append(LetRecUnsoundInnerE().Format v.DisplayName) |> ignore) os.Append(LetRecUnsound2E().Format (List.head path).DisplayName (bos.ToString())) |> ignore @@ -1562,6 +1587,7 @@ let OutputPhasedErrorR (os: StringBuilder) (err: PhasedDiagnostic) (canSuggestNa | MSBuildReferenceResolutionError(code, message, _) -> os.Append(MSBuildReferenceResolutionErrorE().Format message code) |> ignore +#if !FABLE_COMPILER // Strip TargetInvocationException wrappers | :? System.Reflection.TargetInvocationException as e -> OutputExceptionR os e.InnerException @@ -1577,7 +1603,7 @@ let OutputPhasedErrorR (os: StringBuilder) (err: PhasedDiagnostic) (canSuggestNa | :? IOException as e -> Printf.bprintf os "%s" e.Message | :? System.UnauthorizedAccessException as e -> Printf.bprintf os "%s" e.Message - +#endif | e -> os.Append(TargetInvocationExceptionWrapperE().Format e.Message) |> ignore #if DEBUG @@ -1591,14 +1617,14 @@ let OutputPhasedErrorR (os: StringBuilder) (err: PhasedDiagnostic) (canSuggestNa // remove any newlines and tabs let OutputPhasedDiagnostic (os: System.Text.StringBuilder) (err: PhasedDiagnostic) (flattenErrors: bool) (canSuggestNames: bool) = - let buf = new System.Text.StringBuilder() + let buf = new StringBuilder() OutputPhasedErrorR buf err canSuggestNames let s = if flattenErrors then ErrorLogger.NormalizeErrorString (buf.ToString()) else buf.ToString() os.Append s |> ignore -let SanitizeFileName fileName implicitIncludeDir = +let SanitizeFileName fileName (implicitIncludeDir: string) = // The assert below is almost ok, but it fires in two cases: // - fsi.exe sometimes passes "stdin" as a dummy filename // - if you have a #line directive, e.g. @@ -1618,6 +1644,8 @@ let SanitizeFileName fileName implicitIncludeDir = with _ -> fileName +#if !FABLE_COMPILER + [] type DiagnosticLocation = { Range: range @@ -1789,8 +1817,12 @@ let OutputDiagnosticContext prefix fileLineFn os err = Printf.bprintf os "%s%s\n" prefix line Printf.bprintf os "%s%s%s\n" prefix (String.make iA '-') (String.make iLen '^') +#endif //!FABLE_COMPILER + let (++) x s = x @ [s] +#if !FABLE_COMPILER + //-------------------------------------------------------------------------- // General file name resolver //-------------------------------------------------------------------------- @@ -1817,6 +1849,8 @@ let ResolveFileUsingPaths(paths, m, name) = let searchMessage = String.concat "\n " paths raise (FileNameNotResolved(name, searchMessage, m)) +#endif //!FABLE_COMPILER + let GetWarningNumber(m, s: string) = try // Okay so ... @@ -1869,7 +1903,11 @@ type VersionFlag = IL.parseILVersion vstr with _ -> errorR(Error(FSComp.SR.buildInvalidVersionString vstr, rangeStartup)); IL.parseILVersion "0.0.0.0" - member x.GetVersionString implicitIncludeDir = + member x.GetVersionString (implicitIncludeDir: string) = +#if FABLE_COMPILER + ignore implicitIncludeDir + "0.0.0.0" +#else match x with | VersionString s -> s | VersionFile s -> @@ -1880,7 +1918,7 @@ type VersionFlag = use is = System.IO.File.OpenText s is.ReadLine() | VersionNone -> "0.0.0.0" - +#endif //!FABLE_COMPILER /// Represents a reference to an assembly. May be backed by a real assembly on disk, or a cross-project /// reference backed by information generated by the the compiler service. @@ -1913,10 +1951,12 @@ type TimeStampCache(defaultTimeStamp: DateTime) = let ok, v = files.TryGetValue fileName if ok then v else let v = +#if !FABLE_COMPILER try FileSystem.GetLastWriteTimeShim fileName with | :? FileNotFoundException -> +#endif defaultTimeStamp files.[fileName] <- v v @@ -2099,7 +2139,9 @@ type TcConfigBuilder = mutable maxErrors: int mutable abortOnError: bool (* intended for fsi scripts that should exit on first error *) mutable baseAddress: int32 option +#if !FABLE_COMPILER mutable checksumAlgorithm: HashAlgorithm +#endif #if DEBUG mutable showOptimizationData: bool #endif @@ -2230,7 +2272,9 @@ type TcConfigBuilder = maxErrors = 100 abortOnError = false baseAddress = None +#if !FABLE_COMPILER checksumAlgorithm = HashAlgorithm.Sha256 +#endif delaysign = false publicsign = false @@ -2278,7 +2322,11 @@ type TcConfigBuilder = preferredUiLang = None lcid = None // See bug 6071 for product banner spec +#if FABLE_COMPILER + productNameForBannerText = FSComp.SR.buildProductName("F#") +#else productNameForBannerText = FSComp.SR.buildProductName(FSharpEnvironment.FSharpBannerVersion) +#endif showBanner = true showTimes = false showLoadedAssemblies = false @@ -2325,6 +2373,8 @@ type TcConfigBuilder = tryGetMetadataSnapshot = tryGetMetadataSnapshot } +#if !FABLE_COMPILER + member tcConfigB.ResolveSourceFile(m, nm, pathLoadedFrom) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter ResolveFileUsingPaths(tcConfigB.includes @ [pathLoadedFrom], m, nm) @@ -2365,6 +2415,8 @@ type TcConfigBuilder = tcConfigB.outputFile <- Some outfile outfile, pdbfile, assemblyName +#endif //!FABLE_COMPILER + member tcConfigB.TurnWarningOff(m, s: string) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter match GetWarningNumber(m, s) with @@ -2385,7 +2437,13 @@ type TcConfigBuilder = tcConfigB.errorSeverityOptions <- { tcConfigB.errorSeverityOptions with WarnOn = ListSet.insert (=) n tcConfigB.errorSeverityOptions.WarnOn } - member tcConfigB.AddIncludePath (m, path, pathIncludedFrom) = + member tcConfigB.AddIncludePath (m:range, path:string, pathIncludedFrom:string) = +#if FABLE_COMPILER + ignore m + ignore path + ignore pathIncludedFrom + () +#else //!FABLE_COMPILER let absolutePath = ComputeMakePathAbsolute pathIncludedFrom path let ok = let existsOpt = @@ -2398,8 +2456,15 @@ type TcConfigBuilder = | None -> false if ok && not (List.contains absolutePath tcConfigB.includes) then tcConfigB.includes <- tcConfigB.includes ++ absolutePath +#endif //!FABLE_COMPILER member tcConfigB.AddLoadedSource(m, path, pathLoadedFrom) = +#if FABLE_COMPILER + ignore m + ignore path + ignore pathLoadedFrom + () +#else //!FABLE_COMPILER if FileSystem.IsInvalidPathShim path then warning(Error(FSComp.SR.buildInvalidFilename path, m)) else @@ -2411,6 +2476,7 @@ type TcConfigBuilder = ComputeMakePathAbsolute pathLoadedFrom path if not (List.contains path (List.map snd tcConfigB.loadedSources)) then tcConfigB.loadedSources <- tcConfigB.loadedSources ++ (m, path) +#endif //!FABLE_COMPILER member tcConfigB.AddEmbeddedSourceFile (file) = tcConfigB.embedSourceList <- tcConfigB.embedSourceList ++ file @@ -2448,6 +2514,7 @@ type TcConfigBuilder = else ri, fileNameOfPath ri, ILResourceAccess.Public +#if !FABLE_COMPILER let OpenILBinary(filename, reduceMemoryUsage, ilGlobals, pdbDirPath, shadowCopyReferences, tryGetMetadataSnapshot) = let opts: ILReaderOptions = @@ -2472,6 +2539,8 @@ let OpenILBinary(filename, reduceMemoryUsage, ilGlobals, pdbDirPath, shadowCopyR filename AssemblyReader.GetILModuleReader(location, opts) +#endif //!FABLE_COMPILER + #if DEBUG [] #endif @@ -2484,6 +2553,8 @@ type AssemblyResolution = } override this.ToString() = sprintf "%s%s" (if this.sysdir then "[sys]" else "") this.resolvedPath +#if !FABLE_COMPILER + member this.ProjectReference = this.originalReference.ProjectReference /// Compute the ILAssemblyRef for a resolved assembly. This is done by reading the binary if necessary. The result @@ -2527,6 +2598,8 @@ type AssemblyResolution = return assemblyRef } +#endif //!FABLE_COMPILER + //---------------------------------------------------------------------------- // Names to match up refs and defs for assemblies and modules //-------------------------------------------------------------------------- @@ -2559,6 +2632,11 @@ let GetInternalsVisibleToAttributes ilg ilModule = /// This type is immutable and must be kept as such. Do not extract or mutate the underlying data except by cloning it. type TcConfig private (data: TcConfigBuilder, validate: bool) = +#if FABLE_COMPILER + let _ = validate + let clrRootValue, targetFrameworkVersionValue = "", "" + +#else //!FABLE_COMPILER // Validate the inputs - this helps ensure errors in options are shown in visual studio rather than only when built // However we only validate a minimal number of options at the moment do if validate then try data.version.GetVersionInfo(data.implicitIncludeDir) |> ignore with e -> errorR e @@ -2618,6 +2696,8 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = let systemAssemblies = systemAssemblies +#endif //!FABLE_COMPILER + member x.primaryAssembly = data.primaryAssembly member x.autoResolveOpenDirectivesToDlls = data.autoResolveOpenDirectivesToDlls member x.noFeedback = data.noFeedback @@ -2701,8 +2781,10 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member x.flatErrors = data.flatErrors member x.maxErrors = data.maxErrors member x.baseAddress = data.baseAddress +#if !FABLE_COMPILER member x.checksumAlgorithm = data.checksumAlgorithm - #if DEBUG +#endif +#if DEBUG member x.showOptimizationData = data.showOptimizationData #endif member x.showTerms = data.showTerms @@ -2748,6 +2830,8 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member tcConfig.CloneOfOriginalBuilder = { data with conditionalCompilationDefines=data.conditionalCompilationDefines } +#if !FABLE_COMPILER + member tcConfig.ComputeCanContainEntryPoint(sourceFiles: string list) = let n = sourceFiles.Length in (sourceFiles |> List.mapi (fun i _ -> (i = n-1)), tcConfig.target.IsExe) @@ -3093,6 +3177,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member tcConfig.PrimaryAssemblyDllReference() = primaryAssemblyReference member tcConfig.CoreLibraryDllReference() = fslibReference +#endif //!FABLE_COMPILER let ReportWarning options err = warningOn err (options.WarnLevel) (options.WarnOn) && not (List.contains (GetDiagnosticNumber err) (options.WarnOff)) @@ -3384,6 +3469,8 @@ let ParseInput (lexer, errorLogger: ErrorLogger, lexbuf: UnicodeLexing.Lexbuf, d let filteringErrorLogger = ErrorLoggerFilteringByScopedPragmas(false, scopedPragmas, errorLogger) delayLogger.CommitDelayedDiagnostics filteringErrorLogger +#if !FABLE_COMPILER + //---------------------------------------------------------------------------- // parsing - ParseOneInputFile // Filename is (ml/mli/fs/fsi source). Parse it to AST. @@ -3556,6 +3643,7 @@ type TcAssemblyResolutions(tcConfig: TcConfig, results: AssemblyResolution list, let references = resolutions |> List.map (fun r -> r.originalReference) TcAssemblyResolutions.ResolveAssemblyReferences (ctok, tcConfig, references, knownUnresolved) +#endif //!FABLE_COMPILER //---------------------------------------------------------------------------- // Typecheck and optimization environments on disk @@ -3586,6 +3674,8 @@ let GetOptimizationDataResourceName (r: ILResource) = let IsReflectedDefinitionsResource (r: ILResource) = r.Name.StartsWithOrdinal(QuotationPickler.SerializedReflectedDefinitionsResourceNameBase) +#if !FABLE_COMPILER + let MakeILResource rname bytes = { Name = rname Location = ILResourceLocation.LocalOut bytes @@ -4903,6 +4993,45 @@ let GetAssemblyResolutionInformation(ctok, tcConfig: TcConfig) = let resolutions = TcAssemblyResolutions.ResolveAssemblyReferences (ctok, tcConfig, assemblyList, []) resolutions.GetAssemblyResolutions(), resolutions.GetUnresolvedReferences() +#endif //!FABLE_COMPILER + +#if FABLE_COMPILER + +// trimmed-down version of TcImports +[] +type TcImports() = + let mutable tcGlobalsOpt = None + let mutable ccuMap = Map([]) + + // This is the main "assembly reference --> assembly" resolution routine. + let FindCcuInfo (_m, assemblyName) = + match ccuMap |> Map.tryFind assemblyName with + | Some ccuInfo -> ResolvedCcu(ccuInfo.FSharpViewOfMetadata) + | None -> UnresolvedCcu(assemblyName) + + member x.FindCcu (_m: range, assemblyName) = + match ccuMap |> Map.tryFind assemblyName with + | Some ccuInfo -> Some ccuInfo.FSharpViewOfMetadata + | None -> None + + member x.SetTcGlobals g = + tcGlobalsOpt <- Some g + member x.GetTcGlobals() = + tcGlobalsOpt.Value + member x.SetCcuMap m = + ccuMap <- m + member x.GetImportedAssemblies() = + ccuMap.Values + + member x.GetImportMap() = + let loaderInterface = + { new Import.AssemblyLoader with + member x.FindCcuFromAssemblyRef (_ctok, m, ilAssemblyRef) = + FindCcuInfo(m, ilAssemblyRef.Name) + } + new Import.ImportMap (tcGlobalsOpt.Value, loaderInterface) + +#endif //FABLE_COMPILER [] type LoadClosureInput = @@ -4939,6 +5068,7 @@ type CodeContext = | Compilation // in fsc.exe | Editing // in VS +#if !FABLE_COMPILER module private ScriptPreprocessClosure = open Internal.Utilities.Text.Lexing @@ -5257,6 +5387,7 @@ type LoadClosure with ScriptPreprocessClosure.GetFullClosureOfScriptFiles (ctok, tcConfig, files, codeContext, lexResourceManager) +#endif //!FABLE_COMPILER //---------------------------------------------------------------------------- // Initial type checking environment @@ -5283,6 +5414,8 @@ let GetInitialTcEnv (thisAssemblyName: string, initm: range, tcConfig: TcConfig, //---------------------------------------------------------------------------- // Fault injection +#if !FABLE_COMPILER + /// Inject faults into checking let CheckSimulateException(tcConfig: TcConfig) = match tcConfig.simulateException with @@ -5307,6 +5440,8 @@ let CheckSimulateException(tcConfig: TcConfig) = | Some("tc-fail") -> failwith "simulated" | _ -> () +#endif //!FABLE_COMPILER + //---------------------------------------------------------------------------- // Type-check sets of files //-------------------------------------------------------------------------- @@ -5399,7 +5534,9 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig: TcConfig, tcImports: let! ctok = Eventually.token RequireCompilationThread ctok // Everything here requires the compilation thread since it works on the TAST +#if !FABLE_COMPILER CheckSimulateException tcConfig +#endif let m = inp.Range let amap = tcImports.GetImportMap() @@ -5551,6 +5688,8 @@ let TypeCheckClosedInputSet (ctok, checkForErrors, tcConfig, tcImports, tcGlobal let tcState, declaredImpls = TypeCheckClosedInputSetFinish (implFiles, tcState) tcState, topAttrs, declaredImpls, tcEnvAtEndOfLastFile +#if !FABLE_COMPILER // Existing public APIs delegate to newer implementations let GetFSharpCoreLibraryName () = getFSharpCoreLibraryName let DefaultReferencesForScriptsAndOutOfProjectSources assumeDotNetFramework = defaultReferencesForScriptsAndOutOfProjectSources assumeDotNetFramework false +#endif diff --git a/src/fsharp/CompileOps.fsi b/src/fsharp/CompileOps.fsi index 34e25a21f17..f8b12f7ab5a 100644 --- a/src/fsharp/CompileOps.fsi +++ b/src/fsharp/CompileOps.fsi @@ -10,7 +10,9 @@ open Internal.Utilities open FSharp.Compiler.AbstractIL open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILBinaryReader +#if !FABLE_COMPILER open FSharp.Compiler.AbstractIL.ILPdbWriter +#endif open FSharp.Compiler.AbstractIL.Internal.Library open FSharp.Compiler open FSharp.Compiler.TypeChecker @@ -53,7 +55,9 @@ val FSharpLightSyntaxFileSuffixes: string list /// Get the name used for FSharp.Core +#if !FABLE_COMPILER val GetFSharpCoreLibraryName: unit -> string +#endif //---------------------------------------------------------------------------- // Parsing inputs @@ -88,6 +92,8 @@ val SplitRelatedDiagnostics: PhasedDiagnostic -> PhasedDiagnostic * PhasedDiagno /// Output an error to a buffer val OutputPhasedDiagnostic: StringBuilder -> PhasedDiagnostic -> flattenErrors: bool -> suggestNames: bool -> unit +#if !FABLE_COMPILER + /// Output an error or warning to a buffer val OutputDiagnostic: implicitIncludeDir:string * showFullPaths: bool * flattenErrors: bool * errorStyle: ErrorStyle * isError:bool -> StringBuilder -> PhasedDiagnostic -> unit @@ -125,6 +131,8 @@ type Diagnostic = /// Part of LegacyHostedCompilerForTesting val CollectDiagnostic: implicitIncludeDir:string * showFullPaths: bool * flattenErrors: bool * errorStyle: ErrorStyle * warning:bool * PhasedDiagnostic * suggestNames: bool -> seq +#endif //!FABLE_COMPILER + //---------------------------------------------------------------------------- // Resolve assembly references //-------------------------------------------------------------------------- @@ -336,8 +344,10 @@ type TcConfigBuilder = mutable maxErrors: int mutable abortOnError: bool mutable baseAddress: int32 option +#if !FABLE_COMPILER mutable checksumAlgorithm: HashAlgorithm - #if DEBUG +#endif +#if DEBUG mutable showOptimizationData: bool #endif mutable showTerms : bool @@ -401,7 +411,9 @@ type TcConfigBuilder = tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot -> TcConfigBuilder +#if !FABLE_COMPILER member DecideNames: string list -> outfile: string * pdbfile: string option * assemblyName: string +#endif //!FABLE_COMPILER member TurnWarningOff: range * string -> unit member TurnWarningOn: range * string -> unit member AddIncludePath: range * string * string -> unit @@ -496,7 +508,9 @@ type TcConfig = member maxErrors: int member baseAddress: int32 option +#if !FABLE_COMPILER member checksumAlgorithm: HashAlgorithm +#endif #if DEBUG member showOptimizationData: bool #endif @@ -528,6 +542,7 @@ type TcConfig = member isInteractive: bool member isInvalidationSupported: bool +#if !FABLE_COMPILER member ComputeLightSyntaxInitialStatus: string -> bool member GetTargetFrameworkDirectories: unit -> string list @@ -543,6 +558,9 @@ type TcConfig = /// File system query based on TcConfig settings member MakePathAbsolute: string -> string +#endif //!FABLE_COMPILER + + member emitDebugInfoInQuotations: bool member copyFSharpCore: CopyFSharpCoreFlag member shadowCopyReferences: bool member useSdkRefs: bool @@ -550,6 +568,8 @@ type TcConfig = static member Create: TcConfigBuilder * validate: bool -> TcConfig +#if !FABLE_COMPILER + /// Represents a computation to return a TcConfig. Normally this is just a constant immutable TcConfig, /// but for F# Interactive it may be based on an underlying mutable TcConfigBuilder. [] @@ -564,6 +584,8 @@ type TcConfigProvider = /// TcConfigBuilder rather than delivering snapshots. static member BasedOnMutableBuilder: TcConfigBuilder -> TcConfigProvider +#endif //!FABLE_COMPILER + //---------------------------------------------------------------------------- // Tables of referenced DLLs //-------------------------------------------------------------------------- @@ -594,6 +616,20 @@ type ImportedAssembly = #endif FSharpOptimizationData: Lazy> } +#if FABLE_COMPILER + +/// trimmed-down version of TcImports +[] +type TcImports = + internal new: unit -> TcImports + member FindCcu: range * string -> CcuThunk option + member SetTcGlobals: TcGlobals -> unit + member GetTcGlobals: unit -> TcGlobals + member SetCcuMap: Map -> unit + member GetImportedAssemblies: unit -> ImportedAssembly list + member GetImportMap: unit -> Import.ImportMap + +#else //!FABLE_COMPILER [] type TcAssemblyResolutions = @@ -646,6 +682,8 @@ type TcImports = static member BuildNonFrameworkTcImports : CompilationThreadToken * TcConfigProvider * TcGlobals * TcImports * AssemblyResolution list * UnresolvedAssemblyReference list -> Cancellable static member BuildTcImports : CompilationThreadToken * TcConfigProvider -> Cancellable +#endif //!FABLE_COMPILER + //---------------------------------------------------------------------------- // Special resources in DLLs //-------------------------------------------------------------------------- @@ -659,6 +697,9 @@ val IsOptimizationDataResource: ILResource -> bool /// Determine if an IL resource attached to an F# assembly is an F# quotation data resource for reflected definitions val IsReflectedDefinitionsResource: ILResource -> bool val GetSignatureDataResourceName: ILResource -> string +val GetOptimizationDataResourceName: ILResource -> string + +#if !FABLE_COMPILER /// Write F# signature data as an IL resource val WriteSignatureData: TcConfig * TcGlobals * Tastops.Remap * CcuThunk * filename: string * inMem: bool -> ILResource @@ -690,6 +731,8 @@ val ApplyMetaCommandsFromInputToTcConfig: TcConfig * Ast.ParsedInput * string -> /// Process the #nowarn in an input val ApplyNoWarnsToTcConfig: TcConfig * Ast.ParsedInput * string -> TcConfig +#endif //!FABLE_COMPILER + //---------------------------------------------------------------------------- // Scoped pragmas //-------------------------------------------------------------------------- @@ -700,6 +743,8 @@ val GetScopedPragmasForInput: Ast.ParsedInput -> ScopedPragma list /// Get an error logger that filters the reporting of warnings based on scoped pragma information val GetErrorLoggerFilteringByScopedPragmas: checkFile:bool * ScopedPragma list * ErrorLogger -> ErrorLogger +#if !FABLE_COMPILER + /// This list is the default set of references for "non-project" files. val DefaultReferencesForScriptsAndOutOfProjectSources: bool -> string list @@ -710,6 +755,8 @@ val DefaultReferencesForScriptsAndOutOfProjectSources: bool -> string list /// Parse one input file val ParseOneInputFile: TcConfig * Lexhelp.LexResourceManager * string list * string * isLastCompiland: (bool * bool) * ErrorLogger * (*retryLocked*) bool -> ParsedInput option +#endif //!FABLE_COMPILER + //---------------------------------------------------------------------------- // Type checking and querying the type checking state //-------------------------------------------------------------------------- @@ -718,6 +765,7 @@ val ParseOneInputFile: TcConfig * Lexhelp.LexResourceManager * string list * str /// applying the InternalsVisibleTo in referenced assemblies and opening 'Checked' if requested. val GetInitialTcEnv: assemblyName: string * range * TcConfig * TcImports * TcGlobals -> TcEnv + [] /// Represents the incremental type checking state for a set of inputs type TcState = @@ -815,6 +863,7 @@ type LoadClosure = /// Diagnostics seen while processing the compiler options implied root of closure LoadClosureRootFileDiagnostics: (PhasedDiagnostic * bool) list } +#if !FABLE_COMPILER /// Analyze a script text and find the closure of its references. /// Used from FCS, when editing a script file. // @@ -825,3 +874,4 @@ type LoadClosure = /// Analyze a set of script files and find the closure of their references. The resulting references are then added to the given TcConfig. /// Used from fsi.fs and fsc.fs, for #load and command line. static member ComputeClosureOfScriptFiles: CompilationThreadToken * tcConfig:TcConfig * (string * range) list * implicitDefines:CodeContext * lexResourceManager: Lexhelp.LexResourceManager -> LoadClosure +#endif //!FABLE_COMPILER \ No newline at end of file diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index c4595d2dc24..42d3725a00c 100644 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -9,7 +9,9 @@ open System open FSharp.Compiler open FSharp.Compiler.AbstractIL open FSharp.Compiler.AbstractIL.IL +#if !FABLE_COMPILER open FSharp.Compiler.AbstractIL.ILPdbWriter +#endif open FSharp.Compiler.AbstractIL.Internal.Library open FSharp.Compiler.AbstractIL.Extensions.ILX open FSharp.Compiler.AbstractIL.Diagnostics @@ -94,9 +96,14 @@ let PrintCompilerOption (CompilerOption(_s, _tag, _spec, _, help) as compilerOpt let flagWidth = 42 // fixed width for printing of flags, e.g. --debug:{full|pdbonly|portable|embedded} let defaultLineWidth = 80 // the fallback width let lineWidth = +#if FABLE_COMPILER + defaultLineWidth +#else try System.Console.BufferWidth with e -> defaultLineWidth +#endif + let lineWidth = if lineWidth=0 then defaultLineWidth else lineWidth (* Have seen BufferWidth=0 on Linux/Mono *) // Lines have this form: // flagWidth chars - for flags description or padding on continuation lines. @@ -171,6 +178,7 @@ module ResponseFile = | CompilerOptionSpec of string | Comment of string +#if !FABLE_COMPILER let parseFile path: Choice = let parseLine (l: string) = match l with @@ -188,6 +196,7 @@ module ResponseFile = Choice1Of2 data with e -> Choice2Of2 e +#endif //!FABLE_COMPILER let ParseCompilerOptions (collectOtherArgument: string -> unit, blocks: CompilerOptionBlock list, args) = @@ -247,6 +256,10 @@ let ParseCompilerOptions (collectOtherArgument: string -> unit, blocks: Compiler match args with | [] -> () | ((rsp: string) :: t) when rsp.StartsWithOrdinal("@") -> +#if FABLE_COMPILER + ignore t + () +#else let responseFileOptions = let fullpath = try @@ -274,6 +287,7 @@ let ParseCompilerOptions (collectOtherArgument: string -> unit, blocks: Compiler rspData |> List.choose onlyOptions processArg (responseFileOptions @ t) +#endif //!FABLE_COMPILER | opt :: t -> @@ -831,7 +845,11 @@ let setLanguageVersion (specifiedVersion) = printfn "%s" (FSComp.SR.optsSupportedLangVersions()) for v in languageVersion.ValidOptions do printfn "%s" v for v in languageVersion.ValidVersions do printfn "%s" v +#if FABLE_COMPILER + () +#else exit 0 +#endif if specifiedVersion = "?" then dumpAllowedValues () if not (languageVersion.ContainsVersion specifiedVersion) then error(Error(FSComp.SR.optsUnrecognizedLanguageVersion specifiedVersion, rangeCmdArgs)) @@ -865,10 +883,12 @@ let codePageFlag (tcConfigB: TcConfigBuilder) = CompilerOption ("codepage", tagInt, OptionInt (fun n -> +#if !FABLE_COMPILER try System.Text.Encoding.GetEncoding n |> ignore with :? System.ArgumentException as err -> error(Error(FSComp.SR.optsProblemWithCodepage(n, err.Message), rangeCmdArgs)) +#endif tcConfigB.inputCodePage <- Some n), None, Some (FSComp.SR.optsCodepage())) @@ -950,6 +970,7 @@ let advancedFlagsFsc tcConfigB = OptionString (fun s -> tcConfigB.baseAddress <- Some(int32 s)), None, Some (FSComp.SR.optsBaseaddress())) +#if !FABLE_COMPILER yield CompilerOption ("checksumalgorithm", tagAlgorithm, OptionString (fun s -> @@ -959,6 +980,7 @@ let advancedFlagsFsc tcConfigB = | "SHA256" -> HashAlgorithm.Sha256 | _ -> error(Error(FSComp.SR.optsUnknownChecksumAlgorithm s, rangeCmdArgs))), None, Some (FSComp.SR.optsChecksumAlgorithm())) +#endif yield noFrameworkFlag true tcConfigB @@ -1020,7 +1042,9 @@ let testFlag tcConfigB = | "FunctionSizes" -> tcConfigB.optSettings <- { tcConfigB.optSettings with reportFunctionSizes = true } | "TotalSizes" -> tcConfigB.optSettings <- { tcConfigB.optSettings with reportTotalSizes = true } | "HasEffect" -> tcConfigB.optSettings <- { tcConfigB.optSettings with reportHasEffect = true } +#if !FABLE_COMPILER | "NoErrorText" -> FSComp.SR.SwallowResourceText <- true +#endif | "EmitFeeFeeAs100001" -> tcConfigB.testFlagEmitFeeFeeAs100001 <- true | "DumpDebugInfo" -> tcConfigB.dumpDebugInfo <- true | "ShowLoadedAssemblies" -> tcConfigB.showLoadedAssemblies <- true @@ -1402,7 +1426,11 @@ let DisplayBannerText tcConfigB = let displayHelpFsc tcConfigB (blocks:CompilerOptionBlock list) = DisplayBannerText tcConfigB PrintCompilerOptionBlocks blocks +#if FABLE_COMPILER + () +#else exit 0 +#endif let miscFlagsBoth tcConfigB = [ CompilerOption("nologo", tagNone, OptionUnit (fun () -> tcConfigB.showBanner <- false), None, Some (FSComp.SR.optsNologo())) @@ -1584,6 +1612,8 @@ let ApplyCommandLineArgs(tcConfigB: TcConfigBuilder, sourceFiles: string list, c sourceFiles +#if !FABLE_COMPILER + //---------------------------------------------------------------------------- // PrintWholeAssemblyImplementation //---------------------------------------------------------------------------- @@ -1666,6 +1696,8 @@ let ReportTime (tcConfig:TcConfig) descr = nPrev := Some descr +#endif //!FABLE_COMPILER + //---------------------------------------------------------------------------- // OPTIMIZATION - support - addDllToOptEnv //---------------------------------------------------------------------------- @@ -1685,13 +1717,18 @@ let GetInitialOptimizationEnv (tcImports:TcImports, tcGlobals:TcGlobals) = let optEnv = List.fold (AddExternalCcuToOpimizationEnv tcGlobals) optEnv ccuinfos optEnv -let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importMap, isIncrementalFragment, optEnv, ccu:CcuThunk, implFiles) = +let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile:string, importMap, isIncrementalFragment, optEnv, ccu:CcuThunk, implFiles) = // NOTE: optEnv - threads through // // Always optimize once - the results of this step give the x-module optimization // info. Subsequent optimization steps choose representations etc. which we don't // want to save in the x-module info (i.e. x-module info is currently "high level"). +#if FABLE_COMPILER + ignore outfile +#else PrintWholeAssemblyImplementation tcGlobals tcConfig outfile "pass-start" implFiles +#endif + #if DEBUG if tcConfig.showOptimizationData then dprintf "Expression prior to optimization:\n%s\n" (Layout.showL (Layout.squashTo 192 (DebugPrint.implFilesL tcGlobals implFiles))) @@ -1701,7 +1738,9 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM #endif let optEnv0 = optEnv +#if !FABLE_COMPILER ReportTime tcConfig ("Optimizations") +#endif // Only do abstract_big_targets on the first pass! Only do it when TLR is on! let optSettings = tcConfig.optSettings @@ -1779,10 +1818,14 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let implFiles, implFileOptDatas = List.unzip results let assemblyOptData = Optimizer.UnionOptimizationInfos implFileOptDatas let tassembly = TypedAssemblyAfterOptimization implFiles +#if !FABLE_COMPILER PrintWholeAssemblyImplementation tcGlobals tcConfig outfile "pass-end" (List.map fst implFiles) ReportTime tcConfig ("Ending Optimizations") +#endif tassembly, assemblyOptData, optEnvFirstLoop +#if !FABLE_COMPILER + //---------------------------------------------------------------------------- // ILX generation //---------------------------------------------------------------------------- @@ -1869,3 +1912,5 @@ let DoWithErrorColor isError f = let errorColor = ConsoleColor.Red let color = if isError then errorColor else warnColor DoWithColor color f + +#endif //!FABLE_COMPILER diff --git a/src/fsharp/CompileOptions.fsi b/src/fsharp/CompileOptions.fsi index e6e010bff2c..09ee39d227b 100644 --- a/src/fsharp/CompileOptions.fsi +++ b/src/fsharp/CompileOptions.fsi @@ -73,12 +73,16 @@ val SetDebugSwitch : TcConfigBuilder -> string option -> OptionSwitch -> unit val PrintOptionInfo : TcConfigBuilder -> unit val SetTargetProfile : TcConfigBuilder -> string -> unit +#if !FABLE_COMPILER val GetGeneratedILModuleName : CompilerTarget -> string -> string +#endif //!FABLE_COMPILER val GetInitialOptimizationEnv : TcImports * TcGlobals -> IncrementalOptimizationEnv val AddExternalCcuToOpimizationEnv : TcGlobals -> IncrementalOptimizationEnv -> ImportedAssembly -> IncrementalOptimizationEnv val ApplyAllOptimizations : TcConfig * TcGlobals * ConstraintSolver.TcValF * string * ImportMap * bool * IncrementalOptimizationEnv * CcuThunk * TypedImplFile list -> TypedAssemblyAfterOptimization * Optimizer.LazyModuleInfo * IncrementalOptimizationEnv +#if !FABLE_COMPILER + val CreateIlxAssemblyGenerator : TcConfig * TcImports * TcGlobals * ConstraintSolver.TcValF * CcuThunk -> IlxGen.IlxAssemblyGenerator val GenerateIlxCode : IlxGen.IlxGenBackend * isInteractiveItExpr:bool * isInteractiveOnMono:bool * TcConfig * TypeChecker.TopAttribs * TypedAssemblyAfterOptimization * fragName:string * IlxGen.IlxAssemblyGenerator -> IlxGen.IlxGenResults @@ -94,3 +98,5 @@ val DoWithErrorColor : bool -> (unit -> 'a) -> 'a val ReportTime : TcConfig -> string -> unit val GetAbbrevFlagSet : TcConfigBuilder -> bool -> Set val PostProcessCompilerArgs : string Set -> string [] -> string list + +#endif //!FABLE_COMPILER diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 1e59e05b526..9b132e2d612 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -2114,7 +2114,7 @@ and CanMemberSigsMatchUpToCheck match calledMeth.ParamArrayCallerArgs with | Some args -> for callerArg in args do - do! subsumeArg (CalledArg((0, 0), false, NotOptional, NoCallerInfo, false, false, None, reflArgInfo, paramArrayElemTy)) callerArg + do! subsumeArg (GetCalledArg((0, 0), false, NotOptional, NoCallerInfo, false, false, None, reflArgInfo, paramArrayElemTy)) callerArg | _ -> () | _ -> () for argSet in calledMeth.ArgSets do @@ -2136,7 +2136,7 @@ and CanMemberSigsMatchUpToCheck let calledArgTy = rfinfo.FieldType rfinfo.Name, calledArgTy - do! subsumeArg (CalledArg((-1, 0), false, NotOptional, NoCallerInfo, false, false, Some (mkSynId m name), ReflectedArgInfo.None, calledArgTy)) caller + do! subsumeArg (GetCalledArg((-1, 0), false, NotOptional, NoCallerInfo, false, false, Some (mkSynId m name), ReflectedArgInfo.None, calledArgTy)) caller // - Always take the return type into account for // -- op_Explicit, op_Implicit // -- methods using tupling of unfilled out args diff --git a/src/fsharp/DotNetFrameworkDependencies.fs b/src/fsharp/DotNetFrameworkDependencies.fs index 2e96dcd3674..4a7641559c2 100644 --- a/src/fsharp/DotNetFrameworkDependencies.fs +++ b/src/fsharp/DotNetFrameworkDependencies.fs @@ -128,7 +128,7 @@ module internal FSharp.Compiler.DotNetFrameworkDependencies try let refDirs = Directory.GetDirectories(appRefDir) let versionPath = refDirs |> Array.sortWith (versionCompare) |> Array.last - Some(Path.Combine(versionPath, "ref", tfm)) + Some(Path.Combine(versionPath, Path.Combine("ref", tfm))) with | _ -> None | _ -> None diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs index 5760aef8a2a..5c99647fd02 100755 --- a/src/fsharp/ErrorLogger.fs +++ b/src/fsharp/ErrorLogger.fs @@ -129,17 +129,23 @@ let rec AttachRange m (exn:exn) = else match exn with // Strip TargetInvocationException wrappers +#if !FABLE_COMPILER | :? System.Reflection.TargetInvocationException -> AttachRange m exn.InnerException +#endif | UnresolvedReferenceNoRange a -> UnresolvedReferenceError(a, m) | UnresolvedPathReferenceNoRange(a, p) -> UnresolvedPathReference(a, p, m) | Failure msg -> InternalError(msg + " (Failure)", m) +#if !FABLE_COMPILER | :? System.ArgumentException as exn -> InternalError(exn.Message + " (ArgumentException)", m) +#endif | notARangeDual -> notARangeDual //---------------------------------------------------------------------------- // Error logger interface +#if !FABLE_COMPILER + type Exiter = abstract Exit : int -> 'T @@ -153,6 +159,7 @@ let QuitProcessExiter = () FSComp.SR.elSysEnvExitDidntExit() |> failwith } +#endif /// Closed enumeration of build phases. [] @@ -333,13 +340,21 @@ module ErrorLoggerExtensions = // Dev15.0 shipped with a bug in diasymreader in the portable pdb symbol reader which causes an AV // This uses a simple heuristic to detect it (the vsversion is < 16.0) let tryAndDetectDev15 = +#if FABLE_COMPILER + false +#else let vsVersion = Environment.GetEnvironmentVariable("VisualStudioVersion") match Double.TryParse vsVersion with | true, v -> v < 16.0 | _ -> false +#endif /// Instruct the exception not to reset itself when thrown again. let PreserveStackTrace exn = +#if FABLE_COMPILER + ignore exn + () +#else try if not tryAndDetectDev15 then let preserveStackTrace = typeof.GetMethod("InternalPreserveStackTrace", BindingFlags.Instance ||| BindingFlags.NonPublic) @@ -348,6 +363,7 @@ module ErrorLoggerExtensions = // This is probably only the mono case. System.Diagnostics.Debug.Assert(false, "Could not preserve stack trace for watson exception.") () +#endif /// Reraise an exception if it is one we want to report to Watson. let ReraiseIfWatsonable(exn:exn) = @@ -366,11 +382,12 @@ module ErrorLoggerExtensions = type ErrorLogger with member x.ErrorR exn = +#if !FABLE_COMPILER match exn with | InternalError (s, _) | Failure s as exn -> System.Diagnostics.Debug.Assert(false, sprintf "Unexpected exception raised in compiler: %s\n%s" s (exn.ToString())) | _ -> () - +#endif match exn with | StopProcessing | ReportedError _ -> @@ -398,8 +415,10 @@ module ErrorLoggerExtensions = // Never throws ReportedError. // Throws StopProcessing and exceptions raised by the DiagnosticSink(exn) handler. match exn with +#if !FABLE_COMPILER (* Don't send ThreadAbortException down the error channel *) | :? System.Threading.ThreadAbortException | WrappedError((:? System.Threading.ThreadAbortException), _) -> () +#endif | ReportedError _ | WrappedError(ReportedError _, _) -> () | StopProcessing | WrappedError(StopProcessing, _) -> PreserveStackTrace exn diff --git a/src/fsharp/ErrorResolutionHints.fs b/src/fsharp/ErrorResolutionHints.fs index ee80985935e..ca737ea80e4 100644 --- a/src/fsharp/ErrorResolutionHints.fs +++ b/src/fsharp/ErrorResolutionHints.fs @@ -37,7 +37,7 @@ type SuggestionBufferEnumerator(tail: int, data: KeyValuePair []) interface IEnumerator with member __.Current with get () = - let kvpr = &data.[current] + let kvpr = data.[current] kvpr.Value interface System.Collections.IEnumerator with member __.Current with get () = box data.[current].Value @@ -57,11 +57,11 @@ type SuggestionBuffer(idText: string) = let insert (k,v) = let mutable pos = tail - while pos < maxSuggestions && (let kv = &data.[pos] in kv.Key < k) do + while pos < maxSuggestions && (let kv = data.[pos] in kv.Key < k) do pos <- pos + 1 if pos > 0 then - if pos >= maxSuggestions || (let kv = &data.[pos] in k <> kv.Key || v <> kv.Value) then + if pos >= maxSuggestions || (let kv = data.[pos] in k <> kv.Key || v <> kv.Value) then if tail < pos - 1 then for i = tail to pos - 2 do data.[i] <- data.[i + 1] diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 62300df6766..076ff27c041 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -138,7 +138,11 @@ let ReportStatistics (oc: TextWriter) = let NewCounter nm = let count = ref 0 +#if FABLE_COMPILER + ignore nm +#else AddReport (fun oc -> if !count <> 0 then oc.WriteLine (string !count + " " + nm)) +#endif (fun () -> incr count) let CountClosure = NewCounter "closures" @@ -865,6 +869,7 @@ let AddTyparsToEnv typars (eenv: IlxGenEnv) = {eenv with tyenv = eenv.tyenv.Add let AddSignatureRemapInfo _msg (rpi, mhi) eenv = { eenv with sigToImplRemapInfo = (mkRepackageRemapping rpi, mhi) :: eenv.sigToImplRemapInfo } +#if !FABLE_COMPILER let OutputStorage (pps: TextWriter) s = match s with | StaticField _ -> pps.Write "(top)" @@ -874,6 +879,7 @@ let OutputStorage (pps: TextWriter) s = | Arg _ -> pps.Write "(arg)" | Env _ -> pps.Write "(env)" | Null -> pps.Write "(null)" +#endif //-------------------------------------------------------------------------- // Augment eenv with values @@ -1226,7 +1232,11 @@ let GenPossibleILSourceMarker cenv m = // Helpers for merging property definitions //-------------------------------------------------------------------------- +#if FABLE_COMPILER +let HashRangeSorted (ht: IEnumerable>) = +#else let HashRangeSorted (ht: IDictionary<_, (int * _)>) = +#endif [ for KeyValue(_k, v) in ht -> v ] |> List.sortBy fst |> List.map snd let MergeOptions m o1 o2 = @@ -1423,7 +1433,7 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu let ilProperties = mkILProperties [ for (i, (propName, _fldName, fldTy)) in List.indexed flds -> - ILPropertyDef(name=propName, + ILPropertyDef.Create(name=propName, attributes=PropertyAttributes.None, setMethod=None, getMethod=Some(mkILMethRef(ilTypeRef, ILCallingConv.Instance, "get_" + propName, 0, [], fldTy )), @@ -2174,7 +2184,9 @@ let rec GenExpr cenv cgbuf eenv sp (expr: Expr) sequel = cenv.exprRecursionDepth <- cenv.exprRecursionDepth + 1 if cenv.exprRecursionDepth > 1 then +#if !FABLE_COMPILER StackGuard.EnsureSufficientExecutionStack cenv.exprRecursionDepth +#endif GenExprAux cenv cgbuf eenv sp expr sequel else GenExprWithStackGuard cenv cgbuf eenv sp expr sequel @@ -4273,7 +4285,7 @@ and GenClosureTypeDefs cenv (tref: ILTypeRef, ilGenParams, attrs, ilCloFreeVars, cloCode=notlazy ilCtorBody } let tdef = - ILTypeDef(name = tref.Name, + ILTypeDef.Create(name = tref.Name, layout = ILTypeDefLayout.Auto, attributes = enum 0, genericParams = ilGenParams, @@ -4331,7 +4343,7 @@ and GenLambdaClosure cenv (cgbuf: CodeGenBuffer) eenv isLocalTypeFunc selfv expr let ilContractMeths = [ilContractCtor; mkILGenericVirtualMethod("DirectInvoke", ILMemberAccess.Assembly, ilContractMethTyargs, [], mkILReturn ilContractFormalRetTy, MethodBody.Abstract) ] let ilContractTypeDef = - ILTypeDef(name = ilContractTypeRef.Name, + ILTypeDef.Create(name = ilContractTypeRef.Name, layout = ILTypeDefLayout.Auto, attributes = enum 0, genericParams = ilContractGenericParams, @@ -5292,7 +5304,7 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec, rhsExpr, _)) s let ilAttribs = GenAttrs cenv eenv vspec.Attribs let ilTy = ilGetterMethSpec.FormalReturnType let ilPropDef = - ILPropertyDef(name = PrettyNaming.ChopPropertyName ilGetterMethSpec.Name, + ILPropertyDef.Create(name = PrettyNaming.ChopPropertyName ilGetterMethSpec.Name, attributes = PropertyAttributes.None, setMethod = None, getMethod = Some ilGetterMethSpec.MethodRef, @@ -5364,7 +5376,7 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec, rhsExpr, _)) s |> List.filter (fun (Attrib(_, _, _, _, _, targets, _)) -> canTarget(targets, System.AttributeTargets.Property)) |> GenAttrs cenv eenv // property only gets attributes that target properties let ilPropDef = - ILPropertyDef(name=ilPropName, + ILPropertyDef.Create(name=ilPropName, attributes = PropertyAttributes.None, setMethod=(if mut || cenv.opts.isInteractiveItExpr then Some ilSetterMethRef else None), getMethod=Some ilGetterMethRef, @@ -5632,7 +5644,7 @@ and GenReturnInfo cenv eenv ilRetTy (retInfo: ArgReprInfo) : ILReturn = and GenPropertyForMethodDef compileAsInstance tref mdef (v: Val) (memberInfo: ValMemberInfo) ilArgTys ilPropTy ilAttrs compiledName = let name = match compiledName with | Some n -> n | _ -> v.PropertyName in (* chop "get_" *) - ILPropertyDef(name = name, + ILPropertyDef.Create(name = name, attributes = PropertyAttributes.None, setMethod = (if memberInfo.MemberFlags.MemberKind= MemberKind.PropertySet then Some(mkRefToILMethod(tref, mdef)) else None), getMethod = (if memberInfo.MemberFlags.MemberKind= MemberKind.PropertyGet then Some(mkRefToILMethod(tref, mdef)) else None), @@ -5650,7 +5662,7 @@ and GenEventForProperty cenv eenvForMeth (mspec: ILMethodSpec) (v: Val) ilAttrsT let ilThisTy = mspec.DeclaringType let addMethRef = mkILMethRef (ilThisTy.TypeRef, mspec.CallingConv, "add_" + evname, 0, [ilDelegateTy], ILType.Void) let removeMethRef = mkILMethRef (ilThisTy.TypeRef, mspec.CallingConv, "remove_" + evname, 0, [ilDelegateTy], ILType.Void) - ILEventDef(eventType = Some ilDelegateTy, + ILEventDef.Create(eventType = Some ilDelegateTy, name= evname, attributes = EventAttributes.None, addMethod = addMethRef, @@ -7009,7 +7021,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = let literalValue = Option.map (GenFieldInit m) fspec.LiteralValue let fdef = - ILFieldDef(name = ilFieldName, + ILFieldDef.Create(name = ilFieldName, fieldType = ilPropType, attributes = enum 0, data = None, @@ -7037,7 +7049,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = let ilHasSetter = isCLIMutable || isFSharpMutable let ilFieldAttrs = GenAttrs cenv eenv propAttribs @ [mkCompilationMappingAttrWithSeqNum g (int SourceConstructFlags.Field) i] yield - ILPropertyDef(name= ilPropName, + ILPropertyDef.Create(name= ilPropName, attributes= PropertyAttributes.None, setMethod= (if ilHasSetter then Some(mkILMethRef(tref, ilCallingConv, "set_" + ilPropName, 0, [ilPropType], ILType.Void)) else None), getMethod= Some(mkILMethRef(tref, ilCallingConv, "get_" + ilPropName, 0, [], ilPropType)), @@ -7327,7 +7339,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = then SourceConstructFlags.SumType ||| SourceConstructFlags.NonPublicRepresentation else SourceConstructFlags.SumType)) ]) let tdef = - ILTypeDef(name = ilTypeName, + ILTypeDef.Create(name = ilTypeName, layout = layout, attributes = enum 0, genericParams = ilGenParams, @@ -7406,7 +7418,7 @@ and GenExnDef cenv mgbuf eenv m (exnc: Tycon) = let ilMethodDef = mkLdfldMethodDef (ilMethName, reprAccess, false, ilThisTy, ilFieldName, ilPropType) let ilFieldDef = IL.mkILInstanceField(ilFieldName, ilPropType, None, ILMemberAccess.Assembly) let ilPropDef = - ILPropertyDef(name = ilPropName, + ILPropertyDef.Create(name = ilPropName, attributes = PropertyAttributes.None, setMethod = None, getMethod = Some(mkILMethRef(tref, ILCallingConv.Instance, ilMethName, 0, [], ilPropType)), @@ -7631,6 +7643,8 @@ type ExecutionContext = LookupTypeRef: (ILTypeRef -> Type) LookupType: (ILType -> Type) } +#if !FABLE_COMPILER + // A helper to generate a default value for any System.Type. I couldn't find a System.Reflection // method to do this. let defaultOf = @@ -7711,6 +7725,8 @@ let ClearGeneratedValue (ctxt: ExecutionContext) (g: TcGlobals) eenv (v: Val) = #endif () +#endif //!FABLE_COMPILER + /// The published API from the ILX code generator type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal: ConstraintSolver.TcValF, ccu: Tast.CcuThunk) = @@ -7745,10 +7761,12 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal: Constrai delayedGenMethods = Queue () } GenerateCode (cenv, anonTypeTable, ilxGenEnv, typedAssembly, assemAttribs, moduleAttribs) +#if !FABLE_COMPILER /// Invert the compilation of the given value and clear the storage of the value member __.ClearGeneratedValue (ctxt, v) = ClearGeneratedValue ctxt tcGlobals ilxGenEnv v /// Invert the compilation of the given value and return its current dynamic value and its compiled System.Type member __.LookupGeneratedValue (ctxt, v) = LookupGeneratedValue amap ctxt ilxGenEnv v +#endif //!FABLE_COMPILER diff --git a/src/fsharp/IlxGen.fsi b/src/fsharp/IlxGen.fsi index c93d95fdfe1..432f785eef9 100644 --- a/src/fsharp/IlxGen.fsi +++ b/src/fsharp/IlxGen.fsi @@ -92,11 +92,13 @@ type public IlxAssemblyGenerator = /// Generate ILX code for an assembly fragment member GenerateCode : IlxGenOptions * TypedAssemblyAfterOptimization * Attribs * Attribs -> IlxGenResults +#if !FABLE_COMPILER /// Invert the compilation of the given value and clear the storage of the value member ClearGeneratedValue : ExecutionContext * Val -> unit /// Invert the compilation of the given value and return its current dynamic value and its compiled System.Type member LookupGeneratedValue : ExecutionContext * Val -> (obj * System.Type) option +#endif //!FABLE_COMPILER val ReportStatistics : TextWriter -> unit diff --git a/src/fsharp/LegacyHostedCompilerForTesting.fs b/src/fsharp/LegacyHostedCompilerForTesting.fs index b793915b5c8..c13af606717 100644 --- a/src/fsharp/LegacyHostedCompilerForTesting.fs +++ b/src/fsharp/LegacyHostedCompilerForTesting.fs @@ -122,18 +122,33 @@ type internal FscCompiler(legacyReferenceResolver) = /// test if --test:ErrorRanges flag is set let errorRangesArg = +#if FABLE_COMPILER + arg.Equals(@"/test:ErrorRanges", StringComparison.OrdinalIgnoreCase) || + arg.Equals(@"--test:ErrorRanges", StringComparison.OrdinalIgnoreCase) +#else let regex = Regex(@"^(/|--)test:ErrorRanges$", RegexOptions.Compiled ||| RegexOptions.IgnoreCase) fun arg -> regex.IsMatch(arg) +#endif /// test if --vserrors flag is set let vsErrorsArg = +#if FABLE_COMPILER + arg.Equals(@"/vserrors", StringComparison.OrdinalIgnoreCase) || + arg.Equals(@"--vserrors", StringComparison.OrdinalIgnoreCase) +#else let regex = Regex(@"^(/|--)vserrors$", RegexOptions.Compiled ||| RegexOptions.IgnoreCase) fun arg -> regex.IsMatch(arg) +#endif /// test if an arg is a path to fsc.exe let fscExeArg = +#if FABLE_COMPILER + arg.EndsWith(@"fsc", StringComparison.OrdinalIgnoreCase) || + arg.EndsWith(@"fsc.exe", StringComparison.OrdinalIgnoreCase) +#else let regex = Regex(@"fsc(\.exe)?$", RegexOptions.Compiled ||| RegexOptions.IgnoreCase) fun arg -> regex.IsMatch(arg) +#endif /// do compilation as if args was argv to fsc.exe member this.Compile(args : string array) = diff --git a/src/fsharp/LexFilter.fs b/src/fsharp/LexFilter.fs index e37b0c35b1b..8edddea47c4 100755 --- a/src/fsharp/LexFilter.fs +++ b/src/fsharp/LexFilter.fs @@ -568,7 +568,11 @@ type LexFilterImpl (lightSyntaxStatus: LightSyntaxStatus, compilingFsLib, lexer, // Fetch a raw token, either from the old lexer or from our delayedStack //-------------------------------------------------------------------------- +#if FABLE_COMPILER + let delayedStack = Internal.Utilities.Text.Parsing.Stack(100) +#else let delayedStack = System.Collections.Generic.Stack() +#endif let mutable tokensThatNeedNoProcessingCount = 0 let delayToken tokenTup = delayedStack.Push tokenTup @@ -2261,7 +2265,11 @@ type LexFilter (lightSyntaxStatus: LightSyntaxStatus, compilingFsLib, lexer, lex // We don't interact with lexbuf state at all, any inserted tokens have same state/location as the real one read, so // we don't have to do any of the wrapped lexbuf magic that you see in LexFilterImpl. +#if FABLE_COMPILER + let delayedStack = Internal.Utilities.Text.Parsing.Stack(100) +#else let delayedStack = System.Collections.Generic.Stack() +#endif let delayToken tok = delayedStack.Push tok let popNextToken() = diff --git a/src/fsharp/Logger.fs b/src/fsharp/Logger.fs index b1968240d23..797619297be 100644 --- a/src/fsharp/Logger.fs +++ b/src/fsharp/Logger.fs @@ -5,6 +5,13 @@ namespace FSharp.Compiler open System.Diagnostics.Tracing open System +#if FABLE_COMPILER +type EventSource() = + member this.IsEnabled() = false + member this.WriteEvent(_eventId:int, _arg1:int) = () + member this.WriteEvent(_eventId:int, _arg1:string, _arg2:int) = () +#endif + type LogCompilerFunctionId = | Service_ParseAndCheckFileInProject = 1 | Service_CheckOneFile = 2 diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index cf590b69ee3..f860f843a0b 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -63,7 +63,7 @@ type CalledArg = NameOpt: Ident option CalledArgumentType : TType } -let CalledArg (pos, isParamArray, optArgInfo, callerInfo, isInArg, isOutArg, nameOpt, reflArgInfo, calledArgTy) = +let GetCalledArg (pos, isParamArray, optArgInfo, callerInfo, isInArg, isOutArg, nameOpt, reflArgInfo, calledArgTy) = { Position=pos IsParamArray=isParamArray OptArgInfo=optArgInfo diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index e89f3e4284b..e737726212b 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -612,7 +612,12 @@ let TryGetInfoForNonLocalEntityRef env (nleref: NonLocalEntityRef) = let GetInfoForNonLocalVal cenv env (vref: ValRef) = if vref.IsDispatchSlot then UnknownValInfo - // REVIEW: optionally turn x-module on/off on per-module basis or +#if FABLE_COMPILER + // no inlining for FSharp.Core + elif vref.ToString().StartsWith("Microsoft.FSharp.") then + UnknownValInfo +#endif + // REVIEW: optionally turn x-module on/off on per-module basis or elif cenv.settings.crossModuleOpt () || vref.MustInline then match TryGetInfoForNonLocalEntityRef env vref.nlr.EnclosingEntity.nlr with | Some structInfo -> @@ -1424,6 +1429,9 @@ let TryEliminateBinding cenv _env (TBind(vspec1, e1, spBind)) e2 _m = // Immediate consumption of value by a pattern match 'let x = e in match x with ...' | Expr.Match (spMatch, _exprm, TDSwitch(Expr.Val (VRefLocal vspec2, _, _), cases, dflt, _), targets, m, ty2) when (valEq vspec1 vspec2 && +#if FABLE_COMPILER + not (ExprHasEffect cenv.g e1) && +#endif let fvs = accFreeInTargets CollectLocals targets (accFreeInSwitchCases CollectLocals cases dflt emptyFreeVars) not (Zset.contains vspec1 fvs.FreeLocals)) -> @@ -2504,7 +2512,12 @@ and OptimizeVal cenv env expr (v: ValRef, m) = e, AddValEqualityInfo cenv.g m v einfo | None -> - if v.MustInline then error(Error(FSComp.SR.optFailedToInlineValue(v.DisplayName), m)) + if v.MustInline +#if FABLE_COMPILER + // no inlining for FSharp.Core + && not (v.ToString().StartsWith("Microsoft.FSharp.")) +#endif + then error(Error(FSComp.SR.optFailedToInlineValue(v.DisplayName), m)) expr, (AddValEqualityInfo cenv.g m v { Info=valInfoForVal.ValExprInfo HasEffect=false diff --git a/src/fsharp/PrettyNaming.fs b/src/fsharp/PrettyNaming.fs index 4c11b9054d3..b4e210035ea 100755 --- a/src/fsharp/PrettyNaming.fs +++ b/src/fsharp/PrettyNaming.fs @@ -259,7 +259,7 @@ module public FSharp.Compiler.PrettyNaming // 'opCharName' matched the current position in 'opName'. // Append the corresponding operator character to the StringBuilder // and continue decompiling at the index following this instance of 'opCharName'. - sb.Append opChar |> ignore + sb.Append (opChar) |> ignore decompile sb (idx + opCharName.Length) let opNamePrefixLen = opNamePrefix.Length @@ -466,7 +466,11 @@ module public FSharp.Compiler.PrettyNaming if IsCompilerGeneratedName nm then nm else nm+compilerGeneratedMarker let GetBasicNameOfPossibleCompilerGeneratedName (name: string) = +#if FABLE_COMPILER + match name.IndexOf(compilerGeneratedMarker) with +#else match name.IndexOf(compilerGeneratedMarker, StringComparison.Ordinal) with +#endif | -1 | 0 -> name | n -> name.[0..n-1] diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index cf4e4e17456..eceb0700c4c 100644 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -19,7 +19,11 @@ open System.Collections.Generic module QP = FSharp.Compiler.QuotationPickler +#if FABLE_COMPILER +let verboseCReflect = false +#else let verboseCReflect = condition "VERBOSE_CREFLECT" +#endif [] type IsReflectedDefinition = diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 91a63819dab..d6c9d109afc 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -9000,5 +9000,9 @@ let isStaticClass (g:TcGlobals) (x: EntityRef) = | TProvidedTypeExtensionPoint info -> info.IsSealed && info.IsAbstract | _ -> false) #endif - || (not x.IsILTycon && not x.IsProvided && HasFSharpAttribute g g.attrib_AbstractClassAttribute x.Attribs)) && + || (not x.IsILTycon +#if !NO_EXTENSIONTYPING + && not x.IsProvided +#endif + && HasFSharpAttribute g g.attrib_AbstractClassAttribute x.Attribs)) && not (HasFSharpAttribute g g.attrib_RequireQualifiedAccessAttribute x.Attribs) diff --git a/src/fsharp/UnicodeLexing.fs b/src/fsharp/UnicodeLexing.fs index 63ebe2f2b35..6c2b5c7f757 100644 --- a/src/fsharp/UnicodeLexing.fs +++ b/src/fsharp/UnicodeLexing.fs @@ -28,6 +28,8 @@ let FunctionAsLexbuf (supportsFeature: Features.LanguageFeature -> bool, bufferF let SourceTextAsLexbuf (supportsFeature: Features.LanguageFeature -> bool, sourceText) = LexBuffer.FromSourceText(supportsFeature, sourceText) +#if !FABLE_COMPILER + // The choice of 60 retries times 50 ms is not arbitrary. The NTFS FILETIME structure // uses 2 second resolution for LastWriteTime. We retry long enough to surpass this threshold // plus 1 second. Once past the threshold the incremental builder will be able to retry asynchronously based @@ -79,3 +81,5 @@ let UnicodeFileAsLexbuf (supportsFeature: Features.LanguageFeature -> bool, file let lexbuf = LexBuffer<_>.FromChars(supportsFeature, source.ToCharArray()) #endif lexbuf + +#endif \ No newline at end of file diff --git a/src/fsharp/UnicodeLexing.fsi b/src/fsharp/UnicodeLexing.fsi index a6947f38f5b..292fcd4b245 100644 --- a/src/fsharp/UnicodeLexing.fsi +++ b/src/fsharp/UnicodeLexing.fsi @@ -10,5 +10,7 @@ open Internal.Utilities.Text.Lexing type Lexbuf = LexBuffer val internal StringAsLexbuf: (Features.LanguageFeature -> bool) * string -> Lexbuf val public FunctionAsLexbuf: (Features.LanguageFeature -> bool) * (LexBufferChar[] * int * int -> int) -> Lexbuf -val public UnicodeFileAsLexbuf: (Features.LanguageFeature -> bool) * string * int option * (*retryLocked*) bool -> Lexbuf val public SourceTextAsLexbuf: (Features.LanguageFeature -> bool) * ISourceText -> Lexbuf +#if !FABLE_COMPILER +val public UnicodeFileAsLexbuf: (Features.LanguageFeature -> bool) * string * int option * (*retryLocked*) bool -> Lexbuf +#endif diff --git a/src/fsharp/layout.fs b/src/fsharp/layout.fs index d63a8f8f023..494a6f0f665 100644 --- a/src/fsharp/layout.fs +++ b/src/fsharp/layout.fs @@ -437,6 +437,7 @@ let taggedTextListR collector = member x.Finish rstrs = NoResult } +#if !FABLE_COMPILER /// channel LayoutRenderer let channelR (chan:TextWriter) = { new LayoutRenderer with @@ -445,6 +446,7 @@ let channelR (chan:TextWriter) = member r.AddBreak z n = chan.WriteLine(); chan.Write (spaces n); z member r.AddTag z (tag, attrs, start) = z member r.Finish z = NoResult } +#endif /// buffer render let bufferR os = @@ -460,5 +462,7 @@ let bufferR os = //-------------------------------------------------------------------------- let showL layout = renderL stringR layout +#if !FABLE_COMPILER let outL (chan:TextWriter) layout = renderL (channelR chan) layout |> ignore -let bufferL os layout = renderL (bufferR os) layout |> ignore \ No newline at end of file +#endif +let bufferL os layout = renderL (bufferR os) layout |> ignore diff --git a/src/fsharp/layout.fsi b/src/fsharp/layout.fsi index 00831d49ca6..28ae94ab73a 100644 --- a/src/fsharp/layout.fsi +++ b/src/fsharp/layout.fsi @@ -53,7 +53,9 @@ val listL : ('a -> Layout) -> 'a list -> Layout val squashTo : int -> Layout -> Layout val showL : Layout -> string +#if !FABLE_COMPILER val outL : TextWriter -> Layout -> unit +#endif val bufferL : StringBuilder -> Layout -> unit module TaggedTextOps = @@ -193,7 +195,9 @@ val renderL : LayoutRenderer<'b,'a> -> Layout -> 'b /// Primitive renders val stringR : LayoutRenderer +#if !FABLE_COMPILER val channelR : TextWriter -> LayoutRenderer +#endif val bufferR : StringBuilder -> LayoutRenderer val taggedTextListR : collector: (TaggedText -> unit) -> LayoutRenderer diff --git a/src/fsharp/lex.fsl b/src/fsharp/lex.fsl index b77ea661acf..7ad77c7a1d0 100644 --- a/src/fsharp/lex.fsl +++ b/src/fsharp/lex.fsl @@ -49,10 +49,10 @@ let fail args (lexbuf:UnicodeLexing.Lexbuf) msg dflt = // version of the F# core library parsing code with the call to "Trim" // removed, which appears in profiling runs as a small but significant cost. -let getSign32 (s:string) (p:byref) l = +let getSign32 (s:string) (p:int) l = if (l >= p + 1 && s.[p] = '-') - then p <- p + 1; -1 - else 1 + then -1, p + 1 + else 1, p let isOXB c = let c = Char.ToLowerInvariant c @@ -60,10 +60,11 @@ let isOXB c = let is0OXB (s:string) p l = l >= p + 2 && s.[p] = '0' && isOXB s.[p+1] -let get0OXB (s:string) (p:byref) l = + +let get0OXB (s:string) (p:int) l = if is0OXB s p l - then let r = Char.ToLowerInvariant s.[p+1] in p <- p + 2; r - else 'd' + then let r = Char.ToLowerInvariant s.[p+1] in r, p + 2 + else 'd', p let formatError() = raise (new System.FormatException(SR.GetString("bad format string"))) @@ -81,6 +82,16 @@ let removeUnderscores (s:string) = let parseInt32 (s:string) = let s = removeUnderscores s let l = s.Length +#if FABLE_COMPILER + let p = 0 + let sign, p = getSign32 s p l + let specifier, p = get0OXB s p l + match Char.ToLowerInvariant(specifier) with + | 'x' -> sign * Convert.ToInt32(s.Substring(p), 16) + | 'b' -> sign * (int32 (Convert.ToUInt32(parseBinaryUInt64 (s.Substring(p))))) + | 'o' -> sign * (int32 (Convert.ToUInt32(parseOctalUInt64 (s.Substring(p))))) + | _ -> Convert.ToInt32(s) +#else let mutable p = 0 let sign = getSign32 s &p l let specifier = get0OXB s &p l @@ -89,6 +100,7 @@ let parseInt32 (s:string) = | 'b' -> sign * (int32 (Convert.ToUInt32(parseBinaryUInt64 (s.Substring(p))))) | 'o' -> sign * (int32 (Convert.ToUInt32(parseOctalUInt64 (s.Substring(p))))) | _ -> Int32.Parse(s, NumberStyles.AllowLeadingSign, CultureInfo.InvariantCulture) +#endif let lexemeTrimRightToInt32 args lexbuf n = try parseInt32 (lexemeTrimRight lexbuf n) @@ -355,16 +367,25 @@ rule token args skip = parse } | xieee32 { +#if FABLE_COMPILER + fail args lexbuf (FSComp.SR.lexInvalidFloat()) (IEEE32 0.0f) +#else let s = removeUnderscores (lexemeTrimRight lexbuf 2) // Even though the intermediate step is an int64, display the "invalid float" message, since it will be less confusing to the user let n64 = (try (int64 s) with _ -> fail args lexbuf (FSComp.SR.lexInvalidFloat()) 0L) if n64 > 0xFFFFFFFFL || n64 < 0L then fail args lexbuf (FSComp.SR.lexOusideThirtyTwoBitFloat()) (IEEE32 0.0f) else - IEEE32 (System.BitConverter.ToSingle(System.BitConverter.GetBytes(int32 (uint32 (uint64 n64))),0)) } - + IEEE32 (System.BitConverter.ToSingle(System.BitConverter.GetBytes(int32 (uint32 (uint64 n64))),0)) +#endif + } | xieee64 { +#if FABLE_COMPILER + fail args lexbuf (FSComp.SR.lexInvalidFloat()) (IEEE64 0.0) +#else let n64 = (try int64 (removeUnderscores (lexemeTrimRight lexbuf 2)) with _ -> fail args lexbuf (FSComp.SR.lexInvalidFloat()) 0L) - IEEE64 (System.BitConverter.Int64BitsToDouble(n64)) } + IEEE64 (System.BitConverter.Int64BitsToDouble(n64)) +#endif + } | bignum { let s = lexeme lexbuf diff --git a/src/fsharp/lexhelp.fs b/src/fsharp/lexhelp.fs index 6a9a6430cbd..a3274579f91 100644 --- a/src/fsharp/lexhelp.fs +++ b/src/fsharp/lexhelp.fs @@ -335,7 +335,11 @@ module Keywords = if String.IsNullOrWhiteSpace(filename) then String.Empty else if filename = stdinMockFilename then +#if !FABLE_COMPILER System.IO.Directory.GetCurrentDirectory() +#else //FABLE_COMPILER + "." +#endif else filename |> FileSystem.GetFullPathShim (* asserts that path is already absolute *) diff --git a/src/fsharp/lexhelp.fsi b/src/fsharp/lexhelp.fsi index f75ecd392d9..6d7c6f9b984 100644 --- a/src/fsharp/lexhelp.fsi +++ b/src/fsharp/lexhelp.fsi @@ -47,13 +47,13 @@ val reusingLexbufForParsing : UnicodeLexing.Lexbuf -> (unit -> 'a) -> 'a val usingLexbufForParsing : UnicodeLexing.Lexbuf * string -> (UnicodeLexing.Lexbuf -> 'a) -> 'a val defaultStringFinisher : 'a -> 'b -> byte[] -> Parser.token -val callStringFinisher : ('a -> 'b -> byte[] -> 'c) -> AbstractIL.Internal.ByteBuffer -> 'a -> 'b -> 'c -val addUnicodeString : AbstractIL.Internal.ByteBuffer -> string -> unit -val addUnicodeChar : AbstractIL.Internal.ByteBuffer -> int -> unit -val addByteChar : AbstractIL.Internal.ByteBuffer -> char -> unit +val callStringFinisher : ('a -> 'b -> byte[] -> 'c) -> ByteBuffer -> 'a -> 'b -> 'c +val addUnicodeString : ByteBuffer -> string -> unit +val addUnicodeChar : ByteBuffer -> int -> unit +val addByteChar : ByteBuffer -> char -> unit val stringBufferAsString : byte[] -> string -val stringBufferAsBytes : AbstractIL.Internal.ByteBuffer -> byte[] -val stringBufferIsBytes : AbstractIL.Internal.ByteBuffer -> bool +val stringBufferAsBytes : ByteBuffer -> byte[] +val stringBufferIsBytes : ByteBuffer -> bool val newline : Lexing.LexBuffer<'a> -> unit val trigraph : char -> char -> char -> char val digit : char -> int32 diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index 6c4599f8a1c..7e8164921e8 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -16,12 +16,17 @@ let verbose = false let progress = ref false let tracking = ref false // intended to be a general hook to control diagnostic output when tracking down bugs +#if FABLE_COMPILER +let condition _s = false +let GetEnvInteger _e dflt = dflt +#else let condition s = try (System.Environment.GetEnvironmentVariable(s) <> null) with _ -> false let GetEnvInteger e dflt = match System.Environment.GetEnvironmentVariable(e) with null -> dflt | t -> try int t with _ -> dflt let dispose (x:System.IDisposable) = match x with null -> () | x -> x.Dispose() +#endif //------------------------------------------------------------------------- // Library: bits @@ -313,6 +318,7 @@ let bufs f = f buf buf.ToString() +#if !FABLE_COMPILER let buff (os: TextWriter) f x = let buf = System.Text.StringBuilder 100 f buf x @@ -325,6 +331,7 @@ let writeViaBufferWithEnvironmentNewLines (os: TextWriter) f x = let text = buf.ToString() let text = text.Replace("\n", System.Environment.NewLine) os.Write text +#endif //--------------------------------------------------------------------------- // Imperative Graphs @@ -402,6 +409,7 @@ type Dumper(x:obj) = member self.Dump = sprintf "%A" x #endif +#if !FABLE_COMPILER //--------------------------------------------------------------------------- // AsyncUtil //--------------------------------------------------------------------------- @@ -544,4 +552,6 @@ module StackGuard = let EnsureSufficientExecutionStack recursionDepth = if recursionDepth > MaxUncheckedRecursionDepth then - RuntimeHelpers.EnsureSufficientExecutionStack () \ No newline at end of file + RuntimeHelpers.EnsureSufficientExecutionStack () + +#endif //!FABLE_COMPILER diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy index cb2b0a7020b..6de06b46e6e 100644 --- a/src/fsharp/pars.fsy +++ b/src/fsharp/pars.fsy @@ -284,7 +284,7 @@ let rangeOfLongIdent(lid:LongIdent) = %type typedSeqExprBlock %type atomicExpr %type tyconDefnOrSpfnSimpleRepr -%type <(Ast.SynEnumCase, Ast.SynUnionCase) Choice list> unionTypeRepr +%type list> unionTypeRepr %type tyconDefnAugmentation %type exconDefn %type exconCore @@ -2868,7 +2868,7 @@ atomicPattern: { SynPat.OptionalVal($2,lhs parseState) } | atomicPatternLongIdent %prec prec_atompat_pathop { let vis,lidwd = $1 - if not (isNilOrSingleton lidwd.Lid) || (let c = (List.head lidwd.Lid).idText.[0] in Char.IsUpper(c) && not (Char.IsLower c)) + if not (isNilOrSingleton lidwd.Lid) || (String.isUpper (List.head lidwd.Lid).idText) then mkSynPatMaybeVar lidwd vis (lhs parseState) else mkSynPatVar vis (List.head lidwd.Lid) } | constant @@ -3580,15 +3580,15 @@ minusExpr: | PLUS_MINUS_OP minusExpr { if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt $2.Range (FSComp.SR.parsInvalidPrefixOperator()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"^($1)) $2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"+($1)) $2 } | ADJACENT_PREFIX_OP minusExpr { if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt $2.Range (FSComp.SR.parsInvalidPrefixOperator()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"^($1)) $2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"+($1)) $2 } | PERCENT_OP minusExpr { if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt $2.Range (FSComp.SR.parsInvalidPrefixOperator()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"^($1)) $2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) $2.Range) ("~"+($1)) $2 } | AMP minusExpr { SynExpr.AddressOf (true,$2,rhs parseState 1,unionRanges (rhs parseState 1) $2.Range) } @@ -3627,7 +3627,7 @@ argExpr: { let arg2,hpa2 = $2 if not (IsValidPrefixOperatorUse $1) then reportParseErrorAt arg2.Range (FSComp.SR.parsInvalidPrefixOperator()) if hpa2 then reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsSuccessiveArgsShouldBeSpacedOrTupled()) - mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) arg2.Range) ("~"^($1)) arg2 } + mkSynPrefix (rhs parseState 1) (unionRanges (rhs parseState 1) arg2.Range) ("~"+($1)) arg2 } | atomicExpr { let arg,hpa = $1 diff --git a/src/fsharp/range.fs b/src/fsharp/range.fs index 0b6d7d39639..fcf87491c58 100755 --- a/src/fsharp/range.fs +++ b/src/fsharp/range.fs @@ -156,14 +156,22 @@ type FileIndexTable() = | true, idx -> // Record the non-normalized entry if necessary if filePath <> normalizedFilePath then +#if FABLE_COMPILER + ( +#else lock fileToIndexTable (fun () -> +#endif fileToIndexTable.[filePath] <- idx) // Return the index idx | _ -> +#if FABLE_COMPILER + ( +#else lock fileToIndexTable (fun () -> +#endif // Get the new index let idx = indexToFileTable.Count @@ -253,7 +261,9 @@ type range(code1:int64, code2: int64) = let endCol = r.EndColumn - 1 let startCol = r.StartColumn - 1 if FileSystem.IsInvalidPathShim r.FileName then "path invalid: " + r.FileName +#if !FABLE_COMPILER elif not (FileSystem.SafeExists r.FileName) then "non existing file: " + r.FileName +#endif else File.ReadAllLines(r.FileName) |> Seq.skip (r.StartLine - 1) @@ -358,8 +368,11 @@ module Line = // Visual Studio uses line counts starting at 0, F# uses them starting at 1 let fromZ (line:Line0) = int line+1 - +#if FABLE_COMPILER + let toZ (line:int) : Line0 = int (line - 1) +#else let toZ (line:int) : Line0 = LanguagePrimitives.Int32WithMeasure(line - 1) +#endif module Pos = diff --git a/src/fsharp/service/FSharpCheckerResults.fs b/src/fsharp/service/FSharpCheckerResults.fs index 6b493ca332c..dadac3114b6 100644 --- a/src/fsharp/service/FSharpCheckerResults.fs +++ b/src/fsharp/service/FSharpCheckerResults.fs @@ -53,12 +53,20 @@ module internal FSharpCheckerResultsSettings = /// to enable other requests to be serviced. Yielding means returning a continuation function /// (via an Eventually<_> value of case NotYetDone) that can be called as the next piece of work. let maxTimeShareMilliseconds = +#if FABLE_COMPILER + 100L +#else match System.Environment.GetEnvironmentVariable("FCS_MaxTimeShare") with | null | "" -> 100L | s -> int64 s +#endif // Look for DLLs in the location of the service DLL first. +#if FABLE_COMPILER + let defaultFSharpBinariesDir = "" +#else let defaultFSharpBinariesDir = FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(Some(typeof.Assembly.Location)).Value +#endif [] type FSharpFindDeclFailureReason = @@ -518,7 +526,10 @@ type internal TypeCheckInfo nameMatchesResidue n1 || meths |> List.exists (fun meth -> let tcref = meth.ApparentEnclosingTyconRef - tcref.IsProvided || nameMatchesResidue tcref.DisplayName) +#if !NO_EXTENSIONTYPING + tcref.IsProvided || +#endif + nameMatchesResidue tcref.DisplayName) | _ -> residue = n1) /// Post-filter items to make sure they have precisely the right name @@ -1599,6 +1610,7 @@ module internal ParseAndCheckFile = errHandler.CollectedDiagnostics, parseResult, errHandler.AnyErrors +#if !FABLE_COMPILER let ApplyLoadClosure(tcConfig, parsedMainInput, mainInputFileName, loadClosure: LoadClosure option, tcImports: TcImports, backgroundDiagnostics) = // If additional references were brought in by the preprocessor then we need to process them @@ -1656,6 +1668,7 @@ module internal ParseAndCheckFile = | None -> // For non-scripts, check for disallow #r and #load. ApplyMetaCommandsFromInputToTcConfig (tcConfig, parsedMainInput,Path.GetDirectoryName mainInputFileName) |> ignore +#endif //!FABLE_COMPILER // Type check a single file against an initial context, gleaning both errors and intellisense information. let CheckOneFile @@ -1675,13 +1688,19 @@ module internal ParseAndCheckFile = // Used by 'FSharpDeclarationListInfo' to check the IncrementalBuilder is still alive. textSnapshotInfo : obj option, userOpName: string, - suggestNamesForErrors: bool) = async { - + suggestNamesForErrors: bool) = +#if !FABLE_COMPILER + async { +#endif use _logBlock = Logger.LogBlock LogCompilerFunctionId.Service_CheckOneFile match parseResults.ParseTree with // When processing the following cases, we don't need to type-check +#if FABLE_COMPILER + | None -> [||], Result.Error() +#else | None -> return [||], Result.Error() +#endif // Run the type checker... | Some parsedMainInput -> @@ -1692,8 +1711,10 @@ module internal ParseAndCheckFile = use _unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _oldLogger -> errHandler.ErrorLogger) use _unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck +#if !FABLE_COMPILER // Apply nowarns to tcConfig (may generate errors, so ensure errorLogger is installed) let tcConfig = ApplyNoWarnsToTcConfig (tcConfig, parsedMainInput,Path.GetDirectoryName mainInputFileName) +#endif // update the error handler with the modified tcConfig errHandler.ErrorSeverityOptions <- tcConfig.errorSeverityOptions @@ -1702,8 +1723,10 @@ module internal ParseAndCheckFile = for (err,sev) in backgroundDiagnostics do diagnosticSink (err, (sev = FSharpErrorSeverity.Error)) +#if !FABLE_COMPILER // If additional references were brought in by the preprocessor then we need to process them ApplyLoadClosure(tcConfig, parsedMainInput, mainInputFileName, loadClosure, tcImports, backgroundDiagnostics) +#endif // A problem arises with nice name generation, which really should only // be done in the backend, but is also done in the typechecker for better or worse. @@ -1713,6 +1736,23 @@ module internal ParseAndCheckFile = // Typecheck the real input. let sink = TcResultsSinkImpl(tcGlobals, sourceText = sourceText) +#if FABLE_COMPILER + ignore userOpName + let resOpt = + try + let ctok = AssumeCompilationThreadWithoutEvidence() + let checkForErrors() = (parseResults.ParseHadErrors || errHandler.ErrorCount > 0) + let parsedMainInput, _moduleNamesDict = DeduplicateParsedInputModuleName moduleNamesDict parsedMainInput + let result = + TypeCheckOneInputAndFinishEventually(checkForErrors, tcConfig, tcImports, tcGlobals, None, TcResultsSink.WithSink sink, tcState, parsedMainInput) + |> Eventually.force ctok + Some result + with + | e -> + errorR e + Some((tcState.TcEnvFromSignatures, EmptyTopAttrs, [], [NewEmptyModuleOrNamespaceType Namespace]), tcState) +#else //!FABLE_COMPILER + let! ct = Async.CancellationToken let! resOpt = @@ -1745,6 +1785,7 @@ module internal ParseAndCheckFile = errorR e return Some((tcState.TcEnvFromSignatures, EmptyTopAttrs, [], [NewEmptyModuleOrNamespaceType Namespace]), tcState) } +#endif //!FABLE_COMPILER let errors = errHandler.CollectedDiagnostics @@ -1769,8 +1810,12 @@ module internal ParseAndCheckFile = |> Result.Ok | None -> Result.Error() +#if FABLE_COMPILER + errors, res +#else return errors, res } +#endif [] @@ -1821,10 +1866,12 @@ type FSharpCheckFileResults member __.HasFullTypeCheckInfo = details.IsSome +#if !FABLE_COMPILER member info.TryGetCurrentTcImports () = match builderX with | Some builder -> builder.TryGetCurrentTcImports () | _ -> None +#endif /// Intellisense autocompletions member __.GetDeclarationListInfo(parseResultsOpt, line, lineStr, partialName, ?getAllEntities, ?hasTextChangedSinceLastTypecheck, ?userOpName: string) = @@ -2034,6 +2081,7 @@ type FSharpCheckFileResults let errors = FSharpCheckFileResults.JoinErrors(isIncompleteTypeCheckEnvironment, creationErrors, parseErrors, tcErrors) FSharpCheckFileResults (mainInputFileName, errors, Some tcFileInfo, dependencyFiles, Some builder, reactorOps, keepAssemblyContents) +#if !FABLE_COMPILER static member CheckOneFile (parseResults: FSharpParseFileResults, sourceText: ISourceText, @@ -2070,6 +2118,7 @@ type FSharpCheckFileResults let results = FSharpCheckFileResults (mainInputFileName, errors, Some tcFileInfo, dependencyFiles, Some builder, reactorOps, keepAssemblyContents) return FSharpCheckFileAnswer.Succeeded(results) } +#endif and [] FSharpCheckFileAnswer = | Aborted @@ -2186,6 +2235,8 @@ type FSharpCheckProjectResults override __.ToString() = "FSharpCheckProjectResults(" + projectFileName + ")" +#if !FABLE_COMPILER + type FsiInteractiveChecker(legacyReferenceResolver, reactorOps: IReactorOperations, tcConfig: TcConfig, @@ -2247,3 +2298,4 @@ type FsiInteractiveChecker(legacyReferenceResolver, failwith "unexpected aborted" } +#endif diff --git a/src/fsharp/service/FSharpCheckerResults.fsi b/src/fsharp/service/FSharpCheckerResults.fsi index 4f7062d9ce2..66ca752d716 100644 --- a/src/fsharp/service/FSharpCheckerResults.fsi +++ b/src/fsharp/service/FSharpCheckerResults.fsi @@ -91,9 +91,47 @@ type public FSharpParsingOptions = static member internal FromTcConfigBuidler: tcConfigB: TcConfigBuilder * sourceFiles: string[] * isInteractive: bool -> FSharpParsingOptions +[] +type internal TypeCheckInfo = + internal new : + tcConfig: TcConfig * + tcGlobals: TcGlobals * + ccuSigForFile: ModuleOrNamespaceType * + thisCcu: CcuThunk * + tcImports: TcImports * + tcAccessRights: AccessorDomain * + projectFileName: string * + mainInputFileName: string * + sResolutions: TcResolutions * + sSymbolUses: TcSymbolUses * + sFallback: NameResolutionEnv * + loadClosure : LoadClosure option * + reactorOps : IReactorOperations * + textSnapshotInfo: obj option * + implFileOpt: TypedImplFile option * + openDeclarations: OpenDeclaration[] + -> TypeCheckInfo + member ScopeResolutions: TcResolutions + member ScopeSymbolUses: TcSymbolUses + member TcGlobals: TcGlobals + member TcImports: TcImports + member CcuSigForFile: Tast.ModuleOrNamespaceType + member ThisCcu: Tast.CcuThunk + member ImplementationFile: TypedImplFile option + /// A handle to the results of CheckFileInProject. [] type public FSharpCheckFileResults = + internal new : + filename: string * + errors: FSharpErrorInfo[] * + scopeOptX: TypeCheckInfo option * + dependencyFiles: string[] * + builderX: IncrementalBuilder option * + reactorOpsX: IReactorOperations * + keepAssemblyContents: bool + -> FSharpCheckFileResults + /// The errors returned by parsing a source file. member Errors : FSharpErrorInfo[] @@ -107,8 +145,10 @@ type public FSharpCheckFileResults = /// an unrecoverable error in earlier checking/parsing/resolution steps. member HasFullTypeCheckInfo: bool +#if !FABLE_COMPILER /// Tries to get the current successful TcImports. This is only used in testing. Do not use it for other stuff. member internal TryGetCurrentTcImports: unit -> TcImports option +#endif /// Indicates the set of files which must be watched to accurately track changes that affect these results, /// Clients interested in reacting to updates to these files should watch these files and take actions as described @@ -302,6 +342,7 @@ type public FSharpCheckFileResults = openDeclarations: OpenDeclaration[] -> FSharpCheckFileResults +#if !FABLE_COMPILER /// Internal constructor - check a file and collect errors static member internal CheckOneFile: parseResults: FSharpParseFileResults * @@ -326,6 +367,7 @@ type public FSharpCheckFileResults = keepAssemblyContents: bool * suggestNamesForErrors: bool -> Async +#endif /// The result of calling TypeCheckResult including the possibility of abort and background compiler not caught up. and [] public FSharpCheckFileAnswer = @@ -397,6 +439,28 @@ module internal ParseAndCheckFile = suggestNamesForErrors: bool -> (range * range)[] +#if FABLE_COMPILER + val CheckOneFile: + parseResults: FSharpParseFileResults * + sourceText: ISourceText * + mainInputFileName: string * + projectFileName: string * + tcConfig: TcConfig * + tcGlobals: TcGlobals * + tcImports: TcImports * + tcState: TcState * + moduleNamesDict: ModuleNamesDict * + loadClosure: LoadClosure option * + backgroundDiagnostics: (PhasedDiagnostic * FSharpErrorSeverity)[] * + reactorOps: IReactorOperations * + textSnapshotInfo : obj option * + userOpName: string * + suggestNamesForErrors: bool + -> FSharpErrorInfo[] * Result +#endif + +#if !FABLE_COMPILER + // An object to typecheck source in a given typechecking environment. // Used internally to provide intellisense over F# Interactive. type internal FsiInteractiveChecker = @@ -415,6 +479,8 @@ type internal FsiInteractiveChecker = ?userOpName: string -> Async +#endif + module internal FSharpCheckerResultsSettings = val defaultFSharpBinariesDir: string diff --git a/src/fsharp/service/IncrementalBuild.fs b/src/fsharp/service/IncrementalBuild.fs index 96e81e32147..f1e3b369ba1 100755 --- a/src/fsharp/service/IncrementalBuild.fs +++ b/src/fsharp/service/IncrementalBuild.fs @@ -27,6 +27,8 @@ open FSharp.Compiler.Range open FSharp.Compiler.SourceCodeServices open Internal.Utilities.Collections +#if !FABLE_COMPILER + [] module internal IncrementalBuild = @@ -969,6 +971,21 @@ module internal IncrementalBuild = member b.GetInitialPartialBuild(inputs: BuildInput list) = ToBound(ToBuild outputs, inputs) +#endif //!FABLE_COMPILER + + +#if FABLE_COMPILER +// stub +type IncrementalBuilder() = + member x.IncrementUsageCount () = + { new System.IDisposable with member __.Dispose() = () } + member x.IsAlive = false + static member KeepBuilderAlive (builderOpt: IncrementalBuilder option) = + match builderOpt with + | Some builder -> builder.IncrementUsageCount() + | None -> { new System.IDisposable with member __.Dispose() = () } + +#else //!FABLE_COMPILER @@ -1841,3 +1858,5 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput return builderOpt, diagnostics } + +#endif //!FABLE_COMPILER diff --git a/src/fsharp/service/IncrementalBuild.fsi b/src/fsharp/service/IncrementalBuild.fsi index 96d00636887..3f775f75316 100755 --- a/src/fsharp/service/IncrementalBuild.fsi +++ b/src/fsharp/service/IncrementalBuild.fsi @@ -14,6 +14,16 @@ open FSharp.Compiler.NameResolution open FSharp.Compiler.Tast open FSharp.Compiler.SourceCodeServices +#if FABLE_COMPILER +// stub +[] +type internal IncrementalBuilder = + member IncrementUsageCount : unit -> IDisposable + member IsAlive : bool + static member KeepBuilderAlive : IncrementalBuilder option -> IDisposable + +#else //!FABLE_COMPILER + /// Lookup the global static cache for building the FrameworkTcImports type internal FrameworkImportsCache = new : size: int -> FrameworkImportsCache @@ -252,3 +262,4 @@ module internal IncrementalBuild = /// Set the concrete inputs for this build. member GetInitialPartialBuild : vectorinputs: BuildInput list -> PartialBuild +#endif //!FABLE_COMPILER diff --git a/src/fsharp/service/Reactor.fs b/src/fsharp/service/Reactor.fs index f879e5133f9..b6bd1c34df0 100755 --- a/src/fsharp/service/Reactor.fs +++ b/src/fsharp/service/Reactor.fs @@ -14,6 +14,8 @@ type internal IReactorOperations = abstract EnqueueAndAwaitOpAsync : userOpName:string * opName:string * opArg:string * (CompilationThreadToken -> Cancellable<'T>) -> Async<'T> abstract EnqueueOp: userOpName:string * opName:string * opArg:string * (CompilationThreadToken -> unit) -> unit +#if !FABLE_COMPILER + [] type internal ReactorCommands = /// Kick off a build. @@ -196,3 +198,4 @@ type Reactor() = static member Singleton = theReactor +#endif //!FABLE_COMPILER diff --git a/src/fsharp/service/Reactor.fsi b/src/fsharp/service/Reactor.fsi index 3040ca65eee..fe515e100aa 100755 --- a/src/fsharp/service/Reactor.fsi +++ b/src/fsharp/service/Reactor.fsi @@ -14,6 +14,8 @@ type internal IReactorOperations = /// Enqueue an operation and return immediately. abstract EnqueueOp: userOpName:string * opName:string * opArg:string * action: (CompilationThreadToken -> unit) -> unit +#if !FABLE_COMPILER + /// Reactor is intended for long-running but interruptible operations, interleaved /// with one-off asynchronous operations. /// @@ -54,3 +56,4 @@ type internal Reactor = /// Get the reactor static member Singleton : Reactor +#endif //!FABLE_COMPILER diff --git a/src/fsharp/service/ServiceAssemblyContent.fs b/src/fsharp/service/ServiceAssemblyContent.fs index 8ceb381225b..c21dc72fdb2 100644 --- a/src/fsharp/service/ServiceAssemblyContent.fs +++ b/src/fsharp/service/ServiceAssemblyContent.fs @@ -184,6 +184,7 @@ type IAssemblyContentCache = abstract TryGet: AssemblyPath -> AssemblyContentCacheEntry option abstract Set: AssemblyPath -> AssemblyContentCacheEntry -> unit +#if !FABLE_COMPILER module AssemblyContentProvider = open System.IO @@ -372,6 +373,7 @@ module AssemblyContentProvider = | None -> true | Some x when x.IsPublic -> true | _ -> false) +#endif //!FABLE_COMPILER type EntityCache() = let dic = Dictionary() diff --git a/src/fsharp/service/ServiceAssemblyContent.fsi b/src/fsharp/service/ServiceAssemblyContent.fsi index 0fe14c11444..6359c103659 100644 --- a/src/fsharp/service/ServiceAssemblyContent.fsi +++ b/src/fsharp/service/ServiceAssemblyContent.fsi @@ -103,6 +103,7 @@ type public Entity = /// Last part of the entity's full name. LastIdent: string } +#if !FABLE_COMPILER /// Provides assembly content. module public AssemblyContentProvider = /// Given a `FSharpAssemblySignature`, returns assembly content. @@ -115,6 +116,7 @@ module public AssemblyContentProvider = -> fileName: string option -> assemblies: FSharpAssembly list -> AssemblySymbol list +#endif /// Kind of lexical scope. type public ScopeKind = diff --git a/src/fsharp/service/ServiceDeclarationLists.fs b/src/fsharp/service/ServiceDeclarationLists.fs index c4bf83bf087..dbff4e2fda2 100644 --- a/src/fsharp/service/ServiceDeclarationLists.fs +++ b/src/fsharp/service/ServiceDeclarationLists.fs @@ -447,7 +447,7 @@ module internal DescriptionListsImpl = /// Get rid of groups of overloads an replace them with single items. /// (This looks like it is doing the a similar thing as FlattenItems, this code /// duplication could potentially be removed) - let AnotherFlattenItems g m item = + let AnotherFlattenItems g _m item = match item with | Item.CtorGroup(nm, cinfos) -> List.map (fun minfo -> Item.CtorGroup(nm, [minfo])) cinfos | Item.FakeInterfaceCtor _ @@ -467,7 +467,7 @@ module internal DescriptionListsImpl = let pinfo = List.head pinfos if pinfo.IsIndexer then [item] else [] #if !NO_EXTENSIONTYPING - | SymbolHelpers.ItemIsWithStaticArguments m g _ -> + | SymbolHelpers.ItemIsWithStaticArguments _m g _ -> // we pretend that provided-types-with-static-args are method-like in order to get ParamInfo for them [item] #endif @@ -480,18 +480,21 @@ module internal DescriptionListsImpl = /// An intellisense declaration [] -type FSharpDeclarationListItem(name: string, nameInCode: string, fullName: string, glyph: FSharpGlyph, info, accessibility: FSharpAccessibility option, +type FSharpDeclarationListItem(name: string, nameInCode: string, fullName: string, glyph: FSharpGlyph, _info, accessibility: FSharpAccessibility option, kind: CompletionItemKind, isOwnMember: bool, priority: int, isResolved: bool, namespaceToOpen: string option) = +#if !FABLE_COMPILER let mutable descriptionTextHolder: FSharpToolTipText<_> option = None let mutable task = null +#endif member __.Name = name member __.NameInCode = nameInCode +#if !FABLE_COMPILER member __.StructuredDescriptionTextAsync = let userOpName = "ToolTip" - match info with + match _info with | Choice1Of2 (items: CompletionItem list, infoReader, m, denv, reactor:IReactorOperations) -> // reactor causes the lambda to execute on the background compiler thread, through the Reactor reactor.EnqueueAndAwaitOpAsync (userOpName, "StructuredDescriptionTextAsync", name, fun ctok -> @@ -511,7 +514,7 @@ type FSharpDeclarationListItem(name: string, nameInCode: string, fullName: strin match descriptionTextHolder with | Some descriptionText -> descriptionText | None -> - match info with + match _info with | Choice1Of2 _ -> // The dataTipSpinWaitTime limits how long we block the UI thread while a tooltip pops up next to a selected item in an IntelliSense completion list. // This time appears to be somewhat amortized by the time it takes the VS completion UI to actually bring up the tooltip after selecting an item in the first place. @@ -532,7 +535,9 @@ type FSharpDeclarationListItem(name: string, nameInCode: string, fullName: strin result ) (fun err -> FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError err]) + member decl.DescriptionText = decl.StructuredDescriptionText |> Tooltips.ToFSharpToolTipText +#endif member __.Glyph = glyph member __.Accessibility = accessibility member __.Kind = kind @@ -552,7 +557,7 @@ type FSharpDeclarationListInfo(declarations: FSharpDeclarationListItem[], isForT member __.IsError = isError // Make a 'Declarations' object for a set of selected items - static member Create(infoReader:InfoReader, m: range, denv, getAccessibility, items: CompletionItem list, reactor, currentNamespaceOrModule: string[] option, isAttributeApplicationContext: bool) = + static member Create(infoReader:InfoReader, m: range, denv, getAccessibility, items: CompletionItem list, reactor: IReactorOperations, currentNamespaceOrModule: string[] option, isAttributeApplicationContext: bool) = let g = infoReader.g let isForType = items |> List.exists (fun x -> x.Type.IsSome) let items = items |> SymbolHelpers.RemoveExplicitlySuppressedCompletionItems g diff --git a/src/fsharp/service/ServiceDeclarationLists.fsi b/src/fsharp/service/ServiceDeclarationLists.fsi index ae8171bfb00..35c08bcc1fa 100644 --- a/src/fsharp/service/ServiceDeclarationLists.fsi +++ b/src/fsharp/service/ServiceDeclarationLists.fsi @@ -26,6 +26,7 @@ type public FSharpDeclarationListItem = /// Get the description text for the declaration. Computing this property may require using compiler /// resources and may trigger execution of a type provider method to retrieve documentation. /// +#if !FABLE_COMPILER /// May return "Loading..." if timeout occurs member StructuredDescriptionText : FSharpStructuredToolTipText @@ -35,6 +36,7 @@ type public FSharpDeclarationListItem = member StructuredDescriptionTextAsync : Async member DescriptionTextAsync : Async +#endif member Glyph : FSharpGlyph diff --git a/src/fsharp/service/ServiceLexing.fs b/src/fsharp/service/ServiceLexing.fs index 2deb0073598..8c42bc71368 100644 --- a/src/fsharp/service/ServiceLexing.fs +++ b/src/fsharp/service/ServiceLexing.fs @@ -527,12 +527,20 @@ type FSharpLineTokenizer(lexbuf: UnicodeLexing.Lexbuf, // so we need to split it into tokens that are used by VS for colorization // Stack for tokens that are split during postprocessing +#if FABLE_COMPILER + let tokenStack = Internal.Utilities.Text.Parsing.Stack<_>(31) +#else let mutable tokenStack = new Stack<_>() +#endif let delayToken tok = tokenStack.Push tok // Process: anywhite* # let processDirective (str: string) directiveLength delay cont = +#if FABLE_COMPILER + let hashIdx = str.IndexOf("#") +#else let hashIdx = str.IndexOf("#", StringComparison.Ordinal) +#endif if (hashIdx <> 0) then delay(WHITESPACE cont, 0, hashIdx - 1) delay(HASH_IF(range0, "", cont), hashIdx, hashIdx + directiveLength) hashIdx + directiveLength + 1 diff --git a/src/fsharp/service/ServiceUntypedParse.fs b/src/fsharp/service/ServiceUntypedParse.fs index 84c8947d13d..6aab900d484 100755 --- a/src/fsharp/service/ServiceUntypedParse.fs +++ b/src/fsharp/service/ServiceUntypedParse.fs @@ -987,8 +987,23 @@ module UntypedParseImpl = | ParsedInput.ImplFile input -> walkImplFileInput input type internal TS = AstTraversal.TraverseStep + +#if FABLE_COMPILER + let rec findMatches (prefix: string) (suffix: string) (str: string) (startIndex: int) = seq { + let i1 = str.IndexOf(prefix, startIndex) + if i1 >= 0 then + let i2 = str.IndexOf(suffix, i1 + prefix.Length) + if i2 >= 0 then + let index = i1 + prefix.Length + let count = i2 - index + let start = i2 + suffix.Length + yield index, count + yield! findMatches prefix suffix str start + } +#else /// Matches the most nested [< and >] pair. let insideAttributeApplicationRegex = Regex(@"(?<=\[\<)(?(.*?))(?=\>\])", RegexOptions.Compiled ||| RegexOptions.ExplicitCapture) +#endif /// Try to determine completion context for the given pair (row, columns) let TryGetCompletionContext (pos, parsedInput: ParsedInput, lineStr: string) : CompletionContext option = @@ -1348,6 +1363,26 @@ module UntypedParseImpl = let isLongIdent = Seq.forall (fun c -> IsIdentifierPartCharacter c || c = '.' || c = ':') // ':' may occur in "[]" +#if FABLE_COMPILER + // match the most nested paired [< and >] first + let matches = + findMatches "[<" ">]" lineStr 0 + |> Seq.filter (fun (m_Index, m_Length) -> m_Index <= pos.Column && m_Index + m_Length >= pos.Column) + |> Seq.toArray + + if not (Array.isEmpty matches) then + matches + |> Seq.tryPick (fun (m_Index, m_Length) -> + let col = pos.Column - m_Index + if col >= 0 && col < m_Length then + let str = lineStr.Substring(m_Index, m_Length) + let str = str.Substring(0, col).TrimStart() // cut other rhs attributes + let str = cutLeadingAttributes str + if isLongIdent str then + Some CompletionContext.AttributeApplication + else None + else None) +#else // match the most nested paired [< and >] first let matches = insideAttributeApplicationRegex.Matches lineStr @@ -1367,9 +1402,14 @@ module UntypedParseImpl = Some CompletionContext.AttributeApplication else None else None) +#endif else // Paired [< and >] were not found, try to determine that we are after [< without closing >] +#if FABLE_COMPILER + match lineStr.LastIndexOf("[<") with +#else match lineStr.LastIndexOf("[<", StringComparison.Ordinal) with +#endif | -1 -> None | openParenIndex when pos.Column >= openParenIndex + 2 -> let str = lineStr.[openParenIndex + 2..pos.Column - 1].TrimStart() diff --git a/src/fsharp/service/service.fs b/src/fsharp/service/service.fs index 7eac7390c29..d52fc517c18 100644 --- a/src/fsharp/service/service.fs +++ b/src/fsharp/service/service.fs @@ -17,7 +17,9 @@ open FSharp.Compiler.AbstractIL.Internal.Library open FSharp.Compiler.Ast open FSharp.Compiler.CompileOps open FSharp.Compiler.CompileOptions +#if !FABLE_COMPILER open FSharp.Compiler.Driver +#endif open FSharp.Compiler.ErrorLogger open FSharp.Compiler.Features open FSharp.Compiler.Lib @@ -89,6 +91,8 @@ type FSharpProjectOptions = member po.ProjectDirectory = System.IO.Path.GetDirectoryName(po.ProjectFileName) override this.ToString() = "FSharpProjectOptions(" + this.ProjectFileName + ")" +#if !FABLE_COMPILER + //---------------------------------------------------------------------------- // BackgroundCompiler // @@ -1278,4 +1282,6 @@ module PrettyNaming = let KeywordNames = Lexhelp.Keywords.keywordNames module FSharpFileUtilities = - let isScriptFile (fileName: string) = CompileOps.IsScript fileName \ No newline at end of file + let isScriptFile (fileName: string) = CompileOps.IsScript fileName + +#endif //!FABLE_COMPILER diff --git a/src/fsharp/service/service.fsi b/src/fsharp/service/service.fsi index 9f81f8fccda..215a40ee6cc 100755 --- a/src/fsharp/service/service.fsi +++ b/src/fsharp/service/service.fsi @@ -11,6 +11,7 @@ open System.IO open FSharp.Compiler.AbstractIL.ILBinaryReader open FSharp.Compiler +open FSharp.Compiler.AccessibilityLogic open FSharp.Compiler.Ast open FSharp.Compiler.Range open FSharp.Compiler.Text @@ -65,6 +66,8 @@ type public FSharpProjectOptions = Stamp: int64 option } +#if !FABLE_COMPILER + [] /// Used to parse and check F# source code. type public FSharpChecker = @@ -463,4 +466,6 @@ module public PrettyNaming = /// A set of helpers for dealing with F# files. module FSharpFileUtilities = - val isScriptFile : string -> bool \ No newline at end of file + val isScriptFile : string -> bool + +#endif //!FABLE_COMPILER diff --git a/src/fsharp/symbols/Exprs.fs b/src/fsharp/symbols/Exprs.fs index 7941a6be577..c91d746f35b 100644 --- a/src/fsharp/symbols/Exprs.fs +++ b/src/fsharp/symbols/Exprs.fs @@ -1148,8 +1148,13 @@ module FSharpExprConvert = | Const.UInt32 i -> E.Const(box i, tyR) | Const.Int64 i -> E.Const(box i, tyR) | Const.UInt64 i -> E.Const(box i, tyR) +#if FABLE_COMPILER + | Const.IntPtr i -> E.Const(box i, tyR) + | Const.UIntPtr i -> E.Const(box i, tyR) +#else | Const.IntPtr i -> E.Const(box (nativeint i), tyR) | Const.UIntPtr i -> E.Const(box (unativeint i), tyR) +#endif | Const.Decimal i -> E.Const(box i, tyR) | Const.Double i -> E.Const(box i, tyR) | Const.Single i -> E.Const(box i, tyR) diff --git a/src/fsharp/symbols/Exprs.fsi b/src/fsharp/symbols/Exprs.fsi index fd5d88c0225..72f87464815 100644 --- a/src/fsharp/symbols/Exprs.fsi +++ b/src/fsharp/symbols/Exprs.fsi @@ -12,6 +12,9 @@ open FSharp.Compiler.CompileOps /// Represents the definitional contents of an assembly, as seen by the F# language type public FSharpAssemblyContents = +#if FABLE_COMPILER + internal new : cenv: SymbolEnv * mimpls: TypedImplFile list -> FSharpAssemblyContents +#endif internal new : tcGlobals: TcGlobals * thisCcu: CcuThunk * thisCcuType: ModuleOrNamespaceType option * tcImports: TcImports * mimpls: TypedImplFile list -> FSharpAssemblyContents /// The contents of the implementation files in the assembly diff --git a/src/fsharp/symbols/SymbolHelpers.fs b/src/fsharp/symbols/SymbolHelpers.fs index b1c46d9bd72..5f47834e1da 100644 --- a/src/fsharp/symbols/SymbolHelpers.fs +++ b/src/fsharp/symbols/SymbolHelpers.fs @@ -433,9 +433,13 @@ module internal SymbolHelpers = | _ -> None /// Work out the source file for an item and fix it up relative to the CCU if it is relative. - let fileNameOfItem (g: TcGlobals) qualProjectDir (m: range) h = + let fileNameOfItem (g: TcGlobals) (qualProjectDir: string option) (m:range) (h:Item) = let file = m.FileName if verbose then dprintf "file stored in metadata is '%s'\n" file +#if FABLE_COMPILER + ignore g; ignore qualProjectDir; ignore h + file +#else if not (FileSystem.IsPathRootedShim file) then match ccuOfItem g h with | Some ccu -> @@ -444,7 +448,8 @@ module internal SymbolHelpers = match qualProjectDir with | None -> file | Some dir -> Path.Combine(dir, file) - else file + else file +#endif /// Cut long filenames to make them visually appealing let cutFileName s = if String.length s > 40 then String.sub s 0 10 + "..."+String.sub s (String.length s - 27) 27 else s @@ -785,7 +790,11 @@ module internal SymbolHelpers = | ValueSome tcref -> hash tcref.LogicalName | _ -> 1010 | Item.ILField(ILFieldInfo(_, fld)) -> +#if FABLE_COMPILER + (box fld).GetHashCode() // hash on the object identity of the AbstractIL metadata blob for the field +#else System.Runtime.CompilerServices.RuntimeHelpers.GetHashCode fld // hash on the object identity of the AbstractIL metadata blob for the field +#endif | Item.TypeVar (nm, _tp) -> hash nm | Item.CustomOperation (_, _, Some minfo) -> minfo.ComputeHashCode() | Item.CustomOperation (_, _, None) -> 1 @@ -1462,7 +1471,7 @@ module internal SymbolHelpers = (fun err -> FSharpStructuredToolTipElement.CompositionError err) /// Get rid of groups of overloads an replace them with single items. - let FlattenItems g (m: range) item = + let FlattenItems g (_m: range) item = match item with | Item.MethodGroup(nm, minfos, orig) -> minfos |> List.map (fun minfo -> Item.MethodGroup(nm, [minfo], orig)) | Item.CtorGroup(nm, cinfos) -> cinfos |> List.map (fun minfo -> Item.CtorGroup(nm, [minfo])) @@ -1479,7 +1488,7 @@ module internal SymbolHelpers = let pinfo = List.head pinfos if pinfo.IsIndexer then [item] else [] #if !NO_EXTENSIONTYPING - | ItemIsWithStaticArguments m g _ -> [item] // we pretend that provided-types-with-static-args are method-like in order to get ParamInfo for them + | ItemIsWithStaticArguments _m g _ -> [item] // we pretend that provided-types-with-static-args are method-like in order to get ParamInfo for them #endif | Item.CustomOperation(_name, _helpText, _minfo) -> [item] | Item.TypeVar _ -> [] diff --git a/src/fsharp/symbols/SymbolPatterns.fs b/src/fsharp/symbols/SymbolPatterns.fs index 6c2286b4095..e7186627ed3 100644 --- a/src/fsharp/symbols/SymbolPatterns.fs +++ b/src/fsharp/symbols/SymbolPatterns.fs @@ -11,7 +11,12 @@ module Symbol = let isAttribute<'T> (attribute: FSharpAttribute) = // CompiledName throws exception on DataContractAttribute generated by SQLProvider +#if FABLE_COMPILER + ignore attribute + false //TODO: alternative implementation +#else try attribute.AttributeType.CompiledName = typeof<'T>.Name with _ -> false +#endif let tryGetAttribute<'T> (attributes: seq) = attributes |> Seq.tryFind isAttribute<'T> @@ -41,9 +46,14 @@ module Symbol = && name.Substring (2, name.Length - 4) |> String.forall (fun c -> c <> ' ' && not (Char.IsLetter c)) +#if FABLE_COMPILER + let isUnnamedUnionCaseField (field: FSharpField) = + (field.Name.StartsWith "Item") && not (field.Name.Substring(4) |> String.exists (fun c -> not (Char.IsDigit c))) +#else let UnnamedUnionFieldRegex = Regex("^Item(\d+)?$", RegexOptions.Compiled) let isUnnamedUnionCaseField (field: FSharpField) = UnnamedUnionFieldRegex.IsMatch(field.Name) +#endif let (|AbbreviatedType|_|) (entity: FSharpEntity) = if entity.IsFSharpAbbreviation then Some entity.AbbreviatedType diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index f6b93d4e324..4d805bb385a 100644 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -71,7 +71,11 @@ module Impl = f let makeReadOnlyCollection (arr: seq<'T>) = +#if FABLE_COMPILER + System.Collections.Generic.List<_>(Seq.toArray arr) :> IList<_> +#else System.Collections.ObjectModel.ReadOnlyCollection<_>(Seq.toArray arr) :> IList<_> +#endif let makeXmlDoc (XmlDoc x) = makeReadOnlyCollection x @@ -396,7 +400,7 @@ and FSharpEntity(cenv: SymbolEnv, entity:EntityRef) = let fail() = invalidOp (sprintf "the type '%s' does not have a qualified name" x.LogicalName) #if !NO_EXTENSIONTYPING if entity.IsTypeAbbrev || entity.IsProvidedErasedTycon || entity.IsNamespace then fail() - #else +#else if entity.IsTypeAbbrev || entity.IsNamespace then fail() #endif match entity.CompiledRepresentation with @@ -413,7 +417,7 @@ and FSharpEntity(cenv: SymbolEnv, entity:EntityRef) = if isUnresolved() then None #if !NO_EXTENSIONTYPING elif entity.IsTypeAbbrev || entity.IsProvidedErasedTycon then None - #else +#else elif entity.IsTypeAbbrev then None #endif elif entity.IsNamespace then Some entity.DemangledModuleOrNamespaceName @@ -452,6 +456,7 @@ and FSharpEntity(cenv: SymbolEnv, entity:EntityRef) = member __.ArrayRank = checkIsResolved() rankOfArrayTyconRef cenv.g entity + #if !NO_EXTENSIONTYPING member __.IsProvided = isResolved() && @@ -469,6 +474,7 @@ and FSharpEntity(cenv: SymbolEnv, entity:EntityRef) = isResolved() && entity.IsProvidedGeneratedTycon #endif + member __.IsClass = isResolved() && match metadataOfTycon entity.Deref with @@ -921,7 +927,11 @@ and FSharpField(cenv: SymbolEnv, d: FSharpFieldData) = if isUnresolved() then None else match d.TryRecdField with | Choice1Of3 r -> getLiteralValue r.LiteralValue +#if FABLE_COMPILER + | Choice2Of3 _f -> None +#else | Choice2Of3 f -> f.LiteralValue |> Option.map AbstractIL.ILRuntimeWriter.convFieldInit +#endif | Choice3Of3 _ -> None member __.IsVolatile = @@ -1065,10 +1075,10 @@ and [] FSharpAccessibilityRights(thisCcu: CcuThunk, ad:AccessorDomain) = member internal __.Contents = ad -and FSharpActivePatternCase(cenv, apinfo: PrettyNaming.ActivePatternInfo, ty, n, valOpt: ValRef option, item) = +and FSharpActivePatternCase(cenv, apinfo: PrettyNaming.ActivePatternInfo, ty, n, valOpt: ValRef option, item2) = inherit FSharpSymbol (cenv, - (fun () -> item), + (fun () -> item2), (fun _ _ _ -> true)) member __.Name = apinfo.ActiveTags.[n] @@ -1352,10 +1362,10 @@ and FSharpMemberOrVal = FSharpMemberOrFunctionOrValue and FSharpMemberFunctionOrValue = FSharpMemberOrFunctionOrValue -and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = +and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item2) = inherit FSharpSymbol(cenv, - (fun () -> item), + (fun () -> item2), (fun this thisCcu2 ad -> let this = this :?> FSharpMemberOrFunctionOrValue checkForCrossProjectAccessibility (thisCcu2, ad) (cenv.thisCcu, this.Accessibility.Contents)) @@ -1413,7 +1423,7 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = checkIsResolved() match d with | M m | C m -> - match item with + match item2 with | Item.MethodGroup (_, methodInfos, _) | Item.CtorGroup (_, methodInfos) -> let isConstructor = x.IsConstructor @@ -1425,9 +1435,9 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = methods |> List.map (fun mi -> if isConstructor then - FSharpMemberOrFunctionOrValue(cenv, C mi, item) + FSharpMemberOrFunctionOrValue(cenv, C mi, item2) else - FSharpMemberOrFunctionOrValue(cenv, M mi, item)) + FSharpMemberOrFunctionOrValue(cenv, M mi, item2)) |> makeReadOnlyCollection |> Some | _ -> None @@ -1993,7 +2003,9 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = member x.IsValCompiledAsMethod = match d with +#if !FABLE_COMPILER | V valRef -> IlxGen.IsFSharpValCompiledAsMethod cenv.g valRef.Deref +#endif | _ -> false member x.IsValue = @@ -2223,7 +2235,7 @@ and FSharpType(cenv, ty:TType) = |> makeReadOnlyCollection static member Prettify(parameter: FSharpParameter) = - let prettyTy = parameter.V |> PrettyTypes.PrettifyType parameter.cenv.g |> fst + let prettyTy = parameter.V |> PrettyTypes.PrettifyType parameter.cenv2.g |> fst parameter.AdjustType prettyTy static member Prettify(parameters: IList) = @@ -2231,7 +2243,7 @@ and FSharpType(cenv, ty:TType) = match parameters with | [] -> [] | h :: _ -> - let cenv = h.cenv + let cenv = h.cenv2 let prettyTys = parameters |> List.map (fun p -> p.V) |> PrettyTypes.PrettifyTypes cenv.g |> fst (parameters, prettyTys) ||> List.map2 (fun p pty -> p.AdjustType pty) |> makeReadOnlyCollection @@ -2242,14 +2254,14 @@ and FSharpType(cenv, ty:TType) = match hOpt with | None -> xs | Some h -> - let cenv = h.cenv + let cenv = h.cenv2 let prettyTys = xs |> List.mapSquared (fun p -> p.V) |> PrettyTypes.PrettifyCurriedTypes cenv.g |> fst (xs, prettyTys) ||> List.map2 (List.map2 (fun p pty -> p.AdjustType pty)) |> List.map makeReadOnlyCollection |> makeReadOnlyCollection static member Prettify(parameters: IList>, returnParameter: FSharpParameter) = let xs = parameters |> List.ofSeq |> List.map List.ofSeq - let cenv = returnParameter.cenv + let cenv = returnParameter.cenv2 let prettyTys, prettyRetTy = xs |> List.mapSquared (fun p -> p.V) |> (fun tys -> PrettyTypes.PrettifyCurriedSigTypes cenv.g (tys, returnParameter.V) )|> fst let ps = (xs, prettyTys) ||> List.map2 (List.map2 (fun p pty -> p.AdjustType pty)) |> List.map makeReadOnlyCollection |> makeReadOnlyCollection ps, returnParameter.AdjustType prettyRetTy @@ -2340,7 +2352,7 @@ and FSharpParameter(cenv, paramTy:TType, topArgInfo:ArgReprInfo, mOpt, isParamAr member __.Name = match idOpt with None -> None | Some v -> Some v.idText - member __.cenv: SymbolEnv = cenv + member __.cenv2: SymbolEnv = cenv member __.AdjustType t = FSharpParameter(cenv, t, topArgInfo, mOpt, isParamArrayArg, isInArg, isOutArg, isOptionalArg) diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 6e063cd8314..ebe667fd6d8 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -36,13 +36,21 @@ open Microsoft.FSharp.Core.CompilerServices type Unique = int64 //++GLOBAL MUTABLE STATE (concurrency-safe) +#if FABLE_COMPILER +let newUnique = let i = ref 0L in fun () -> i := !i + 1L; !i +#else let newUnique = let i = ref 0L in fun () -> System.Threading.Interlocked.Increment i +#endif type Stamp = int64 /// Unique name generator for stamps attached to to val_specs, tycon_specs etc. //++GLOBAL MUTABLE STATE (concurrency-safe) +#if FABLE_COMPILER +let newStamp = let i = ref 0L in fun () -> i := !i + 1L; !i +#else let newStamp = let i = ref 0L in fun () -> System.Threading.Interlocked.Increment i +#endif type StampMap<'T> = Map @@ -476,7 +484,7 @@ type EntityFlags(flags: int64) = member x.PickledBits = (flags &&& ~~~0b000111111000100L) -#if DEBUG +#if DEBUG && !FABLE_COMPILER assert (sizeof = 8) assert (sizeof = 8) assert (sizeof = 4) diff --git a/src/ilx/EraseClosures.fs b/src/ilx/EraseClosures.fs index ca0dbfcdf8e..e5f0af32471 100644 --- a/src/ilx/EraseClosures.fs +++ b/src/ilx/EraseClosures.fs @@ -488,7 +488,7 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo = |> cenv.addMethodGeneratedAttrs let cloTypeDef = - ILTypeDef(name = td.Name, + ILTypeDef.Create(name = td.Name, genericParams= td.GenericParams, attributes = td.Attributes, implements = [], @@ -585,7 +585,7 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo = ILMemberAccess.Assembly) |> cenv.addMethodGeneratedAttrs - ILTypeDef(name = td.Name, + ILTypeDef.Create(name = td.Name, genericParams= td.GenericParams, attributes = td.Attributes, implements = [], diff --git a/src/ilx/EraseUnions.fs b/src/ilx/EraseUnions.fs index 1d0175676c8..3abc3f47a3f 100644 --- a/src/ilx/EraseUnions.fs +++ b/src/ilx/EraseUnions.fs @@ -614,7 +614,7 @@ let mkMethodsAndPropertiesForFields (addMethodGeneratedAttrs, addPropertyGenerat let basicProps = fields |> Array.map (fun field -> - ILPropertyDef(name = adjustFieldName hasHelpers field.Name, + ILPropertyDef.Create(name = adjustFieldName hasHelpers field.Name, attributes = PropertyAttributes.None, setMethod = None, getMethod = Some (mkILMethRef (ilTy.TypeRef, ILCallingConv.Instance, "get_" + adjustFieldName hasHelpers field.Name, 0, [], field.Type)), @@ -698,7 +698,7 @@ let convAlternativeDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addP mkMethodBody(true,[],2,nonBranchingInstrsToCode ([ mkLdarg0 ] @ mkIsData ilg (true, cuspec, num)), attr)) |> addMethodGeneratedAttrs ], - [ ILPropertyDef(name = mkTesterName altName, + [ ILPropertyDef.Create(name = mkTesterName altName, attributes = PropertyAttributes.None, setMethod = None, getMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Instance, "get_" + mkTesterName altName, 0, [], ilg.typ_Bool)), @@ -726,7 +726,7 @@ let convAlternativeDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addP let nullaryProp = - ILPropertyDef(name = altName, + ILPropertyDef.Create(name = altName, attributes = PropertyAttributes.None, setMethod = None, getMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Static, "get_" + altName, 0, [], baseTy)), @@ -827,7 +827,7 @@ let convAlternativeDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addP let debugProxyGetterProps = fields |> Array.map (fun fdef -> - ILPropertyDef(name = fdef.Name, + ILPropertyDef.Create(name = fdef.Name, attributes = PropertyAttributes.None, setMethod = None, getMethod = Some(mkILMethRef(debugProxyTy.TypeRef,ILCallingConv.Instance,"get_" + fdef.Name,0,[],fdef.Type)), @@ -1039,7 +1039,7 @@ let mkClassUnionDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addProp [ mkILNonGenericInstanceMethod("get_" + tagPropertyName,cud.cudHelpersAccess,[],mkILReturn tagFieldType,body) |> addMethodGeneratedAttrs ], - [ ILPropertyDef(name = tagPropertyName, + [ ILPropertyDef.Create(name = tagPropertyName, attributes = PropertyAttributes.None, setMethod = None, getMethod = Some(mkILMethRef(baseTy.TypeRef,ILCallingConv.Instance,"get_" + tagPropertyName,0,[], tagFieldType)), @@ -1066,7 +1066,7 @@ let mkClassUnionDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addProp None else let tdef = - ILTypeDef(name = "Tags", + ILTypeDef.Create(name = "Tags", nestedTypes = emptyILTypeDefs, genericParams= td.GenericParams, attributes = enum 0, diff --git a/src/utils/HashMultiMap.fs b/src/utils/HashMultiMap.fs index 7f571c232d0..f2efc561605 100644 --- a/src/utils/HashMultiMap.fs +++ b/src/utils/HashMultiMap.fs @@ -15,11 +15,13 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) let rest = Dictionary<_,_>(3,hasheq) +#if !FABLE_COMPILER new (hasheq : IEqualityComparer<'Key>) = HashMultiMap<'Key,'Value>(11, hasheq) new (seq : seq<'Key * 'Value>, hasheq : IEqualityComparer<'Key>) as x = new HashMultiMap<'Key,'Value>(11, hasheq) then seq |> Seq.iter (fun (k,v) -> x.Add(k,v)) +#endif member x.GetRest(k) = match rest.TryGetValue k with @@ -42,7 +44,11 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member x.Rest = rest member x.Copy() = +#if FABLE_COMPILER + let res = HashMultiMap<'Key,'Value>(firstEntries.Count, hasheq) +#else let res = HashMultiMap<'Key,'Value>(firstEntries.Count,firstEntries.Comparer) +#endif for kvp in firstEntries do res.FirstEntries.Add(kvp.Key,kvp.Value) @@ -117,6 +123,21 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member x.Count = firstEntries.Count +#if FABLE_COMPILER + interface System.Collections.IEnumerable with + member s.GetEnumerator() = ((s :> IEnumerable>).GetEnumerator() :> System.Collections.IEnumerator) + + interface IEnumerable> with + member s.GetEnumerator() = + let elems = seq { + for kvp in firstEntries do + yield kvp + for z in s.GetRest(kvp.Key) do + yield KeyValuePair(kvp.Key, z) + } + elems.GetEnumerator() +#else //!FABLE_COMPILER + interface IEnumerable> with member s.GetEnumerator() = @@ -150,6 +171,7 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member s.Remove(k:'Key) = let res = s.ContainsKey(k) in s.Remove(k); res +#endif interface ICollection> with diff --git a/src/utils/HashMultiMap.fsi b/src/utils/HashMultiMap.fsi index bd05cfc1d7a..eb189b16fb8 100644 --- a/src/utils/HashMultiMap.fsi +++ b/src/utils/HashMultiMap.fsi @@ -10,15 +10,19 @@ open System.Collections.Generic /// The table may map a single key to multiple bindings. [] type internal HashMultiMap<'Key,'Value> = +#if !FABLE_COMPILER /// Create a new empty mutable HashMultiMap with the given key hash/equality functions. new : comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> +#endif /// Create a new empty mutable HashMultiMap with an internal bucket array of the given approximate size /// and with the given key hash/equality functions. new : size:int * comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> +#if !FABLE_COMPILER /// Build a map that contains the bindings of the given IEnumerable. new : entries:seq<'Key * 'Value> * comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> +#endif /// Make a shallow copy of the collection. member Copy : unit -> HashMultiMap<'Key,'Value> @@ -58,7 +62,9 @@ type internal HashMultiMap<'Key,'Value> = /// Apply the given function to each binding in the hash table. member Iterate : ('Key -> 'Value -> unit) -> unit +#if !FABLE_COMPILER interface IDictionary<'Key, 'Value> +#endif interface ICollection> interface IEnumerable> interface System.Collections.IEnumerable diff --git a/src/utils/PathMap.fs b/src/utils/PathMap.fs index 3e4f6fad96c..cda4520ff52 100644 --- a/src/utils/PathMap.fs +++ b/src/utils/PathMap.fs @@ -17,7 +17,11 @@ module internal PathMap = let addMapping (src : string) (dst : string) (PathMap map) : PathMap = // Normalise the path +#if FABLE_COMPILER + let normalSrc = src // no file system +#else let normalSrc = Path.GetFullPath src +#endif let oldPrefix = if normalSrc.EndsWith dirSepStr then normalSrc diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs index 232d3b75053..efe059acda2 100644 --- a/src/utils/TaggedCollections.fs +++ b/src/utils/TaggedCollections.fs @@ -659,11 +659,15 @@ namespace Internal.Utilities.Collections.Tagged member s.ToArray () = SetTree.toArray tree - override this.Equals(that) = + override this.Equals(that) = +#if FABLE_COMPILER + ((this :> System.IComparable).CompareTo(that) = 0) +#else match that with // Cast to the exact same type as this, otherwise not equal. | :? Set<'T,'ComparerTag> as that -> ((this :> System.IComparable).CompareTo(that) = 0) | _ -> false +#endif interface System.IComparable with // Cast s2 to the exact same type as s1, see 4884. @@ -1141,11 +1145,15 @@ namespace Internal.Utilities.Collections.Tagged interface System.Collections.IEnumerable with override s.GetEnumerator() = (MapTree.toSeq tree :> System.Collections.IEnumerator) - override this.Equals(that) = + override this.Equals(that) = +#if FABLE_COMPILER + ((this :> System.IComparable).CompareTo(that) = 0) +#else match that with // Cast to the exact same type as this, otherwise not equal. | :? Map<'Key,'T,'ComparerTag> as that -> ((this :> System.IComparable).CompareTo(that) = 0) | _ -> false +#endif interface System.IComparable with member m1.CompareTo(m2: obj) = diff --git a/src/utils/prim-lexing.fs b/src/utils/prim-lexing.fs index 8d30b3cd793..040ad5840b8 100644 --- a/src/utils/prim-lexing.fs +++ b/src/utils/prim-lexing.fs @@ -88,7 +88,11 @@ type StringText(str: string) = if lastIndex <= startIndex || lastIndex >= str.Length then invalidArg "target" "Too big." +#if FABLE_COMPILER + str.IndexOf(target, startIndex) <> -1 +#else str.IndexOf(target, startIndex, target.Length) <> -1 +#endif member __.Length = str.Length @@ -98,7 +102,11 @@ type StringText(str: string) = | _ -> false member __.CopyTo(sourceIndex, destination, destinationIndex, count) = +#if FABLE_COMPILER + Array.blit (str.ToCharArray()) sourceIndex destination destinationIndex count +#else str.CopyTo(sourceIndex, destination, destinationIndex, count) +#endif module SourceText = diff --git a/src/utils/prim-parsing.fs b/src/utils/prim-parsing.fs index 4cbfee630b6..597f111624e 100644 --- a/src/utils/prim-parsing.fs +++ b/src/utils/prim-parsing.fs @@ -98,7 +98,7 @@ type Stack<'a>(n) = Array.blit old 0 contents 0 count member buf.Count = count - member buf.Pop() = count <- count - 1 + member buf.Pop() = count <- count - 1; contents.[count] member buf.Peep() = contents.[count - 1] member buf.Top(n) = [ for x in contents.[max 0 (count-n)..count - 1] -> x ] |> List.rev member buf.Push(x) = @@ -107,9 +107,11 @@ type Stack<'a>(n) = count <- count + 1 member buf.IsEmpty = (count = 0) +#if DEBUG member buf.PrintStack() = for i = 0 to (count - 1) do System.Console.Write("{0}{1}",(contents.[i]),if i=count-1 then ":" else "-") +#endif #if DEBUG @@ -294,8 +296,8 @@ module internal Implementation = if Flags.debug then System.Console.WriteLine("popping stack during error recovery") #endif - valueStack.Pop() - stateStack.Pop() + valueStack.Pop() |> ignore + stateStack.Pop() |> ignore popStackUntilErrorShifted(tokenOpt) while not finished do @@ -365,8 +367,8 @@ module internal Implementation = for i = 0 to n - 1 do if valueStack.IsEmpty then failwith "empty symbol stack" let topVal = valueStack.Peep() // Grab topVal - valueStack.Pop() - stateStack.Pop() + valueStack.Pop() |> ignore + stateStack.Pop() |> ignore let ruleIndex = (n-i)-1 ruleValues.[ruleIndex] <- topVal.value diff --git a/src/utils/prim-parsing.fsi b/src/utils/prim-parsing.fsi index 762c90796ab..196468174db 100644 --- a/src/utils/prim-parsing.fsi +++ b/src/utils/prim-parsing.fsi @@ -7,7 +7,18 @@ namespace Internal.Utilities.Text.Parsing open Internal.Utilities open Internal.Utilities.Text.Lexing +#if FABLE_COMPILER +type Stack<'T> = + new : int -> Stack<'T> + member Count : int + member Pop : unit -> 'T + member Peep : unit -> 'T + member Top : int -> 'T list + member Push : 'T -> unit + member IsEmpty : bool +#else open System.Collections.Generic +#endif [] type internal IParseState = diff --git a/src/utils/sformat.fs b/src/utils/sformat.fs index 42cb18fa8d0..4b9e090d924 100644 --- a/src/utils/sformat.fs +++ b/src/utils/sformat.fs @@ -14,7 +14,7 @@ #nowarn "52" // The value has been copied to ensure the original is not mutated by this operation -#if COMPILER +#if COMPILER || FABLE_COMPILER namespace Internal.Utilities.StructuredFormat #else // FSharp.Core.dll: @@ -306,6 +306,8 @@ namespace Microsoft.FSharp.Text.StructuredPrintfImpl let unfoldL selector folder state count = boundedUnfoldL selector folder (fun _ -> false) state count +#if !FABLE_COMPILER + /// These are a typical set of options used to control structured formatting. [] type FormatOptions = @@ -1258,3 +1260,5 @@ namespace Microsoft.FSharp.Text.StructuredPrintfImpl x |> anyL ShowAll bindingFlags options |> layout_to_string options #endif + +#endif //!FABLE_COMPILER diff --git a/src/utils/sformat.fsi b/src/utils/sformat.fsi index e6ff9762bb5..b40e399c8d5 100644 --- a/src/utils/sformat.fsi +++ b/src/utils/sformat.fsi @@ -14,7 +14,7 @@ // Note no layout objects are ever transferred between the above implementations, and in // all 4 cases the layout types are really different types. -#if COMPILER +#if COMPILER || FABLE_COMPILER // fsc.exe: // FSharp.Compiler.Service.dll: namespace Internal.Utilities.StructuredFormat @@ -268,6 +268,8 @@ namespace Microsoft.FSharp.Text.StructuredPrintfImpl /// If reach maxLength (before exhausting) then truncate. val unfoldL : selector:('T -> Layout) -> folder:('State -> ('T * 'State) option) -> state:'State -> count:int -> Layout list +#if !FABLE_COMPILER + /// A record of options to control structural formatting. /// For F# Interactive properties matching those of this value can be accessed via the 'fsi' /// value. @@ -357,3 +359,5 @@ namespace Microsoft.FSharp.Text.StructuredPrintfImpl #if COMPILER val fsi_any_to_layout : options:FormatOptions -> value:'T * Type -> Layout #endif + +#endif //!FABLE_COMPILER \ No newline at end of file