diff --git a/.gitignore b/.gitignore index 857182a3dc..5d94c27371 100644 --- a/.gitignore +++ b/.gitignore @@ -191,7 +191,7 @@ artifacts/*.nupkg *.orig *.mdf *.ldf -.paket/paket.exe +fcs/.paket/paket.exe paket-files docsrc/tools/FSharp.Formatting.svclog src/fsharp/FSharp.Compiler.Service/pplex.fs @@ -201,6 +201,7 @@ src/fsharp/FSharp.Compiler.Service/pppars.fsi *.cto *.vstman project.lock.json +.vscode src/fsharp/FSharp.Compiler.Service/FSComp.fs src/fsharp/FSharp.Compiler.Service/FSComp.resx diff --git a/fcs/build.fsx b/fcs/build.fsx index 5690fb73b0..45f316c1e3 100644 --- a/fcs/build.fsx +++ b/fcs/build.fsx @@ -80,6 +80,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" runDotnet __SOURCE_DIRECTORY__ "build FSharp.Compiler.Service.sln -v n -c release" @@ -98,6 +102,25 @@ 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/" + + // run FCS codegen (except that fssrgen runs without .resx output to inline it) + 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 ) @@ -125,6 +148,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 0000000000..db7b2bd566 --- /dev/null +++ b/fcs/fcs-fable/.gitignore @@ -0,0 +1,3 @@ +# Codegen +codegen/*.fs +codegen/*.fsi diff --git a/fcs/fcs-fable/adapters.fs b/fcs/fcs-fable/adapters.fs new file mode 100644 index 0000000000..408623ab27 --- /dev/null +++ b/fcs/fcs-fable/adapters.fs @@ -0,0 +1,155 @@ +namespace Internal.Utilities + +#nowarn "1182" + +//------------------------------------------------------------------------ +// shims for things not yet implemented in Fable +//------------------------------------------------------------------------ + +module System = + + module Decimal = + let GetBits(d: decimal): int[] = [| 0; 0; 0; 0 |] //TODO: proper implementation + + 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) + + module Collections = + module Concurrent = + open System.Collections.Generic + + type ConcurrentDictionary<'TKey, 'TValue when 'TKey: equality>(comparer: IEqualityComparer<'TKey>) = + inherit Dictionary<'TKey, 'TValue>(comparer) + new () = ConcurrentDictionary { + new IEqualityComparer<'TKey> with + member __.GetHashCode(x) = x.GetHashCode() + member __.Equals(x, y) = x.Equals(y) } + member x.TryAdd (key:'TKey, value:'TValue) = x.[key] <- value; true + member x.GetOrAdd (key:'TKey, valueFactory: 'TKey -> 'TValue): 'TValue = + match x.TryGetValue key with + | true, v -> v + | false, _ -> let v = valueFactory(key) in x.[key] <- v; v + + module IO = + module Directory = + let GetCurrentDirectory () = "." //TODO: proper xplat implementation + + 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 GetFullPath (path: string) = //TODO: proper xplat implementation + path + + 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("/") + + +module Microsoft = + module FSharp = + + //------------------------------------------------------------------------ + // From reshapedreflection.fs + //------------------------------------------------------------------------ + module Core = + module XmlAdapters = + let s_escapeChars = [| '<'; '>'; '\"'; '\''; '&' |] + let getEscapeSequence c = + match c with + | '<' -> "<" + | '>' -> ">" + | '\"' -> """ + | '\'' -> "'" + | '&' -> "&" + | _ as ch -> ch.ToString() + let escape str = String.collect getEscapeSequence str + + //------------------------------------------------------------------------ + // From sr.fs + //------------------------------------------------------------------------ + module 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/ast_print.fs b/fcs/fcs-fable/ast_print.fs new file mode 100644 index 0000000000..a155d1c4b3 --- /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 Microsoft.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 0000000000..ac42bff1c0 --- /dev/null +++ b/fcs/fcs-fable/codegen/codegen.fsproj @@ -0,0 +1,47 @@ + + + $(MSBuildProjectDirectory)\..\..\..\src + + + + + + Exe + netcoreapp2.1 + + + + + --module Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiParser --open Microsoft.FSharp.Compiler.AbstractIL --internal --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing + ilpars.fsy + + + --module Microsoft.FSharp.Compiler.Parser --open Microsoft.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 Microsoft.FSharp.Compiler.PPParser --open Microsoft.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 0000000000..529a0a1d54 --- /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 0000000000..c28706b5d6 --- /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 0000000000..535783eafd --- /dev/null +++ b/fcs/fcs-fable/fcs-fable.fsproj @@ -0,0 +1,218 @@ + + + $(MSBuildProjectDirectory)/../../src + + + + netstandard2.0 + $(DefineConstants);FABLE_COMPILER + $(DefineConstants);FX_NO_CORHOST_SIGNER + $(DefineConstants);FX_NO_LINKEDRESOURCES + $(DefineConstants);FX_NO_PDB_READER + $(DefineConstants);FX_NO_PDB_WRITER + $(DefineConstants);FX_NO_WEAKTABLE + $(DefineConstants);FX_REDUCED_EXCEPTIONS + $(DefineConstants);NO_COMPILER_BACKEND + $(DefineConstants);NO_EXTENSIONTYPING + $(DefineConstants);NO_INLINE_IL_PARSER + $(OtherFlags) --warnon:1182 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fcs/fcs-fable/fsstrings.fs b/fcs/fcs-fable/fsstrings.fs new file mode 100644 index 0000000000..e83b30f01b --- /dev/null +++ b/fcs/fcs-fable/fsstrings.fs @@ -0,0 +1,980 @@ +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}." + ); + ( "PossibleBestOverload", + "\n\nPossible best overload: '{0}'." + ); + ( "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/service_shim.fs b/fcs/fcs-fable/service_shim.fs new file mode 100644 index 0000000000..ad4a17c4b4 --- /dev/null +++ b/fcs/fcs-fable/service_shim.fs @@ -0,0 +1,479 @@ +// 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. + +// Open up the compiler as an incremental service for parsing, +// type checking and intellisense-like environment-reporting. + +namespace Microsoft.FSharp.Compiler.SourceCodeServices + +#nowarn "1182" + +open Internal.Utilities +open Internal.Utilities.Collections +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Control + +open System +open System.Text +open System.Threading +open System.Collections.Concurrent +open System.Collections.Generic + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library + +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.ReferenceResolver +open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.Parser +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Lexhelp +open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.Tastops.DebugPrint +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.TypeChecker + + +//------------------------------------------------------------------------- +// InteractiveChecker +//------------------------------------------------------------------------- + +type internal TcResult = TcEnv * TopAttribs * TypedImplFile option * ModuleOrNamespaceType + +type InteractiveChecker internal (tcConfig, tcGlobals, tcImports, tcInitialState, ctok, reactorOps, parseCache, checkCache) = + let userOpName = "Unknown" + + static member Create(references: string[], readAllBytes: string -> byte[], defines: string[], optimize: bool) = + + 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 tcConfig = TcConfig (optimize, defines = Array.toList defines) + 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 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 = + { 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 -> 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) + +#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) + + let niceNameGen = NiceNameGenerator() + let amap = tcImports.GetImportMap() + let rng = rangeN Lexhelp.stdinMockFilename 0 + + let assemblyName = "Project" + let ccus = ccuInfos |> List.map (fun x -> x.FSharpViewOfMetadata, x.AssemblyAutoOpenAttributes, x.AssemblyInternalsVisibleToAttributes) + let tcInitialEnv = CreateInitialTcEnv (tcGlobals, amap, rng, assemblyName, ccus) + let tcInitialState = GetInitialTcState (rangeStartup, assemblyName, tcConfig, tcGlobals, tcImports, niceNameGen, tcInitialEnv) + let ctok = CompilationThreadToken() + + 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 staleParseKeys = parseCache.Keys |> Seq.filter (fun (n,_) -> n = fileName) |> Seq.toArray + let staleCheckKeys = parsingOptions.SourceFiles |> Array.skip fileIndex + staleParseKeys |> Array.iter (fun key -> parseCache.Remove(key) |> ignore) + staleCheckKeys |> Array.iter (fun key -> checkCache.Remove(key) |> 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 parseErrors, parseTreeOpt, anyErrors = Parser.parseFile (source, fileName, parsingOptions, userOpName) + let dependencyFiles = [||] // interactions have no dependencies + FSharpParseFileResults (parseErrors, parseTreeOpt, anyErrors, dependencyFiles) ) + + member private x.CheckFile (projectFileName: string, parseResults: FSharpParseFileResults, tcState: TcState, moduleNamesDict: ModuleNamesDict) = + match parseResults.ParseTree with + | Some input -> + let capturingErrorLogger = CompilationErrorLogger("TypeCheckFile", tcConfig.errorSeverityOptions) + let errorLogger = GetErrorLoggerFilteringByScopedPragmas(false, GetScopedPragmasForInput(input), capturingErrorLogger) + use _errorScope = new CompilationGlobalsScope (errorLogger, BuildPhase.TypeCheck) + + let sink = TcResultsSinkImpl(tcGlobals) + let tcSink = TcResultsSink.WithSink sink + let checkForErrors () = parseResults.ParseHadErrors || errorLogger.ErrorCount > 0 + let prefixPathOpt = None + + let input, moduleNamesDict = input |> DeduplicateParsedInputModuleName moduleNamesDict + let (tcEnvAtEnd, topAttrs, implFile, ccuSigForFile), tcState = + TypeCheckOneInputEventually (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input) + |> Eventually.force ctok + + let fileName = parseResults.FileName + checkCache.[fileName] <- ((tcEnvAtEnd, topAttrs, implFile, ccuSigForFile), (tcState, moduleNamesDict)) + + let loadClosure = None + let checkAlive () = true + let textSnapshotInfo = None + let keepAssemblyContents = true + + let tcErrors = ErrorHelpers.CreateErrorInfos (tcConfig.errorSeverityOptions, false, fileName, (capturingErrorLogger.GetErrors())) + 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, checkAlive, textSnapshotInfo, implFile, sink.GetOpenDeclarations()) + FSharpCheckFileResults (fileName, errors, Some scope, parseResults.DependencyFiles, None, reactorOps, keepAssemblyContents) + |> Some + | None -> + None + + member private x.TypeCheckClosedInputSet (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) = + let fileNameOf = function + | ParsedInput.SigFile (ParsedSigFileInput(fileName,_,_,_,_)) -> fileName + | ParsedInput.ImplFile (ParsedImplFileInput(fileName,_,_,_,_,_,_)) -> fileName + let cachedTypeCheck (tcState, moduleNamesDict) (input: ParsedInput) = + let checkCacheKey = fileNameOf input + let typeCheckOneInput _fileName = + let input, moduleNamesDict = input |> DeduplicateParsedInputModuleName moduleNamesDict + let tcResults, tcState = + TypeCheckOneInput (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt) tcState input + tcResults, (tcState, moduleNamesDict) + checkCache.GetOrAdd(checkCacheKey, typeCheckOneInput) + let results, (tcState, moduleNamesDict) = + ((tcState, Map.empty), inputs) ||> List.mapFold cachedTypeCheck + let (tcEnvAtEndOfLastFile, topAttrs, implFiles, _ccuSigsForFiles), tcState = + TypeCheckMultipleInputsFinish(results, tcState) + let tcState, declaredImpls = TypeCheckClosedInputSetFinish (implFiles, tcState) + tcState, topAttrs, declaredImpls, tcEnvAtEndOfLastFile, moduleNamesDict + + /// 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 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 checkAlive () = true + let textSnapshotInfo = None + let tcState = tcInitialState + let tcResults = Parser.CheckOneFile( + parseResults, source, fileName, projectFileName, tcConfig, tcGlobals, tcImports, tcState, + moduleNamesDict, loadClosure, backgroundErrors, reactorOps, checkAlive, textSnapshotInfo, userOpName) + match tcResults with + | tcErrors, Parser.TypeCheckAborted.No scope -> + let errors = Array.append parseResults.Errors tcErrors + let tcImplFilesOpt = match scope.ImplementationFile with Some x -> Some [x] | None -> None + let typeCheckResults = FSharpCheckFileResults (fileName, errors, Some scope, parseResults.DependencyFiles, None, reactorOps, true) + let symbolUses = [scope.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 + let parseHadErrors = parseResults |> Array.exists (fun p -> p.ParseHadErrors) + let parsedInputs = parseResults |> Array.choose (fun p -> p.ParseTree) |> Array.toList + + // type check files + use errorScope = new ErrorScope() + let hasTypedErrors () = errorScope.Diagnostics |> List.exists (fun e -> e.Severity = FSharpErrorSeverity.Error) + let checkForErrors () = parseHadErrors || hasTypedErrors () + let prefixPathOpt = None + let tcState, topAttrs, tcImplFiles, _tcEnvAtEnd, _moduleNamesDict = + x.TypeCheckClosedInputSet (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcInitialState, parsedInputs) + + // make project results + let parseErrors = parseResults |> Array.collect (fun p -> p.Errors) + let typedErrors = errorScope.Diagnostics |> List.toArray + let errors = Array.append parseErrors typedErrors //TODO: order by file + 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 + let parseHadErrors = parseResults |> Array.exists (fun p -> p.ParseHadErrors) + let parsedInputs = parseResults |> Array.choose (fun p -> p.ParseTree) |> Array.toList + + // type check files before file + use errorScope = new ErrorScope() + let hasTypedErrors () = errorScope.Diagnostics |> List.exists (fun e -> e.Severity = FSharpErrorSeverity.Error) + let checkForErrors () = parseHadErrors || hasTypedErrors () + let prefixPathOpt = None + let tcState, topAttrs, tcImplFiles, _tcEnvAtEnd, moduleNamesDict = + x.TypeCheckClosedInputSet (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcInitialState, parsedInputs) + + // parse and type check file + let parseFileResults = parseFile (fileName, sources.[fileIndex]) + let checkFileResults = x.CheckFile (projectFileName, parseFileResults, tcState, moduleNamesDict) + let (_tcEnvAtEndFile, topAttrsFile, implFile, _ccuSigForFile), (tcState, _moduleNamesDict) = + checkCache.[fileName] + + // collect errors + let parseErrorsBefore = parseResults |> Array.collect (fun p -> p.Errors) + let typedErrorsBefore = errorScope.Diagnostics |> List.toArray + let newErrors = match checkFileResults with | Some res -> res.Errors | None -> [||] + let errors = [| yield! parseErrorsBefore; yield! typedErrorsBefore; yield! newErrors |] //TODO: order by file + + // 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 0000000000..66d36d51d6 --- /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 0000000000..0e1a7990a7 --- /dev/null +++ b/fcs/fcs-fable/test/Metadata.fs @@ -0,0 +1,195 @@ +module Metadata + +let references_core = [| + "Fable.Core" + "Fable.Import.Browser" + "FSharp.Core" + "mscorlib" + "netstandard" + "System.Collections" + "System.Collections.Concurrent" + "System.Console" + "System.Core" + "System.Diagnostics.Debug" + "System.Diagnostics.Tracing" + "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 use_net45_meta = + if use_net45_meta then + [|"Fable.Core" + "Fable.Import.Browser" + "FSharp.Core" + "mscorlib" + "System" + "System.Core" + "System.Data" + "System.IO" + "System.Xml" + "System.Numerics" + |] + else + [|"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 0000000000..fb541d360c --- /dev/null +++ b/fcs/fcs-fable/test/Platform.fs @@ -0,0 +1,62 @@ +module Platform + +#if DOTNET_FILE_SYSTEM + +open System.IO + +let readAllBytes metadataPath (fileName:string) = File.ReadAllBytes (metadataPath + fileName) +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 + +#else // !DOTNET_FILE_SYSTEM + +open Fable.Core.JsInterop + +type private IFileSystem = + abstract readFileSync: string -> byte[] + abstract readFileSync: string * string -> string + abstract writeFileSync: string * string -> unit + +type private IProcess = + abstract hrtime: unit -> float [] + abstract hrtime: float[] -> float[] + +let private File: IFileSystem = importAll "fs" +let private Process: IProcess = importAll "process" + +let readAllBytes metadataPath (fileName:string) = File.readFileSync (metadataPath + fileName) +let readAllText (filePath:string) = (File.readFileSync (filePath, "utf8")).TrimStart('\uFEFF') +let writeAllText (filePath:string) (text:string) = File.writeFileSync (filePath, text) + +let measureTime (f: 'a -> 'b) x = + let startTime = Process.hrtime() + let res = f x + let elapsed = Process.hrtime(startTime) + int64 (elapsed.[0] * 1e3 + elapsed.[1] / 1e6), res + +#endif + +module Path = + + let Combine (path1: string, path2: string) = + let path1 = + if path1.Length = 0 then path1 + else (path1.TrimEnd [|'\\';'/'|]) + "/" + path1 + (path2.TrimStart [|'\\';'/'|]) + + let GetFileName (path: string) = + let normPath = path.Replace("\\", "/").TrimEnd('/') + let i = normPath.LastIndexOf("/") + normPath.Substring(i + 1) + + 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/Properties/launchSettings.json b/fcs/fcs-fable/test/Properties/launchSettings.json new file mode 100644 index 0000000000..f014faf066 --- /dev/null +++ b/fcs/fcs-fable/test/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.fs b/fcs/fcs-fable/test/bench.fs new file mode 100644 index 0000000000..c4763d97cf --- /dev/null +++ b/fcs/fcs-fable/test/bench.fs @@ -0,0 +1,150 @@ +module App + +open System.Text.RegularExpressions +open Microsoft.FSharp.Compiler.SourceCodeServices +open Platform + +let references = Metadata.references_core +let metadataPath = "/temp/repl/metadata2/" // .NET BCL binaries + +let parseProjectFile projectPath = + let projectFileName = Path.GetFileName projectPath + let projectText = readAllText projectPath + + // remove all comments + let projectText = Regex.Replace(projectText, @"", "") + + // get conditional defines + let definesRegex = @"]*>([^<]*)<\/DefineConstants[^>]*>" + let defines = + Regex.Matches(projectText, definesRegex) + |> 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 project references + let projectRefsRegex = @"]*Include\s*=\s*(""[^""]*|'[^']*)" + let projectRefs = + Regex.Matches(projectText, projectRefsRegex) + |> Seq.map (fun m -> m.Groups.[1].Value.TrimStart('"').TrimStart(''').Trim().Replace("\\", "/")) + |> Seq.toArray + + // replace some variables + let projectText = projectText.Replace(@"$(MSBuildProjectDirectory)", ".") + let projectText = projectText.Replace(@"$(FSharpSourcesRoot)", "../../src") + + // 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 + + (projectFileName, projectRefs, sourceFiles, defines) + +let rec parseProject projectPath = + let (projectFileName, projectRefs, sourceFiles, defines) = parseProjectFile projectPath + + let projectFileDir = Path.GetDirectoryName projectPath + let isAbsolutePath (path: string) = path.StartsWith("/") + let trimPath (path: string) = path.TrimStart([|'.';'/'|]) + let makePath path = if isAbsolutePath path then path else Path.Combine(projectFileDir, path) + let makeName path = Path.Combine(trimPath projectFileDir, trimPath path) + + let fileNames = sourceFiles |> Array.map (fun path -> path |> makeName) + let sources = sourceFiles |> Array.map (fun path -> path |> makePath |> readAllText) + + let parsedProjects = projectRefs |> Array.map makePath |> Array.map parseProject + let fileNames = fileNames |> Array.append (parsedProjects |> Array.collect (fun (_,x,_,_) -> x)) + let sources = sources |> Array.append (parsedProjects |> Array.collect (fun (_,_,x,_) -> x)) + let defines = defines |> Array.append (parsedProjects |> Array.collect (fun (_,_,_,x) -> x)) + + (projectFileName, fileNames, sources, defines |> Array.distinct) + +let dedupFileNames fileNames = + let nameSet = System.Collections.Generic.HashSet() + let padName (name: string) = + let pos = name.LastIndexOf(".") + let nm = if pos < 0 then name else name.Substring(0, pos) + let ext = if pos < 0 then "" else name.Substring(pos) + nm + "_" + ext + let rec dedup name = + if nameSet.Contains(name) then + dedup (padName name) + else + nameSet.Add(name) |> ignore + name + fileNames |> Array.map dedup + +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 projectPath outDir optimized = + // parse project + let (projectFileName, fileNames, sources, defines) = parseProject projectPath + + // dedup file names + let fileNames = dedupFileNames fileNames + + // create checker + let createChecker () = InteractiveChecker.Create(references, readAllBytes metadataPath, defines, optimize=false) + 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 + + // 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 optimized + 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 + | [| projectPath |] -> + let outDir = "./out-test" + let optimized = opts |> Array.contains "--optimize-fcs" + parseFiles projectPath outDir optimized + | _ -> printfn "%s" usage + +[] +let main argv = + try + parseArguments argv + with ex -> + printfn "Error: %A" ex.Message + 0 diff --git a/fcs/fcs-fable/test/fcs-fable-bench.fsproj b/fcs/fcs-fable/test/fcs-fable-bench.fsproj new file mode 100644 index 0000000000..b675ca64be --- /dev/null +++ b/fcs/fcs-fable/test/fcs-fable-bench.fsproj @@ -0,0 +1,23 @@ + + + + Exe + netcoreapp2.1 + $(DefineConstants);DOTNET_FILE_SYSTEM + + + + + + + + + + + + + + + + + diff --git a/fcs/fcs-fable/test/fcs-fable-bench.sln b/fcs/fcs-fable/test/fcs-fable-bench.sln new file mode 100644 index 0000000000..fa63eb3e00 --- /dev/null +++ b/fcs/fcs-fable/test/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 0000000000..b723c7bd24 --- /dev/null +++ b/fcs/fcs-fable/test/fcs-fable-test.fsproj @@ -0,0 +1,24 @@ + + + + Exe + netcoreapp2.1 + $(DefineConstants);DOTNET_FILE_SYSTEM + + + + + + + + + + + + + + + + + + diff --git a/fcs/fcs-fable/test/package.json b/fcs/fcs-fable/test/package.json new file mode 100644 index 0000000000..d7728f8edd --- /dev/null +++ b/fcs/fcs-fable/test/package.json @@ -0,0 +1,20 @@ +{ + "name": "fcs-fable-test", + "version": "1.0.0", + "description": "FCS-Fable test", + "keywords": [], + "author": "", + "license": "", + "scripts": { + "build-test": "dotnet run -c Release -p ../../../../Fable/src/dotnet/Fable.Compiler npm-splitter", + "splitter": "node ./node_modules/fable-splitter/dist/cli --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 fcs-fable-bench.fsproj ../fcs-fable.fsproj" + }, + "devDependencies": { + "@babel/core": "^7.2.0", + "@babel/plugin-transform-modules-commonjs": "^7.2.0", + "fable-splitter": "2.0.2" + } +} diff --git a/fcs/fcs-fable/test/splitter.config.js b/fcs/fcs-fable/test/splitter.config.js new file mode 100644 index 0000000000..7995bac7a8 --- /dev/null +++ b/fcs/fcs-fable/test/splitter.config.js @@ -0,0 +1,31 @@ +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_LINKEDRESOURCES", + "FX_NO_PDB_READER", + "FX_NO_PDB_WRITER", + "FX_NO_WEAKTABLE", + "FX_REDUCED_EXCEPTIONS", + "NO_COMPILER_BACKEND", + "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 0000000000..4b4d2056b6 --- /dev/null +++ b/fcs/fcs-fable/test/test.fs @@ -0,0 +1,64 @@ +module App + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.SourceCodeServices +open Platform + +let references = Metadata.references_core +let metadataPath = "/temp/repl/metadata2/" // .NET BCL binaries + +[] +let main argv = + printfn "Parsing begins..." + + let defines = [||] + let optimize = false + let checker = InteractiveChecker.Create(references, readAllBytes metadataPath, 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 0000000000..1bbe729ab7 --- /dev/null +++ b/fcs/fcs-fable/test/test_script.fsx @@ -0,0 +1,8 @@ +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. diff --git a/src/absil/il.fs b/src/absil/il.fs index 61c5a33a84..7070bf2077 100644 --- a/src/absil/il.fs +++ b/src/absil/il.fs @@ -7,6 +7,12 @@ module Microsoft.FSharp.Compiler.AbstractIL.IL #nowarn "346" // The struct, record or union type 'IlxExtensionType' has an explicit implementation of 'Object.Equals'. ... +open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core +#endif + open System open System.Diagnostics open System.IO @@ -21,8 +27,6 @@ open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Internal.Utilities - let logging = false let runningOnMono = @@ -395,6 +399,7 @@ type ILAssemblyRef(data) = assemRefVersion=version assemRefLocale=locale } +#if !FABLE_COMPILER static member FromAssemblyName (aname:System.Reflection.AssemblyName) = let locale = None @@ -416,11 +421,16 @@ type ILAssemblyRef(data) = let retargetable = aname.Flags = System.Reflection.AssemblyNameFlags.Retargetable ILAssemblyRef.Create(aname.Name, None, publicKey, retargetable, version, locale) - +#endif + member aref.QualifiedName = let b = new System.Text.StringBuilder(100) let add (s:string) = (b.Append(s) |> ignore) +#if FABLE_COMPILER + let addC (s:char) = (b.Append(string s) |> ignore) +#else let addC (s:char) = (b.Append(s) |> ignore) +#endif add(aref.Name) match aref.Version with | None -> () @@ -1580,15 +1590,19 @@ 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) = - ILMethodDef(name, attributes, implAttributes, callingConv, parameters, ret, body, isEntryPoint, genericParams, - storeILSecurityDecls securityDecls, storeILCustomAttrs customAttrs, NoMetadataIdx) - + 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) + // The captured data - remember the object will be as large as the data captured by these members member __.Name = name @@ -1615,7 +1629,7 @@ type ILMethodDef (name: string, attributes: MethodAttributes, implAttributes: Me member __.MetadataIndex = metadataIndex member x.With (?name: string, ?attributes: MethodAttributes, ?implAttributes: MethodImplAttributes, ?callingConv: ILCallingConv, ?parameters: ILParameters, ?ret: ILReturn, ?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, @@ -1731,10 +1745,13 @@ 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 @@ -1749,7 +1766,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, @@ -1775,10 +1792,13 @@ 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 @@ -1794,7 +1814,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, @@ -1831,11 +1851,15 @@ 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 @@ -1848,7 +1872,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, @@ -2006,15 +2030,18 @@ 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) = - ILTypeDef (name, attributes, layout, implements, genericParams, extends, methods, nestedTypes, fields, methodImpls, events, properties, storeILSecurityDecls securityDecls, storeILCustomAttrs customAttrs, NoMetadataIdx) + 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 member __.Attributes = attributes @@ -2033,7 +2060,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, @@ -2130,10 +2157,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 -> System.Threading.LazyInitializer.EnsureInitialized(&store, System.Func<_>(fun () -> f())) | ILTypeDefStored.Reader f -> System.Threading.LazyInitializer.EnsureInitialized(&store, System.Func<_>(fun () -> f x.MetadataIndex)) +#endif | _ -> store and ILTypeDefStored = @@ -2199,8 +2231,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" @@ -2414,7 +2448,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() = System.Threading.Interlocked.Increment(codeLabelCount) +#endif let instrIsRet i = match i with @@ -2848,7 +2886,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, @@ -2887,7 +2925,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, @@ -2903,7 +2941,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, @@ -2924,7 +2962,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 ||| @@ -2943,7 +2981,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, @@ -3031,7 +3069,7 @@ let prependInstrsToClassCtor instrs tag 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 ||| @@ -3148,7 +3186,7 @@ let mkILStorageCtor(tag, preblock, ty, flds, access) = mkILStorageCtorWithParamN 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, implements = impl, @@ -3164,7 +3202,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), implements = [], @@ -3739,7 +3777,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(System.Reflection.AssemblyName(scope))) +#endif else ILScopeRef.Local @@ -3887,7 +3929,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(System.Reflection.AssemblyName(aname))) +#endif | None -> ilg.primaryAssemblyScopeRef let tref = mkILTyRef (scoref, unqualified_tname) @@ -4150,11 +4196,17 @@ let parseILVersion (vstr : string) = versionComponents.[3] <- defaultRevision.ToString() vstr <- System.String.Join(".", versionComponents) +#if FABLE_COMPILER + let parts = vstr.Split([|'.'|]) + let versions = Array.append (Array.map uint16 parts) [|0us;0us;0us;0us|] + (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) (zero32 version.Major, zero32 version.Minor, zero32 version.Build, minorRevision) +#endif let compareILVersions (a1, a2, a3, a4) ((b1, b2, b3, b4) : ILVersionInfo) = diff --git a/src/absil/il.fsi b/src/absil/il.fsi index 668459088f..4e32bf9ab3 100755 --- a/src/absil/il.fsi +++ b/src/absil/il.fsi @@ -58,7 +58,9 @@ type ILVersionInfo = uint16 * uint16 * uint16 * uint16 [] 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. @@ -952,16 +954,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 @@ -1055,16 +1057,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 @@ -1104,16 +1106,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 @@ -1140,16 +1142,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 @@ -1245,16 +1247,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 8b58001bd8..803808a1cc 100755 --- a/src/absil/ildiag.fs +++ b/src/absil/ildiag.fs @@ -6,6 +6,12 @@ module internal Microsoft.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 d0b8ab9557..3e33254f92 100755 --- a/src/absil/ildiag.fsi +++ b/src/absil/ildiag.fsi @@ -8,10 +8,12 @@ /// REVIEW: review if we should just switch to System.Diagnostics module internal Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open System.IO open Microsoft.FSharp.Core.Printf +#if !FABLE_COMPILER +open System.IO 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 4426160638..ef68e75ef9 100755 --- a/src/absil/illib.fs +++ b/src/absil/illib.fs @@ -4,6 +4,13 @@ module public Microsoft.FSharp.Compiler.AbstractIL.Internal.Library #nowarn "1178" // The struct, record or union type 'internal_instr_extension' is not structurally comparable because the type +#if FABLE_COMPILER +open Internal.Utilities +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.Operators +open Microsoft.FSharp.Control +#endif open System open System.Collections.Generic open System.Diagnostics @@ -45,6 +52,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 //--------------------------------------------------------------------- @@ -58,13 +66,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 @@ -76,6 +90,7 @@ type InlineDelayInit<'T when 'T : not struct> = let res = LazyInitializer.EnsureInitialized(&x.store, x.func) x.func <- Unchecked.defaultof<_> res +#endif //------------------------------------------------------------------------- // Library: projections @@ -305,7 +320,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 +487,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 @@ -531,7 +552,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 @@ -560,20 +581,21 @@ 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 +#if !FABLE_COMPILER let getLines (str: string) = use reader = new StringReader(str) [| @@ -586,6 +608,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 +665,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 +776,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 @@ -847,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 /// @@ -881,6 +911,7 @@ module Eventually = return! loop r } loop e +#endif let rec bind k e = match e with @@ -965,6 +996,10 @@ type MemoizationTable<'T,'U>(compute: 'T -> 'U, keyComparer: IEqualityComparer<' let table = new Dictionary<'T,'U>(keyComparer) member t.Apply(x) = if (match canMemoize with None -> true | Some f -> f x) then +#if FABLE_COMPILER // no byref + ( + let ok, res = table.TryGetValue(x) +#else let mutable res = Unchecked.defaultof<'U> let ok = table.TryGetValue(x,&res) if ok then res @@ -972,6 +1007,7 @@ type MemoizationTable<'T,'U>(compute: 'T -> 'U, keyComparer: IEqualityComparer<' lock table (fun () -> let mutable res = Unchecked.defaultof<'U> let ok = table.TryGetValue(x,&res) +#endif if ok then res else let res = compute x @@ -1013,12 +1049,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 @@ -1049,11 +1089,11 @@ module Tables = let memoize f = let t = new Dictionary<_,_>(1000, HashIdentity.Structural) fun x -> - let mutable res = Unchecked.defaultof<_> - if t.TryGetValue(x, &res) then + let ok, res = t.TryGetValue(x) + if ok then res else - res <- f x; t.[x] <- res; res + let res = f x in t.[x] <- res; res /// Interface that defines methods for comparing objects using partial equality relation @@ -1220,6 +1260,7 @@ module Shim = type IFileSystem = +#if !FABLE_COMPILER /// A shim over File.ReadAllBytes abstract ReadAllBytesShim: fileName:string -> byte[] @@ -1231,6 +1272,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) @@ -1243,6 +1285,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 @@ -1263,11 +1306,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 @@ -1281,6 +1326,7 @@ module Shim = member __.FileStreamCreateShim (fileName: string) = new FileStream(fileName,FileMode.Create,FileAccess.Write,FileShare.Read ,0x1000,false) :> Stream member __.FileStreamWriteExistingShim (fileName: string) = new FileStream(fileName,FileMode.Open,FileAccess.Write,FileShare.Read ,0x1000,false) :> Stream +#endif member __.GetFullPathShim (fileName: string) = System.IO.Path.GetFullPath fileName @@ -1301,6 +1347,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 @@ -1316,9 +1363,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) = use stream = FileSystem.FileStreamReadShim fileName @@ -1329,3 +1379,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 c2c10e9479..003242cea3 100755 --- a/src/absil/ilread.fs +++ b/src/absil/ilread.fs @@ -9,14 +9,15 @@ module Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader #nowarn "42" // This construct is deprecated: it is only for use in the F# library +open Internal.Utilities +open Internal.Utilities.Collections open System open System.Collections.Generic open System.Diagnostics open System.IO open System.Runtime.InteropServices open System.Text -open Internal.Utilities -open Internal.Utilities.Collections +open Microsoft.FSharp.Collections open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal #if !FX_NO_PDB_READER @@ -34,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) @@ -138,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() @@ -305,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() @@ -344,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. @@ -383,6 +397,8 @@ 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 @@ -902,8 +918,12 @@ let mkCacheInt32 lowMem _inbase _nm _sz = | null -> cache := new Dictionary(11) | _ -> () !cache +#if FABLE_COMPILER + let ok, res = cache.TryGetValue(idx) +#else let mutable res = Unchecked.defaultof<_> let ok = cache.TryGetValue(idx, &res) +#endif if ok then incr count res @@ -1141,6 +1161,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 @@ -1157,6 +1202,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 @@ -1188,7 +1235,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 @@ -1198,7 +1245,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 @@ -1209,7 +1256,7 @@ let seekReadTypeDefRow (ctxt: ILMetadataReader) idx = ctxt.seekReadTypeDefRow i 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 @@ -1220,7 +1267,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 @@ -1228,7 +1275,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 @@ -1239,7 +1286,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 @@ -1247,14 +1294,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 @@ -1265,7 +1312,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 @@ -1274,7 +1321,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 @@ -1282,14 +1329,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 @@ -1297,7 +1344,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 @@ -1305,27 +1352,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 @@ -1333,14 +1380,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 @@ -1351,7 +1398,7 @@ let seekReadMethodSemanticsRow (ctxt: ILMetadataReader) idx = ctxt.seekReadMeth 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 @@ -1359,7 +1406,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 @@ -1367,19 +1414,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 @@ -1388,14 +1435,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 @@ -1409,7 +1456,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 @@ -1423,7 +1470,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 @@ -1431,7 +1478,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 @@ -1441,7 +1488,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 @@ -1453,14 +1500,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 @@ -1469,19 +1516,18 @@ 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) - let readUserStringHeapUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() @@ -1802,7 +1848,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, @@ -1994,7 +2040,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)))), @@ -2394,7 +2440,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, @@ -2480,7 +2526,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)), @@ -2523,7 +2569,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, @@ -3237,11 +3283,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 @@ -3962,6 +4012,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 ILModuleReaderCacheLockToken() = interface LockToken type ILModuleReaderCacheKey = ILModuleReaderCacheKey of string * DateTime * ILScopeRef * bool * ReduceMemoryFlag * MetadataOnlyFlag @@ -4111,3 +4170,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 c548447444..0e23e51449 100755 --- a/src/absil/ilread.fsi +++ b/src/absil/ilread.fsi @@ -74,11 +74,12 @@ 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. /// PDB files may not be read with this option. val internal OpenILModuleReader: string -> ILReaderOptions -> ILModuleReader +#endif /// Open a binary reader based on the given bytes. val internal OpenILModuleReaderFromBytes: fileNameForDebugOutput:string -> assemblyContents: byte[] -> options: ILReaderOptions -> ILModuleReader @@ -92,6 +93,8 @@ type Statistics = val GetStatistics : unit -> Statistics +#if !FABLE_COMPILER + [] module Shim = @@ -103,3 +106,5 @@ module Shim = interface IAssemblyReader val mutable AssemblyReader: IAssemblyReader + +#endif diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs index 12541d5089..b41e3e83ee 100755 --- a/src/absil/ilwrite.fs +++ b/src/absil/ilwrite.fs @@ -458,8 +458,12 @@ type MetadataTable<'T> = #if DEBUG tbl.lookups <- tbl.lookups + 1 #endif +#if FABLE_COMPILER + let ok, res = tbl.dict.TryGetValue(x) +#else let mutable res = Unchecked.defaultof<_> let ok = tbl.dict.TryGetValue(x, &res) +#endif if ok then res else tbl.AddSharedEntry x @@ -763,11 +767,17 @@ let rec GetTypeRefAsTypeRefRow cenv (tref:ILTypeRef) = SharedRow [| ResolutionScope (rs1, rs2); nelem; nselem |] and GetTypeRefAsTypeRefIdx cenv tref = +#if FABLE_COMPILER + let ok, res = cenv.trefCache.TryGetValue(tref) +#else let mutable res = 0 - if cenv.trefCache.TryGetValue(tref, &res) then res else - let res = FindOrAddSharedRow cenv TableNames.TypeRef (GetTypeRefAsTypeRefRow cenv tref) - cenv.trefCache.[tref] <- res - res + let ok = cenv.trefCache.TryGetValue(tref, &res) +#endif + if ok then res + else + let res = FindOrAddSharedRow cenv TableNames.TypeRef (GetTypeRefAsTypeRefRow cenv tref) + cenv.trefCache.[tref] <- res + res and GetTypeDescAsTypeRefIdx cenv (scoref, enc, n) = GetTypeRefAsTypeRefIdx cenv (mkILNestedTyRef (scoref, enc, n)) diff --git a/src/fsharp/CheckFormatStrings.fs b/src/fsharp/CheckFormatStrings.fs index 9d7fd72d7a..abf5e1fc0c 100755 --- a/src/fsharp/CheckFormatStrings.fs +++ b/src/fsharp/CheckFormatStrings.fs @@ -2,6 +2,9 @@ module internal Microsoft.FSharp.Compiler.CheckFormatStrings +#if FABLE_COMPILER +open Internal.Utilities +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.Ast diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 830a08bf2f..c7aa1539b8 100755 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -3,13 +3,18 @@ /// Coordinating compiler operations - configuration, loading initial context, reporting errors etc. module internal Microsoft.FSharp.Compiler.CompileOps +open Internal.Utilities open System open System.Collections.Generic open System.Diagnostics open System.IO open System.Text -open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.Operators +#endif open Internal.Utilities.Collections open Internal.Utilities.Filename open Internal.Utilities.Text @@ -227,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 @@ -356,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 @@ -426,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) @@ -436,7 +447,9 @@ let SplitRelatedDiagnostics(err:PhasedDiagnostic) = let DeclareMesssage = Microsoft.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") @@ -601,6 +614,18 @@ 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 + 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) = let rec OutputExceptionR (os:StringBuilder) error = @@ -1329,7 +1354,7 @@ let OutputPhasedErrorR (os:StringBuilder) (err:PhasedDiagnostic) = 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 @@ -1556,6 +1581,7 @@ let OutputPhasedErrorR (os:StringBuilder) (err:PhasedDiagnostic) = | 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 @@ -1571,7 +1597,7 @@ let OutputPhasedErrorR (os:StringBuilder) (err:PhasedDiagnostic) = | :? 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 @@ -1585,14 +1611,14 @@ let OutputPhasedErrorR (os:StringBuilder) (err:PhasedDiagnostic) = // remove any newlines and tabs let OutputPhasedDiagnostic (os:System.Text.StringBuilder) (err:PhasedDiagnostic) (flattenErrors:bool) = - let buf = new System.Text.StringBuilder() + let buf = new StringBuilder() OutputPhasedErrorR buf err 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. @@ -1612,6 +1638,8 @@ let SanitizeFileName fileName implicitIncludeDir = with _ -> fileName +#if !FABLE_COMPILER + [] type DiagnosticLocation = { Range : range @@ -2026,6 +2054,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 ... @@ -2067,6 +2097,7 @@ type ResolveAssemblyReferenceMode = Speculative | ReportErrors [] type CopyFSharpCoreFlag = Yes | No +#if !FABLE_COMPILER /// Represents the file or string used for the --version flag type VersionFlag = | VersionString of string @@ -2090,6 +2121,7 @@ type VersionFlag = 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. @@ -2122,10 +2154,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 @@ -2198,6 +2232,8 @@ type AvailableImportedAssembly = | ResolvedImportedAssembly of ImportedAssembly | UnresolvedImportedAssembly of string +#if !FABLE_COMPILER + type CcuLoadFailureAction = | RaiseError | ReturnNone @@ -3300,6 +3336,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)) @@ -3591,6 +3628,8 @@ let ParseInput (lexer, errorLogger:ErrorLogger, lexbuf:UnicodeLexing.Lexbuf, def 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. @@ -3765,6 +3804,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 @@ -3792,6 +3832,8 @@ let GetOptimizationDataResourceName (r: ILResource) = String.dropPrefix r.Name FSharpOptimizationDataResourceName2 else failwith "GetOptimizationDataResourceName" +#if !FABLE_COMPILER + let IsReflectedDefinitionsResource (r: ILResource) = r.Name.StartsWithOrdinal(QuotationPickler.SerializedReflectedDefinitionsResourceNameBase) @@ -5345,6 +5387,89 @@ let CheckSimulateException(tcConfig:TcConfig) = | Some("tc-fail") -> failwith "simulated" | _ -> () +#endif //!FABLE_COMPILERFABLE_COMPILER + +#if FABLE_COMPILER + +type AssemblyResolution = + { originalReference : AssemblyReference + resolvedPath : string + prepareToolTip : unit -> string + sysdir : bool + ilAssemblyRef : ILAssemblyRef option ref + } + +// cut-down version of LoadClosure +type LoadClosure = + { + SourceFiles: (string * range list) list + References: (string * AssemblyResolution list) list + } + +// cut-down version of TcConfig +type TcConfig (optimize: bool, defines: string list) = + member x.primaryAssembly = PrimaryAssembly.NetStandard + member x.implicitIncludeDir = "" + member x.compilingFslib = false + member x.isInteractive = false + member x.mlCompatibility = false + member x.noDebugData = false + member x.conditionalCompilationDefines = defines + member x.emitDebugInfoInQuotations = false + member x.errorSeverityOptions = FSharpErrorSeverityOptions.Default + member x.light = Some true + member x.target = CompilerTarget.WinExe + member x.extraOptimizationIterations = if optimize then 0 else 0 +#if DEBUG + member x.showOptimizationData = false +#endif + member x.doDetuple = optimize + member x.doTLR = optimize + member x.doFinalSimplify = optimize + member x.optSettings = { Optimizer.OptimizationSettings.Defaults with + jitOptUser = Some optimize + localOptUser = Some optimize + crossModuleOptUser = Some optimize + lambdaInlineThreshold = if optimize then 6 else 0 } + member x.emitTailcalls = true + member x.internalTestSpanStackReferring = false + member x.noConditionalErasure = false + +// cut-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 (_, assemblyName) = + match ccuMap |> Map.tryFind assemblyName with + | Some ccuInfo -> ResolvedCcu(ccuInfo.FSharpViewOfMetadata) + | None -> UnresolvedCcu(assemblyName) + + member x.FindCcu (_, 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-check sets of files //-------------------------------------------------------------------------- @@ -5437,7 +5562,9 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc 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() diff --git a/src/fsharp/CompileOps.fsi b/src/fsharp/CompileOps.fsi index 9ee74ee993..521024f287 100755 --- a/src/fsharp/CompileOps.fsi +++ b/src/fsharp/CompileOps.fsi @@ -3,6 +3,7 @@ /// Coordinating compiler operations - configuration, loading initial context, reporting errors etc. module internal Microsoft.FSharp.Compiler.CompileOps +open Internal.Utilities open System open System.Text open System.Collections.Generic diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index 344c0e1412..238d575d09 100755 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -28,6 +28,8 @@ open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Lexhelp open Microsoft.FSharp.Compiler.IlxGen +#if !FABLE_COMPILER + #if FX_RESHAPED_REFLECTION open Microsoft.FSharp.Core.ReflectionAdapters #endif @@ -840,7 +842,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 @@ -1231,6 +1235,8 @@ let ReportTime (tcConfig:TcConfig) descr = nPrev := Some descr +#endif //!FABLE_COMPILER + //---------------------------------------------------------------------------- // OPTIMIZATION - support - addDllToOptEnv //---------------------------------------------------------------------------- @@ -1256,14 +1262,21 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM // 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 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 implFiles))) if tcConfig.showOptimizationData then dprintf "CCU prior to optimization:\n%s\n" (Layout.showL (Layout.squashTo 192 (DebugPrint.entityL ccu.Contents))) #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 @@ -1324,11 +1337,13 @@ 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 tcConfig outfile "pass-end" (List.map fst implFiles) ReportTime tcConfig ("Ending Optimizations") - +#endif tassembly, assemblyOptData, optEnvFirstLoop +#if !FABLE_COMPILER //---------------------------------------------------------------------------- // ILX generation @@ -1408,3 +1423,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/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 230474a2e8..17918c6535 100755 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -33,6 +33,10 @@ module internal Microsoft.FSharp.Compiler.ConstraintSolver open Internal.Utilities.Collections +#if FABLE_COMPILER +open Internal.Utilities +open Microsoft.FSharp.Collections +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL @@ -2016,7 +2020,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 @@ -2038,7 +2042,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/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index 9a7f99e63a..92f5574749 100755 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -2,6 +2,10 @@ module internal Microsoft.FSharp.Compiler.Detuple +open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs index 41be3768ed..0eeefd3145 100755 --- a/src/fsharp/ErrorLogger.fs +++ b/src/fsharp/ErrorLogger.fs @@ -2,6 +2,10 @@ module public Microsoft.FSharp.Compiler.ErrorLogger +open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range open System @@ -129,17 +133,20 @@ let rec AttachRange m (exn:exn) = else match exn with // Strip TargetInvocationException wrappers - | :? System.Reflection.TargetInvocationException -> AttachRange m exn.InnerException | 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 +160,7 @@ let QuitProcessExiter = () FSComp.SR.elSysEnvExitDidntExit() |> failwith } +#endif /// Closed enumeration of build phases. [] @@ -332,6 +340,10 @@ module ErrorLoggerExtensions = /// Instruct the exception not to reset itself when thrown again. let PreserveStackTrace(exn) = +#if FABLE_COMPILER + ignore exn + () +#else try let preserveStackTrace = typeof.GetMethod("InternalPreserveStackTrace", BindingFlags.Instance ||| BindingFlags.NonPublic) preserveStackTrace.Invoke(exn, null) |> ignore @@ -339,7 +351,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) = @@ -363,11 +375,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 _ -> @@ -645,7 +658,7 @@ let NormalizeErrorString (text : string) = | c -> // handle remaining chars: control - replace with space, others - keep unchanged let c = if Char.IsControl(c) then ' ' else c - buf.Append(c) |> ignore + buf.Append(string c) |> ignore 1 i <- i + delta buf.ToString() diff --git a/src/fsharp/ExtensionTyping.fs b/src/fsharp/ExtensionTyping.fs index 0d86ca58a0..6ccfe0285b 100755 --- a/src/fsharp/ExtensionTyping.fs +++ b/src/fsharp/ExtensionTyping.fs @@ -340,16 +340,16 @@ module internal ExtensionTyping = match ctxt with | NoEntries -> None | Entries(d, _) -> - let mutable res = Unchecked.defaultof<_> - if d.TryGetValue(st, &res) then Some res else None + let ok, res = d.TryGetValue(st) + if ok then Some res else None member ctxt.TryGetTyconRef(st) = match ctxt with | NoEntries -> None | Entries(_, d) -> let d = d.Force() - let mutable res = Unchecked.defaultof<_> - if d.TryGetValue(st, &res) then Some res else None + let ok, res = d.TryGetValue(st) + if ok then Some res else None member ctxt.RemapTyconRefs (f:obj->obj) = match ctxt with diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index cb5747f3c5..2740c6ac22 100755 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -1404,7 +1404,7 @@ keywordDescriptionTo,"Used in for loops to indicate a range." keywordDescriptionTry,"Used to introduce a block of code that might generate an exception. Used together with with or finally." keywordDescriptionType,"Used to declare a class, record, structure, discriminated union, enumeration type, unit of measure, or type abbreviation." keywordDescriptionUpcast,"Used to convert to a type that is higher in the inheritance chain." -keywordDescriptionUse,"Used instead of let for values that implement IDisposable"" +keywordDescriptionUse,"Used instead of let for values that implement IDisposable" keywordDescriptionUseBang,"Used instead of let! in computation expressions for computation expression results that implement IDisposable." keywordDescriptionVal,"Used in a signature to indicate a value, or in a type to declare a member, in limited situations." keywordDescriptionVoid,"Indicates the .NET void type. Used when interoperating with other .NET languages." diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index d027afabeb..4576e7222d 100755 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -124,7 +124,11 @@ let ReportStatistics (oc:TextWriter) = reports oc 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" @@ -710,6 +714,7 @@ let AddSignatureRemapInfo _msg (rpi, mhi) eenv = // Print eenv //-------------------------------------------------------------------------- +#if !FABLE_COMPILER let OutputStorage (pps: TextWriter) s = match s with | StaticField _ -> pps.Write "(top)" @@ -719,6 +724,7 @@ let OutputStorage (pps: TextWriter) s = | Arg _ -> pps.Write "(arg)" | Env _ -> pps.Write "(env)" | Null -> pps.Write "(null)" +#endif //-------------------------------------------------------------------------- // Augment eenv with values @@ -1056,9 +1062,12 @@ 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 = match o1,o2 with | Some x, None | None, Some x -> Some x @@ -1236,7 +1245,7 @@ type AssemblyBuilder(cenv:cenv, anonTypeTable: AnonTypeGenerationTable) as mgbuf 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 )), @@ -3922,7 +3931,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, @@ -3976,7 +3985,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, @@ -4915,7 +4924,7 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec,rhsExpr,_)) sta 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, @@ -4987,7 +4996,7 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec,rhsExpr,_)) sta |> 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, @@ -5243,7 +5252,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), @@ -5260,7 +5269,7 @@ and GenEventForProperty cenv eenvForMeth (mspec:ILMethodSpec) (v:Val) ilAttrsTha 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, @@ -6600,8 +6609,8 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let literalValue = Option.map (GenFieldInit m) fspec.LiteralValue let fdef = - ILFieldDef(name = ilFieldName, - fieldType = ilPropType, + ILFieldDef.Create(name = ilFieldName, + fieldType = ilPropType, attributes = enum 0, data = None, literalValue = None, @@ -6628,7 +6637,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let ilHasSetter = isCLIMutable || isFSharpMutable let ilFieldAttrs = GenAttrs cenv eenv propAttribs @ [mkCompilationMappingAttrWithSeqNum cenv.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)), @@ -6918,7 +6927,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, @@ -6996,7 +7005,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)), @@ -7222,6 +7231,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 = @@ -7302,6 +7313,7 @@ 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) = @@ -7335,10 +7347,12 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal : Constra optimizeDuringCodeGen = (fun x -> x) } 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 6d50da1bfd..d7ecee47ce 100755 --- 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/InfoReader.fs b/src/fsharp/InfoReader.fs index e04485887e..851cc4a114 100644 --- a/src/fsharp/InfoReader.fs +++ b/src/fsharp/InfoReader.fs @@ -4,8 +4,12 @@ /// Select members from a type by name, searching the type hierarchy if needed module internal Microsoft.FSharp.Compiler.InfoReader +open Internal.Utilities open System.Collections.Generic - +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index c783c1efe1..563d393fd4 100755 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -2,6 +2,10 @@ module internal Microsoft.FSharp.Compiler.InnerLambdasToTopLevelFuncs +open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library diff --git a/src/fsharp/InternalCollections.fs b/src/fsharp/InternalCollections.fs index 8713eef00f..58d6e4ec57 100755 --- a/src/fsharp/InternalCollections.fs +++ b/src/fsharp/InternalCollections.fs @@ -1,6 +1,10 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. namespace Internal.Utilities.Collections +#if FABLE_COMPILER +open Internal.Utilities +open Microsoft.FSharp.Collections +#endif open System open System.Collections.Generic @@ -109,6 +113,7 @@ type internal AgedLookup<'Token, 'Key, 'Value when 'Value : not struct>(keepStro refs <- newdata discard1 |> List.iter (snd >> strongDiscard) discard2 |> List.iter (snd >> snd >> strongDiscard) + member al.TryPeekKeyValue(tok, key) = // Returns the original key value as well since it may be different depending on equality test. diff --git a/src/fsharp/LegacyHostedCompilerForTesting.fs b/src/fsharp/LegacyHostedCompilerForTesting.fs index 1f8e258e07..2b0d176f4e 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 c67aa06cb4..7483c1b14b 100755 --- a/src/fsharp/LexFilter.fs +++ b/src/fsharp/LexFilter.fs @@ -4,6 +4,10 @@ /// Implements the offside rule and a copule of other lexical transformations. module internal Microsoft.FSharp.Compiler.LexFilter +#if FABLE_COMPILER +open Internal.Utilities +open Microsoft.FSharp.Core +#endif open Internal.Utilities.Text.Lexing open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL @@ -409,13 +413,19 @@ type PositionTuple = new (x: Position, y: Position) = { X = x; Y = y } /// Used to save the state related to a token +#if FABLE_COMPILER +type TokenTup (token,state,lastTokenPos) = + member x.Token : token = token + member x.LexbufState : LexbufState = state + member x.LastTokenPos: PositionTuple = lastTokenPos +#else [] type TokenTup = val Token : token val LexbufState : LexbufState val LastTokenPos: PositionTuple new (token,state,lastTokenPos) = { Token=token; LexbufState=state;LastTokenPos=lastTokenPos } - +#endif /// Returns starting position of the token member x.StartPos = x.LexbufState.StartPos /// Returns end position of the token @@ -569,7 +579,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 @@ -2203,8 +2217,12 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer, | NATIVEINT(v) -> delayMergedToken(NATIVEINT(if plus then v else -v)) | IEEE32(v) -> delayMergedToken(IEEE32(if plus then v else -v)) | IEEE64(v) -> delayMergedToken(IEEE64(if plus then v else -v)) +#if FABLE_COMPILER + | DECIMAL(v) -> delayMergedToken(DECIMAL(if plus then v else -v)) +#else | DECIMAL(v) -> delayMergedToken(DECIMAL(if plus then v else System.Decimal.op_UnaryNegation v)) - | BIGNUM(v,s) -> delayMergedToken(BIGNUM((if plus then v else "-"^v),s)) +#endif + | BIGNUM(v,s) -> delayMergedToken(BIGNUM((if plus then v else "-"+v),s)) | _ -> noMerge() else noMerge() @@ -2249,7 +2267,11 @@ type LexFilter (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer, lexb // 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 7ecfe842f2..4380bb783c 100644 --- a/src/fsharp/Logger.fs +++ b/src/fsharp/Logger.fs @@ -5,6 +5,13 @@ namespace Microsoft.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 de5271eb67..8f4e579d59 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -62,7 +62,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/NameResolution.fs b/src/fsharp/NameResolution.fs index 9434740d31..047cd355e4 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -5,6 +5,11 @@ module internal Microsoft.FSharp.Compiler.NameResolution open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast @@ -1582,8 +1587,17 @@ type TcResultsSinkImpl(g, ?source: string) = // for the same identifier at the same location. if allowedRange m then if replace then +#if FABLE_COMPILER // RemoveAll not supported + let r1 = capturedNameResolutions.FindAll(fun cnr -> cnr.Range <> m) + let r2 = capturedMethodGroupResolutions.FindAll(fun cnr -> cnr.Range <> m) + capturedNameResolutions.Clear() + capturedMethodGroupResolutions.Clear() + capturedNameResolutions.AddRange(r1) + capturedMethodGroupResolutions.AddRange(r2) +#else capturedNameResolutions.RemoveAll(fun cnr -> cnr.Range = m) |> ignore capturedMethodGroupResolutions.RemoveAll(fun cnr -> cnr.Range = m) |> ignore +#endif else let alreadyDone = match item with diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 142ccbae07..90b7c40559 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -6,6 +6,9 @@ module internal Microsoft.FSharp.Compiler.NicePrint +#if FABLE_COMPILER +open Internal.Utilities +#endif open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 5e34582267..c05dbf9d35 100755 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -514,8 +514,7 @@ let GetInfoForLocalValue cenv env (v:Val) m = (* Abstract slots do not have values *) if v.IsDispatchSlot then UnknownValInfo else - let mutable res = Unchecked.defaultof<_> - let ok = cenv.localInternalVals.TryGetValue(v.Stamp, &res) + let ok, res = cenv.localInternalVals.TryGetValue(v.Stamp) if ok then res else match env.localExternalVals.TryFind v.Stamp with | Some vval -> vval diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 625b23a70d..ddf020f77c 100755 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -3,6 +3,10 @@ module internal Microsoft.FSharp.Compiler.PatternMatchCompilation open System.Collections.Generic +open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -1289,7 +1293,7 @@ let CompilePatternBasic // Report unused targets if warnOnUnused then - let used = HashSet<_>(accTargetsOfDecisionTree dtree [],HashIdentity.Structural) + let used = HashSet<_>(accTargetsOfDecisionTree dtree [] |> List.toSeq, HashIdentity.Structural) clausesL |> List.iteri (fun i c -> if not (used.Contains i) then warning (RuleNeverMatched c.Range)) diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index acc3c0c03a..7f0e60f844 100755 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -6,6 +6,10 @@ module internal Microsoft.FSharp.Compiler.PostTypeCheckSemanticChecks open System open System.Collections.Generic +open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.IL diff --git a/src/fsharp/PrettyNaming.fs b/src/fsharp/PrettyNaming.fs index 923be2ccea..d47974cec6 100755 --- a/src/fsharp/PrettyNaming.fs +++ b/src/fsharp/PrettyNaming.fs @@ -6,6 +6,7 @@ /// Anything to do with special names of identifiers and other lexical rules module public Microsoft.FSharp.Compiler.PrettyNaming + open Internal.Utilities open System open System.Collections.Generic open System.Collections.Concurrent @@ -15,7 +16,6 @@ module public Microsoft.FSharp.Compiler.PrettyNaming open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library - open Internal.Utilities open Internal.Utilities.StructuredFormat open Internal.Utilities.StructuredFormat.LayoutOps @@ -180,7 +180,7 @@ module public Microsoft.FSharp.Compiler.PrettyNaming | true, x -> sb.Append(x) |> ignore | false, _ -> - sb.Append(c) |> ignore + sb.Append(string c) |> ignore /// The compiled (mangled) operator name. let opName = sb.ToString () @@ -263,7 +263,7 @@ module public Microsoft.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 (string opChar) |> ignore decompile sb (idx + opCharName.Length) let opNamePrefixLen = opNamePrefix.Length @@ -470,7 +470,11 @@ module public Microsoft.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/QuotationPickler.fs b/src/fsharp/QuotationPickler.fs index 79c2ac2796..2eb46b5eb4 100755 --- a/src/fsharp/QuotationPickler.fs +++ b/src/fsharp/QuotationPickler.fs @@ -2,9 +2,12 @@ module internal Microsoft.FSharp.Compiler.QuotationPickler - -open System.Text +open Internal.Utilities open Internal.Utilities.Collections +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +#endif +open System.Text open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Lib diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index b0f1e7ce4c..3f9d68ca00 100755 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -19,7 +19,11 @@ open System.Collections.Generic module QP = Microsoft.FSharp.Compiler.QuotationPickler +#if FABLE_COMPILER +let verboseCReflect = false +#else let verboseCReflect = condition "VERBOSE_CREFLECT" +#endif [] type IsReflectedDefinition = diff --git a/src/fsharp/SignatureConformance.fs b/src/fsharp/SignatureConformance.fs index ac0c23e970..89a20fb29d 100644 --- a/src/fsharp/SignatureConformance.fs +++ b/src/fsharp/SignatureConformance.fs @@ -4,6 +4,10 @@ /// constraint solving and method overload resolution. module internal Microsoft.FSharp.Compiler.SignatureConformance +#if FABLE_COMPILER +open Internal.Utilities +open Microsoft.FSharp.Core +#endif open System.Text open Microsoft.FSharp.Compiler diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 23242b1aff..1504c58a39 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -5,6 +5,10 @@ module internal Microsoft.FSharp.Compiler.Tastops open System.Collections.Generic open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core.Operators +#endif open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX @@ -1154,6 +1158,7 @@ let primMkMatch(spBind, exprm, tree, targets, matchm, ty) = Expr.Match (spBind, type MatchBuilder(spBind, inpRange: Range.range) = let targets = new ResizeArray<_>(10) + member x.AddTarget(tg) = let n = targets.Count targets.Add tg @@ -3474,8 +3479,8 @@ module DebugPrint = begin | Const.IntPtr x -> (x |> string)+"n" | Const.UIntPtr x -> (x |> string)+"un" | Const.Single d -> - (let s = d.ToString("g12", System.Globalization.CultureInfo.InvariantCulture) - if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s + let s = d.ToString("g12", System.Globalization.CultureInfo.InvariantCulture) + (if String.forall (fun c -> System.Char.IsDigit(c) || c = '-') s then s + ".0" else s) + "f" | Const.Double d -> @@ -4649,7 +4654,7 @@ let underlyingTypeOfEnumTy (g: TcGlobals) ty = let tycon = (tcrefOfAppTy g ty).Deref match tycon.GetFieldByName "value__" with | Some rf -> rf.FormalType - | None -> error(InternalError("no 'value__' field found for enumeration type "^tycon.LogicalName, tycon.Range)) + | None -> error(InternalError("no 'value__' field found for enumeration type "+tycon.LogicalName, tycon.Range)) // CLEANUP NOTE: Get rid of this mutation. @@ -5138,7 +5143,7 @@ and renameTycon tyenv x = let res = tyenv.tyconRefRemap.[mkLocalTyconRef x] res with :? KeyNotFoundException -> - errorR(InternalError("couldn't remap internal tycon "^showL(DebugPrint.tyconL x), x.Range)); + errorR(InternalError("couldn't remap internal tycon "+showL(DebugPrint.tyconL x), x.Range)); mkLocalTyconRef x tcref.Deref @@ -5180,7 +5185,7 @@ and copyAndRemapAndBindTyconsAndVals g compgen tmenv tycons vs = let res = tmenvinner.tyconRefRemap.[mkLocalTyconRef tycon] res with :? KeyNotFoundException -> - errorR(InternalError("couldn't remap internal tycon "^showL(DebugPrint.tyconL tycon), tycon.Range)); + errorR(InternalError("couldn't remap internal tycon "+showL(DebugPrint.tyconL tycon), tycon.Range)); mkLocalTyconRef tycon tcref.Deref @@ -5684,7 +5689,7 @@ let rec simplifyTrivialMatch spBind exprm matchm ty tree (targets : _[]) = if n >= targets.Length then failwith "simplifyTrivialMatch: target out of range"; // REVIEW: should we use _spTarget here? let (TTarget(vs, rhs, _spTarget)) = targets.[n] - if vs.Length <> es.Length then failwith ("simplifyTrivialMatch: invalid argument, n = "^string n^", List.length targets = "^string targets.Length); + if vs.Length <> es.Length then failwith ("simplifyTrivialMatch: invalid argument, n = "+string n+", List.length targets = "+string targets.Length); // These are non-sticky - any sequence point for 'rhs' goes on 'rhs' _after_ the bindings have been made mkInvisibleLetsFromBindings rhs.Range vs es rhs | _ -> @@ -6496,6 +6501,10 @@ let mkCallNewDecimal (g:TcGlobals) m (e1, e2, e3, e4, e5) = mkApps g (t let mkCallNewFormat (g:TcGlobals) m aty bty cty dty ety e1 = mkApps g (typedExprForIntrinsic g m g.new_format_info, [[aty;bty;cty;dty;ety]], [ e1 ], m) +#if FABLE_COMPILER +let TryEliminateDesugaredConstants (_g:TcGlobals) (_m:range) (_c:Const) : Expr option = + None +#else let TryEliminateDesugaredConstants g m c = match c with | Const.Decimal d -> @@ -6507,6 +6516,7 @@ let TryEliminateDesugaredConstants g m c = | _ -> failwith "unreachable" | _ -> None +#endif let mkSeqTy (g:TcGlobals) ty = mkAppTy g.seq_tcr [ty] let mkIEnumeratorTy (g:TcGlobals) ty = mkAppTy g.tcref_System_Collections_Generic_IEnumerator [ty] @@ -6813,7 +6823,7 @@ let AdjustArityOfLambdaBody g arity (vs:Val list) body = if (untupledTys.Length <> arity) then failwith "length untupledTys <> arity"; let dummyvs, dummyes = untupledTys - |> List.mapi (fun i ty -> mkCompGenLocal v.Range (v.LogicalName ^"_"^string i) ty) + |> List.mapi (fun i ty -> mkCompGenLocal v.Range (v.LogicalName + "_" + string i) ty) |> List.unzip // These are non-sticky - any sequence point for 'body' goes on 'body' _after_ the binding has been made let body = mkInvisibleLet v.Range v (mkRefTupled g v.Range dummyes untupledTys) body @@ -7036,7 +7046,7 @@ let AdjustPossibleSubsumptionExpr g (expr: Expr) (suppliedArgs: Expr list) : (Ex argtysl |> List.mapi (fun i argtys -> argtys |> List.mapi (fun j (_, argInfo) -> match argInfo.Name with - | None -> CompilerGeneratedName ("arg" + string i ^string j) + | None -> CompilerGeneratedName ("arg" + string i + string j) | Some id -> id.idText)) | _ -> [] @@ -7166,11 +7176,11 @@ let AdjustPossibleSubsumptionExpr g (expr: Expr) (suppliedArgs: Expr list) : (Ex assert (inpArgTys.Length = actualArgTys.Length) - let inpsAsVars, inpsAsExprs = inpArgTys |> List.mapi (fun j ty -> mkCompGenLocal appm ("arg"^string i^string j) ty) |> List.unzip + let inpsAsVars, inpsAsExprs = inpArgTys |> List.mapi (fun j ty -> mkCompGenLocal appm ("arg"+string i+string j) ty) |> List.unzip let inpsAsActualArg = CoerceDetupled inpArgTys inpsAsExprs actualArgTys let inpCloVarType = (mkFunTy (mkRefTupledTy g actualArgTys) cloVar.Type) let newResTy = mkFunTy inpArgTy resTy - let inpCloVar, inpCloVarAsExpr = mkCompGenLocal appm ("clo"^string i) inpCloVarType + let inpCloVar, inpCloVarAsExpr = mkCompGenLocal appm ("clo"+string i) inpCloVarType let newRes = // For the final arg we can skip introducing the dummy variable if i = N - 1 then @@ -7210,7 +7220,7 @@ let AdjustPossibleSubsumptionExpr g (expr: Expr) (suppliedArgs: Expr list) : (Ex let niceNames = match niceNames with | nms when nms.Length = inpArgTys.Length -> nms - | [nm] -> inpArgTys |> List.mapi (fun i _ -> (nm^string i)) + | [nm] -> inpArgTys |> List.mapi (fun i _ -> (nm + string i)) | nms -> nms match suppliedArg with | Some arg -> diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index 14998cc882..6b015be6a2 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -2,9 +2,13 @@ module internal Microsoft.FSharp.Compiler.TastPickle +open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +open Microsoft.FSharp.Core.Operators +#endif open System.Collections.Generic open System.Text -open Internal.Utilities open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL @@ -71,8 +75,12 @@ type Table<'T> = tbl.rows.Add(x) n member tbl.FindOrAdd x = +#if FABLE_COMPILER + let ok, res = tbl.tbl.TryGetValue(x) +#else let mutable res = Unchecked.defaultof<_> - let ok = tbl.tbl.TryGetValue(x,&res) + let ok = tbl.tbl.TryGetValue(x, &res) +#endif if ok then res else tbl.Add x diff --git a/src/fsharp/TcGlobals.fs b/src/fsharp/TcGlobals.fs index 85f12f8b3f..8a4a15bae3 100755 --- a/src/fsharp/TcGlobals.fs +++ b/src/fsharp/TcGlobals.fs @@ -11,6 +11,10 @@ module internal Microsoft.FSharp.Compiler.TcGlobals open System.Collections.Generic open System.Diagnostics +open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Collections +#endif open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL @@ -23,8 +27,6 @@ open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.PrettyNaming -open Internal.Utilities - let internal DummyFileNameForRangesWithoutASpecificLocation = "startup" let private envRange = rangeN DummyFileNameForRangesWithoutASpecificLocation 0 @@ -870,8 +872,13 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d TType_app (tcref, tinst) else let dict = getDecompileTypeDict() +#if FABLE_COMPILER + let ok, builder = dict.TryGetValue(tcref.Stamp) +#else let mutable builder = Unchecked.defaultof<_> - if dict.TryGetValue(tcref.Stamp, &builder) then builder tinst + let ok = dict.TryGetValue(tcref.Stamp, &builder) +#endif + if ok then builder tinst else TType_app (tcref, tinst) /// For cosmetic purposes "improve" some .NET types, e.g. Int32 --> int32. @@ -880,13 +887,23 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d let improveTy (tcref: EntityRef) tinst = if compilingFslib then let dict = getBetterTypeDict1() +#if FABLE_COMPILER + let ok, builder = dict.TryGetValue(tcref.LogicalName) +#else let mutable builder = Unchecked.defaultof<_> - if dict.TryGetValue(tcref.LogicalName, &builder) then builder tcref tinst + let ok = dict.TryGetValue(tcref.LogicalName, &builder) +#endif + if ok then builder tcref tinst else TType_app (tcref, tinst) else let dict = getBetterTypeDict2() +#if FABLE_COMPILER + let ok, builder = dict.TryGetValue(tcref.Stamp) +#else let mutable builder = Unchecked.defaultof<_> - if dict.TryGetValue(tcref.Stamp, &builder) then builder tinst + let ok = dict.TryGetValue(tcref.Stamp, &builder) +#endif + if ok then builder tinst else TType_app (tcref, tinst) diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index a20b3743ca..b178a97b9b 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -4,11 +4,14 @@ /// with generalization at appropriate points. module internal Microsoft.FSharp.Compiler.TypeChecker +open Internal.Utilities + +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif open System open System.Collections.Generic -open Internal.Utilities - open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -12262,8 +12265,8 @@ module TcRecdUnionAndEnumDeclarations = begin let ValidateFieldNames (synFields : SynField list, tastFields : RecdField list) = let seen = Dictionary() for (sf, f) in List.zip synFields tastFields do - let mutable synField = Unchecked.defaultof<_> - if seen.TryGetValue(f.Name, &synField) then + let ok, synField = seen.TryGetValue(f.Name) + if ok then match sf, synField with | Field(_, _, Some(id), _, _, _, _, _), Field(_, _, Some(_), _, _, _, _, _) -> error(Error(FSComp.SR.tcFieldNameIsUsedModeThanOnce(id.idText), id.idRange)) diff --git a/src/fsharp/UnicodeLexing.fs b/src/fsharp/UnicodeLexing.fs index 26b9f40ad7..53149b3339 100755 --- a/src/fsharp/UnicodeLexing.fs +++ b/src/fsharp/UnicodeLexing.fs @@ -20,6 +20,8 @@ let StringAsLexbuf = let FunctionAsLexbuf = Lexbuf.FromFunction +#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 @@ -67,3 +69,5 @@ let UnicodeFileAsLexbuf (filename,codePage : int option, retryLocked:bool) : Le let source = getSource 0 let lexbuf = LexBuffer<_>.FromString (source) lexbuf + +#endif \ No newline at end of file diff --git a/src/fsharp/UnicodeLexing.fsi b/src/fsharp/UnicodeLexing.fsi index fba8faff4f..d6e9874d97 100755 --- a/src/fsharp/UnicodeLexing.fsi +++ b/src/fsharp/UnicodeLexing.fsi @@ -8,4 +8,7 @@ open Internal.Utilities.Text.Lexing type Lexbuf = LexBuffer val internal StringAsLexbuf : string -> Lexbuf val public FunctionAsLexbuf : (LexBufferChar[] * int * int -> int) -> Lexbuf + +#if !FABLE_COMPILER val public UnicodeFileAsLexbuf :string * int option * (*retryLocked*) bool -> Lexbuf +#endif \ No newline at end of file diff --git a/src/fsharp/ast.fs b/src/fsharp/ast.fs index 22b960d18c..642d819ebb 100644 --- a/src/fsharp/ast.fs +++ b/src/fsharp/ast.fs @@ -2,6 +2,10 @@ module public Microsoft.FSharp.Compiler.Ast +#if FABLE_COMPILER +open Internal.Utilities +open Microsoft.FSharp.Core.Operators +#endif open System.Collections.Generic open Internal.Utilities.Text.Lexing open Internal.Utilities.Text.Parsing diff --git a/src/fsharp/import.fs b/src/fsharp/import.fs index e06ee756da..2cd555d384 100755 --- a/src/fsharp/import.fs +++ b/src/fsharp/import.fs @@ -3,6 +3,10 @@ /// Functions to import .NET binary metadata as TAST objects module internal Microsoft.FSharp.Compiler.Import +open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif open System.Reflection open System.Collections.Concurrent open System.Collections.Generic diff --git a/src/fsharp/layout.fs b/src/fsharp/layout.fs index 2ee543d9b1..8ac92c730d 100755 --- a/src/fsharp/layout.fs +++ b/src/fsharp/layout.fs @@ -4,6 +4,10 @@ module Microsoft.FSharp.Compiler.Layout open System open System.Collections.Generic +#if FABLE_COMPILER +open Internal.Utilities +open Microsoft.FSharp.Core.Operators +#endif open System.IO open Internal.Utilities.StructuredFormat open Microsoft.FSharp.Core.Printf @@ -437,6 +441,7 @@ let taggedTextListR collector = member x.Finish rstrs = NoResult } +#if !FABLE_COMPILER /// channel LayoutRenderer let channelR (chan:TextWriter) = { new LayoutRenderer with @@ -445,6 +450,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 +466,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 a9ced6d9f2..49c773a348 100755 --- a/src/fsharp/layout.fsi +++ b/src/fsharp/layout.fsi @@ -2,6 +2,9 @@ module public Microsoft.FSharp.Compiler.Layout +#if FABLE_COMPILER +open Internal.Utilities +#endif open System.Text open System.Collections.Generic open System.IO @@ -53,7 +56,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 +198,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 bf7477fcc0..aedf01a45a 100755 --- a/src/fsharp/lex.fsl +++ b/src/fsharp/lex.fsl @@ -10,10 +10,10 @@ module internal Microsoft.FSharp.Compiler.Lexer // whitespace etc. //----------------------------------------------------------------------- +open Internal.Utilities open System open System.Globalization open System.Text -open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -48,10 +48,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 @@ -59,10 +59,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"))) @@ -82,18 +83,26 @@ let removeUnderscores (s:string) = let parseInt32 (s:string) = let s = removeUnderscores s let l = s.Length - let mutable p = 0 - let sign = getSign32 s &p l - let specifier = get0OXB s &p l + let p = 0 + let sign, p = getSign32 s p l + let specifier, p = get0OXB s p l #if FX_RESHAPED_GLOBALIZATION match CultureInfo.InvariantCulture.TextInfo.ToLower(specifier) with #else - match Char.ToLower(specifier,CultureInfo.InvariantCulture) with + match Char.ToLowerInvariant(specifier) with +#endif +#if FABLE_COMPILER + | 'x' -> sign * Convert.ToInt32(s.Substring(p), 16) +#else + | 'x' -> sign * (int32 (uint32(UInt64.Parse(s.Substring(p), NumberStyles.AllowHexSpecifier,CultureInfo.InvariantCulture)))) #endif - | 'x' -> sign * (int32 (Convert.ToUInt32(UInt64.Parse(s.Substring(p), NumberStyles.AllowHexSpecifier,CultureInfo.InvariantCulture)))) - | 'b' -> sign * (int32 (Convert.ToUInt32(parseBinaryUInt64 s p l))) - | 'o' -> sign * (int32 (Convert.ToUInt32(parseOctalUInt64 s p l))) + | 'b' -> sign * (int32 (uint32(parseBinaryUInt64 s p l))) + | 'o' -> sign * (int32 (uint32(parseOctalUInt64 s p l))) +#if FABLE_COMPILER + | _ -> Convert.ToInt32(s) +#else | _ -> Int32.Parse(s, NumberStyles.AllowLeadingSign, CultureInfo.InvariantCulture) +#endif let lexemeTrimRightToInt32 args lexbuf n = try parseInt32 (lexemeTrimRight lexbuf n) @@ -351,23 +360,36 @@ rule token args skip = parse { try let s = removeUnderscores (lexemeTrimRight lexbuf 1) // This implements a range check for decimal literals +#if FABLE_COMPILER + let d = Convert.ToDecimal(s) +#else let d = System.Decimal.Parse(s,System.Globalization.NumberStyles.AllowExponent ||| System.Globalization.NumberStyles.Number,System.Globalization.CultureInfo.InvariantCulture) +#endif DECIMAL d with e -> fail args lexbuf (FSComp.SR.lexOusideDecimal()) (DECIMAL (decimal 0)) } | 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 b7603baf15..94b39d0360 100755 --- a/src/fsharp/lexhelp.fs +++ b/src/fsharp/lexhelp.fs @@ -2,14 +2,12 @@ module internal Microsoft.FSharp.Compiler.Lexhelp -open System -open System.Text - open Internal.Utilities open Internal.Utilities.Collections open Internal.Utilities.Text open Internal.Utilities.Text.Lexing - +open System +open System.Text open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -45,12 +43,18 @@ type LightSyntaxStatus(initial:bool,warn:bool) = type LexResourceManager() = let strings = new System.Collections.Generic.Dictionary(1024) member x.InternIdentifierToken(s) = +#if FABLE_COMPILER + let ok, res = strings.TryGetValue(s) +#else let mutable res = Unchecked.defaultof<_> let ok = strings.TryGetValue(s, &res) - if ok then res else - let res = IDENT s - (strings.[s] <- res; res) - +#endif + if ok then res + else + let res = IDENT s + strings.[s] <- res + res + /// Lexer parameters type lexargs = { defines: string list diff --git a/src/fsharp/lexhelp.fsi b/src/fsharp/lexhelp.fsi index 5c534fd7b3..d7b81b2c68 100755 --- a/src/fsharp/lexhelp.fsi +++ b/src/fsharp/lexhelp.fsi @@ -46,13 +46,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 18404ba377..c1d181cd44 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -2,9 +2,12 @@ module internal Microsoft.FSharp.Compiler.Lib +open Internal.Utilities open System.IO open System.Collections.Generic -open Internal.Utilities +#if FABLE_COMPILER +open Microsoft.FSharp.Core +#endif open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -16,6 +19,10 @@ 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 @@ -31,6 +38,7 @@ type SaveAndRestoreConsoleEncoding () = try System.Console.SetOut(savedOut) with _ -> () +#endif //------------------------------------------------------------------------- // Library: bits @@ -322,6 +330,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 @@ -334,6 +343,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 @@ -411,6 +421,7 @@ type Dumper(x:obj) = member self.Dump = sprintf "%A" x #endif +#if !FABLE_COMPILER //--------------------------------------------------------------------------- // AsyncUtil //--------------------------------------------------------------------------- @@ -549,3 +560,5 @@ module UnmanagedProcessExecutionOptions = GetLastError().ToString("X").PadLeft(8,'0') + ".")) #endif + +#endif //!FABLE_COMPILER \ No newline at end of file diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy index 25c8ce10a8..dcc48e7e80 100644 --- a/src/fsharp/pars.fsy +++ b/src/fsharp/pars.fsy @@ -281,7 +281,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 @@ -2845,7 +2845,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 @@ -3557,15 +3557,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) } @@ -3604,7 +3604,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 4e97edc2b3..4d348bb02b 100755 --- a/src/fsharp/range.fs +++ b/src/fsharp/range.fs @@ -3,6 +3,7 @@ /// Anything to do with special names of identifiers and other lexical rules module Microsoft.FSharp.Compiler.Range +open Internal.Utilities open System open System.IO open System.Collections.Concurrent @@ -163,7 +164,11 @@ type FileIndexTable() = idx | _ -> +#if FABLE_COMPILER + ( +#else lock fileToIndexTable (fun () -> +#endif // Get the new index let idx = indexToFileTable.Count @@ -352,8 +357,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/range.fsi b/src/fsharp/range.fsi index d4ef8be800..c9a1fdf1b7 100755 --- a/src/fsharp/range.fsi +++ b/src/fsharp/range.fsi @@ -2,9 +2,9 @@ module public Microsoft.FSharp.Compiler.Range +open Internal.Utilities open System.Text open System.Collections.Generic -open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler diff --git a/src/fsharp/rational.fs b/src/fsharp/rational.fs index 4d72c2b5ad..0b0c609c95 100644 --- a/src/fsharp/rational.fs +++ b/src/fsharp/rational.fs @@ -3,6 +3,9 @@ /// Rational arithmetic, used for exponents on units-of-measure module internal Microsoft.FSharp.Compiler.Rational +#if FABLE_COMPILER +open Internal.Utilities +#endif open System.Numerics type Rational = { diff --git a/src/fsharp/service/IncrementalBuild.fs b/src/fsharp/service/IncrementalBuild.fs index f5d0141b32..020fa33086 100755 --- a/src/fsharp/service/IncrementalBuild.fs +++ b/src/fsharp/service/IncrementalBuild.fs @@ -17,7 +17,9 @@ open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.CompileOps +#if !FABLE_COMPILER open Microsoft.FSharp.Compiler.CompileOptions +#endif open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.TcGlobals @@ -27,6 +29,8 @@ open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.SourceCodeServices open Internal.Utilities.Collections +#if !FABLE_COMPILER + [] module internal IncrementalBuild = @@ -970,6 +974,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 @@ -1886,3 +1905,4 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput member __.IsBeingKeptAliveApartFromCacheEntry = (referenceCount >= 2) +#endif //!FABLE_COMPILER \ No newline at end of file diff --git a/src/fsharp/service/IncrementalBuild.fsi b/src/fsharp/service/IncrementalBuild.fsi index 29c7a03a45..1a28a7d6e3 100755 --- a/src/fsharp/service/IncrementalBuild.fsi +++ b/src/fsharp/service/IncrementalBuild.fsi @@ -14,6 +14,16 @@ open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.Tast open Microsoft.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 @@ -260,3 +270,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/QuickParse.fs b/src/fsharp/service/QuickParse.fs index 9e851fef05..b15879607a 100644 --- a/src/fsharp/service/QuickParse.fs +++ b/src/fsharp/service/QuickParse.fs @@ -2,6 +2,9 @@ namespace Microsoft.FSharp.Compiler +#if FABLE_COMPILER +open Internal.Utilities +#endif open System open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.SourceCodeServices diff --git a/src/fsharp/service/Reactor.fs b/src/fsharp/service/Reactor.fs index d2b8bda7ea..cf09b21685 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. @@ -189,3 +191,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 b4bd46d167..cbae24c7ea 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. /// @@ -51,3 +53,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 663ed82a94..d3c7462707 100644 --- a/src/fsharp/service/ServiceAssemblyContent.fs +++ b/src/fsharp/service/ServiceAssemblyContent.fs @@ -7,6 +7,10 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices +#if FABLE_COMPILER +open Internal.Utilities +open Microsoft.FSharp.Core.Operators +#endif open System open System.Collections.Generic @@ -184,6 +188,7 @@ type IAssemblyContentCache = abstract TryGet: AssemblyPath -> AssemblyContentCacheEntry option abstract Set: AssemblyPath -> AssemblyContentCacheEntry -> unit +#if !FABLE_COMPILER module AssemblyContentProvider = open System.IO @@ -372,6 +377,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 10c9dc4baa..6d488dfe1e 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 22b851a5b8..0011884c25 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, checkAlive) -> // reactor causes the lambda to execute on the background compiler thread, through the Reactor reactor.EnqueueAndAwaitOpAsync (userOpName, "StructuredDescriptionTextAsync", name, fun ctok -> @@ -518,7 +521,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. @@ -539,7 +542,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 @@ -559,7 +564,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, denv, getAccessibility, items: CompletionItem list, reactor, currentNamespaceOrModule: string[] option, isAttributeApplicationContext: bool, checkAlive) = + static member Create(infoReader:InfoReader, m:range, denv, getAccessibility, items: CompletionItem list, reactor:IReactorOperations, currentNamespaceOrModule: string[] option, isAttributeApplicationContext: bool, checkAlive:(unit -> 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 2beee7024f..de73766a90 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 5eda7cb31d..3c1112fdf7 100755 --- a/src/fsharp/service/ServiceLexing.fs +++ b/src/fsharp/service/ServiceLexing.fs @@ -6,6 +6,9 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices +#if FABLE_COMPILER +open Internal.Utilities +#endif open System open System.Collections.Generic open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -517,12 +520,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 62c8892331..13f430351b 100755 --- a/src/fsharp/service/ServiceUntypedParse.fs +++ b/src/fsharp/service/ServiceUntypedParse.fs @@ -7,6 +7,9 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices +#if FABLE_COMPILER +open Internal.Utilities +#endif open System open System.IO open System.Collections.Generic @@ -982,8 +985,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 = @@ -1343,6 +1361,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) @@ -1362,9 +1400,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 7fbc49c1f3..da534c1bbf 100755 --- a/src/fsharp/service/service.fs +++ b/src/fsharp/service/service.fs @@ -1,3394 +1,3444 @@ -// 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 Microsoft.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 Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.AbstractIL -open Microsoft.FSharp.Compiler.AbstractIL.IL -open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open Microsoft.FSharp.Compiler.AbstractIL.Internal -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library - -open Microsoft.FSharp.Compiler.AccessibilityLogic -open Microsoft.FSharp.Compiler.Ast -open Microsoft.FSharp.Compiler.CompileOps -open Microsoft.FSharp.Compiler.CompileOptions -open Microsoft.FSharp.Compiler.Driver -open Microsoft.FSharp.Compiler.ErrorLogger -open Microsoft.FSharp.Compiler.Lib -open Microsoft.FSharp.Compiler.PrettyNaming -open Microsoft.FSharp.Compiler.Parser -open Microsoft.FSharp.Compiler.Range -open Microsoft.FSharp.Compiler.Lexhelp -open Microsoft.FSharp.Compiler.Layout -open Microsoft.FSharp.Compiler.Tast -open Microsoft.FSharp.Compiler.Tastops -open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.Infos -open Microsoft.FSharp.Compiler.InfoReader -open Microsoft.FSharp.Compiler.NameResolution -open Microsoft.FSharp.Compiler.TypeChecker -open Microsoft.FSharp.Compiler.SourceCodeServices.SymbolHelpers - -open Internal.Utilities -open Internal.Utilities.Collections -open Microsoft.FSharp.Compiler.Layout.TaggedTextOps - -#if FX_RESHAPED_REFLECTION -open Microsoft.FSharp.Core.ReflectionAdapters -#endif - -type internal Layout = StructuredFormat.Layout - -[] -module EnvMisc = - let getToolTipTextSize = GetEnvInteger "FCS_GetToolTipTextCacheSize" 5 - let maxTypeCheckErrorsOutOfProjectContext = GetEnvInteger "FCS_MaxErrorsOutOfProjectContext" 3 - let braceMatchCacheSize = GetEnvInteger "FCS_BraceMatchCacheSize" 5 - let parseFileCacheSize = GetEnvInteger "FCS_ParseFileCacheSize" 2 - let checkFileInProjectCacheSize = GetEnvInteger "FCS_CheckFileInProjectCacheSize" 10 - - let projectCacheSizeDefault = GetEnvInteger "FCS_ProjectCacheSizeDefault" 3 - let frameworkTcImportsCacheStrongSize = GetEnvInteger "FCS_frameworkTcImportsCacheStrongSizeDefault" 8 - let maxMBDefault = GetEnvInteger "FCS_MaxMB" 1000000 // a million MB = 1TB = disabled - //let maxMBDefault = GetEnvInteger "FCS_maxMB" (if sizeof = 4 then 1700 else 3400) - - /// Maximum time share for a piece of background work before it should (cooperatively) yield - /// 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 = - match System.Environment.GetEnvironmentVariable("FCS_MaxTimeShare") with - | null | "" -> 100L - | s -> int64 s - - -//---------------------------------------------------------------------------- -// Scopes. -//-------------------------------------------------------------------------- - -[] -type FSharpFindDeclFailureReason = - // generic reason: no particular information about error - | Unknown of message: string - // source code file is not available - | NoSourceCode - // trying to find declaration of ProvidedType without TypeProviderDefinitionLocationAttribute - | ProvidedType of string - // trying to find declaration of ProvidedMember without TypeProviderDefinitionLocationAttribute - | ProvidedMember of string - -[] -type FSharpFindDeclResult = - /// declaration not found + reason - | DeclNotFound of FSharpFindDeclFailureReason - /// found declaration - | DeclFound of range - /// Indicates an external declaration was found - | ExternalDecl of assembly : string * externalSym : ExternalSymbol - -/// This type is used to describe what was found during the name resolution. -/// (Depending on the kind of the items, we may stop processing or continue to find better items) -[] -[] -type internal NameResResult = - | Members of (ItemWithInst list * DisplayEnv * range) - | Cancel of DisplayEnv * range - | Empty - | TypecheckStaleAndTextChanged - - -[] -type ResolveOverloads = -| Yes -| No - -[] -type GetPreciseCompletionListFromExprTypingsResult = - | NoneBecauseTypecheckIsStaleAndTextChanged - | NoneBecauseThereWereTypeErrors - | None - | Some of (ItemWithInst list * DisplayEnv * range) * TType - -type Names = string list - -[] -type SemanticClassificationType = - | ReferenceType - | ValueType - | UnionCase - | Function - | Property - | MutableVar - | Module - | Printf - | ComputationExpression - | IntrinsicFunction - | Enumeration - | Interface - | TypeArgument - | Operator - | Disposable - -/// A TypeCheckInfo represents everything we get back from the typecheck of a file. -/// It acts like an in-memory database about the file. -/// It is effectively immutable and not updated: when we re-typecheck we just drop the previous -/// scope object on the floor and make a new one. -[] -type TypeCheckInfo - (// Information corresponding to miscellaneous command-line options (--define, etc). - _sTcConfig: TcConfig, - g: TcGlobals, - // The signature of the assembly being checked, up to and including the current file - ccuSigForFile: ModuleOrNamespaceType, - thisCcu: CcuThunk, - tcImports: TcImports, - tcAccessRights: AccessorDomain, - projectFileName: string, - mainInputFileName: string, - sResolutions: TcResolutions, - sSymbolUses: TcSymbolUses, - // This is a name resolution environment to use if no better match can be found. - sFallback: NameResolutionEnv, - loadClosure : LoadClosure option, - reactorOps : IReactorOperations, - checkAlive : (unit -> bool), - textSnapshotInfo:obj option, - implFileOpt: TypedImplFile option, - openDeclarations: OpenDeclaration[]) = - - let textSnapshotInfo = defaultArg textSnapshotInfo null - let (|CNR|) (cnr:CapturedNameResolution) = - (cnr.Pos, cnr.Item, cnr.ItemOccurence, cnr.DisplayEnv, cnr.NameResolutionEnv, cnr.AccessorDomain, cnr.Range) - - // These strings are potentially large and the editor may choose to hold them for a while. - // Use this cache to fold together data tip text results that are the same. - // Is not keyed on 'Names' collection because this is invariant for the current position in - // this unchanged file. Keyed on lineStr though to prevent a change to the currently line - // being available against a stale scope. - let getToolTipTextCache = AgedLookup>(getToolTipTextSize,areSimilar=(fun (x,y) -> x = y)) - - let amap = tcImports.GetImportMap() - let infoReader = new InfoReader(g,amap) - let ncenv = new NameResolver(g,amap,infoReader,NameResolution.FakeInstantiationGenerator) - let cenv = SymbolEnv(g, thisCcu, Some ccuSigForFile, tcImports, amap, infoReader) - - /// Find the most precise naming environment for the given line and column - let GetBestEnvForPos cursorPos = - - let mutable bestSoFar = None - - // Find the most deeply nested enclosing scope that contains given position - sResolutions.CapturedEnvs |> ResizeArray.iter (fun (possm,env,ad) -> - if rangeContainsPos possm cursorPos then - match bestSoFar with - | Some (bestm,_,_) -> - if rangeContainsRange bestm possm then - bestSoFar <- Some (possm,env,ad) - | None -> - bestSoFar <- Some (possm,env,ad)) - - let mostDeeplyNestedEnclosingScope = bestSoFar - - // Look for better subtrees on the r.h.s. of the subtree to the left of where we are - // Should really go all the way down the r.h.s. of the subtree to the left of where we are - // This is all needed when the index is floating free in the area just after the environment we really want to capture - // We guarantee to only refine to a more nested environment. It may not be strictly - // the right environment, but will always be at least as rich - - let bestAlmostIncludedSoFar = ref None - - sResolutions.CapturedEnvs |> ResizeArray.iter (fun (possm,env,ad) -> - // take only ranges that strictly do not include cursorPos (all ranges that touch cursorPos were processed during 'Strict Inclusion' part) - if rangeBeforePos possm cursorPos && not (posEq possm.End cursorPos) then - let contained = - match mostDeeplyNestedEnclosingScope with - | Some (bestm,_,_) -> rangeContainsRange bestm possm - | None -> true - - if contained then - match !bestAlmostIncludedSoFar with - | Some (rightm:range,_,_) -> - if posGt possm.End rightm.End || - (posEq possm.End rightm.End && posGt possm.Start rightm.Start) then - bestAlmostIncludedSoFar := Some (possm,env,ad) - | _ -> bestAlmostIncludedSoFar := Some (possm,env,ad)) - - let resEnv = - match !bestAlmostIncludedSoFar, mostDeeplyNestedEnclosingScope with - | Some (_,env,ad), None -> env, ad - | Some (_,almostIncludedEnv,ad), Some (_,mostDeeplyNestedEnv,_) - when almostIncludedEnv.eFieldLabels.Count >= mostDeeplyNestedEnv.eFieldLabels.Count -> - almostIncludedEnv,ad - | _ -> - match mostDeeplyNestedEnclosingScope with - | Some (_,env,ad) -> - env,ad - | None -> - sFallback,AccessibleFromSomeFSharpCode - let pm = mkRange mainInputFileName cursorPos cursorPos - - resEnv,pm - - /// The items that come back from ResolveCompletionsInType are a bit - /// noisy. Filter a few things out. - /// - /// e.g. prefer types to constructors for FSharpToolTipText - let FilterItemsForCtors filterCtors (items: ItemWithInst list) = - let items = items |> List.filter (fun item -> match item.Item with (Item.CtorGroup _) when filterCtors = ResolveTypeNamesToTypeRefs -> false | _ -> true) - items - - // Filter items to show only valid & return Some if there are any - let ReturnItemsOfType (items: ItemWithInst list) g denv (m:range) filterCtors hasTextChangedSinceLastTypecheck = - let items = - items - |> RemoveDuplicateItems g - |> RemoveExplicitlySuppressed g - |> FilterItemsForCtors filterCtors - - if not (isNil items) then - if hasTextChangedSinceLastTypecheck(textSnapshotInfo, m) then - NameResResult.TypecheckStaleAndTextChanged // typecheck is stale, wait for second-chance IntelliSense to bring up right result - else - NameResResult.Members (items, denv, m) - else NameResResult.Empty - - let GetCapturedNameResolutions endOfNamesPos resolveOverloads = - - let quals = - match resolveOverloads with - | ResolveOverloads.Yes -> sResolutions.CapturedNameResolutions - | ResolveOverloads.No -> sResolutions.CapturedMethodGroupResolutions - - let quals = quals |> ResizeArray.filter (fun cnr -> posEq cnr.Pos endOfNamesPos) - - quals - - /// Looks at the exact name resolutions that occurred during type checking - /// If 'membersByResidue' is specified, we look for members of the item obtained - /// from the name resolution and filter them by the specified residue (?) - let GetPreciseItemsFromNameResolution(line, colAtEndOfNames, membersByResidue, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck) = - let endOfNamesPos = mkPos line colAtEndOfNames - - // Logic below expects the list to be in reverse order of resolution - let cnrs = GetCapturedNameResolutions endOfNamesPos resolveOverloads |> ResizeArray.toList |> List.rev - - match cnrs, membersByResidue with - - // If we're looking for members using a residue, we'd expect only - // a single item (pick the first one) and we need the residue (which may be "") - | CNR(_,Item.Types(_,(ty::_)), _, denv, nenv, ad, m)::_, Some _ -> - let items = ResolveCompletionsInType ncenv nenv (ResolveCompletionTargets.All(ConstraintSolver.IsApplicableMethApprox g amap m)) m ad true ty - let items = List.map ItemWithNoInst items - ReturnItemsOfType items g denv m filterCtors hasTextChangedSinceLastTypecheck - - // Value reference from the name resolution. Primarily to disallow "let x.$ = 1" - // In most of the cases, value references can be obtained from expression typings or from environment, - // so we wouldn't have to handle values here. However, if we have something like: - // let varA = "string" - // let varA = if b then 0 else varA. - // then the expression typings get confused (thinking 'varA:int'), so we use name resolution even for usual values. - - | CNR(_, Item.Value(vref), occurence, denv, nenv, ad, m)::_, Some _ -> - if (occurence = ItemOccurence.Binding || occurence = ItemOccurence.Pattern) then - // Return empty list to stop further lookup - for value declarations - NameResResult.Cancel(denv, m) - else - // If we have any valid items for the value, then return completions for its type now. - // Adjust the type in case this is the 'this' pointer stored in a reference cell. - let ty = StripSelfRefCell(g, vref.BaseOrThisInfo, vref.TauType) - // patch accessibility domain to remove protected members if accessing NormalVal - let ad = - match vref.BaseOrThisInfo, ad with - | ValBaseOrThisInfo.NormalVal, AccessibleFrom(paths, Some tcref) -> - let tcref = generalizedTyconRef tcref - // check that type of value is the same or subtype of tcref - // yes - allow access to protected members - // no - strip ability to access protected members - if Microsoft.FSharp.Compiler.TypeRelations.TypeFeasiblySubsumesType 0 g amap m tcref Microsoft.FSharp.Compiler.TypeRelations.CanCoerce ty then - ad - else - AccessibleFrom(paths, None) - | _ -> ad - - let items = ResolveCompletionsInType ncenv nenv (ResolveCompletionTargets.All(ConstraintSolver.IsApplicableMethApprox g amap m)) m ad false ty - let items = List.map ItemWithNoInst items - ReturnItemsOfType items g denv m filterCtors hasTextChangedSinceLastTypecheck - - // No residue, so the items are the full resolution of the name - | CNR(_, _, _, denv, _, _, m) :: _, None -> - let items = - cnrs - |> List.map (fun cnr -> cnr.ItemWithInst) - // "into" is special magic syntax, not an identifier or a library call. It is part of capturedNameResolutions as an - // implementation detail of syntax coloring, but we should not report name resolution results for it, to prevent spurious QuickInfo. - |> List.filter (fun item -> match item.Item with Item.CustomOperation(CustomOperations.Into,_,_) -> false | _ -> true) - ReturnItemsOfType items g denv m filterCtors hasTextChangedSinceLastTypecheck - | _, _ -> NameResResult.Empty - - let TryGetTypeFromNameResolution(line, colAtEndOfNames, membersByResidue, resolveOverloads) = - let endOfNamesPos = mkPos line colAtEndOfNames - let items = GetCapturedNameResolutions endOfNamesPos resolveOverloads |> ResizeArray.toList |> List.rev - - match items, membersByResidue with - | CNR(_,Item.Types(_,(ty::_)),_,_,_,_,_)::_, Some _ -> Some ty - | CNR(_, Item.Value(vref), occurence,_,_,_,_)::_, Some _ -> - if (occurence = ItemOccurence.Binding || occurence = ItemOccurence.Pattern) then None - else Some (StripSelfRefCell(g, vref.BaseOrThisInfo, vref.TauType)) - | _, _ -> None - - let CollectParameters (methods: MethInfo list) amap m: Item list = - methods - |> List.collect (fun meth -> - match meth.GetParamDatas(amap, m, meth.FormalMethodInst) with - | x::_ -> x |> List.choose(fun (ParamData(_isParamArray, _isInArg, _isOutArg, _optArgInfo, _callerInfo, name, _, ty)) -> - match name with - | Some n -> Some (Item.ArgName(n, ty, Some (ArgumentContainer.Method meth))) - | None -> None - ) - | _ -> [] - ) - - let GetNamedParametersAndSettableFields endOfExprPos hasTextChangedSinceLastTypecheck = - let cnrs = GetCapturedNameResolutions endOfExprPos ResolveOverloads.No |> ResizeArray.toList |> List.rev - let result = - match cnrs with - | CNR(_, Item.CtorGroup(_, ((ctor::_) as ctors)), _, denv, nenv, ad, m) ::_ -> - let props = ResolveCompletionsInType ncenv nenv ResolveCompletionTargets.SettablePropertiesAndFields m ad false ctor.ApparentEnclosingType - let parameters = CollectParameters ctors amap m - let items = props @ parameters - Some (denv, m, items) - | CNR(_, Item.MethodGroup(_, methods, _), _, denv, nenv, ad, m) ::_ -> - let props = - methods - |> List.collect (fun meth -> - let retTy = meth.GetFSharpReturnTy(amap, m, meth.FormalMethodInst) - ResolveCompletionsInType ncenv nenv ResolveCompletionTargets.SettablePropertiesAndFields m ad false retTy - ) - let parameters = CollectParameters methods amap m - let items = props @ parameters - Some (denv, m, items) - | _ -> - None - match result with - | None -> - NameResResult.Empty - | Some (denv, m, items) -> - let items = List.map ItemWithNoInst items - ReturnItemsOfType items g denv m TypeNameResolutionFlag.ResolveTypeNamesToTypeRefs hasTextChangedSinceLastTypecheck - - /// finds captured typing for the given position - let GetExprTypingForPosition(endOfExprPos) = - let quals = - sResolutions.CapturedExpressionTypings - |> Seq.filter (fun (pos,ty,denv,_,_,_) -> - // We only want expression types that end at the particular position in the file we are looking at. - let isLocationWeCareAbout = posEq pos endOfExprPos - // Get rid of function types. True, given a 2-arg curried function "f x y", it is legal to do "(f x).GetType()", - // but you almost never want to do this in practice, and we choose not to offer up any intellisense for - // F# function types. - let isFunction = isFunTy denv.g ty - isLocationWeCareAbout && not isFunction) - |> Seq.toArray - - let thereWereSomeQuals = not (Array.isEmpty quals) - // filter out errors - - let quals = quals - |> Array.filter (fun (_,ty,denv,_,_,_) -> not (isTyparTy denv.g ty && (destTyparTy denv.g ty).IsFromError)) - thereWereSomeQuals, quals - - /// obtains captured typing for the given position - /// if type of captured typing is record - returns list of record fields - let GetRecdFieldsForExpr(r : range) = - let _, quals = GetExprTypingForPosition(r.End) - let bestQual = - match quals with - | [||] -> None - | quals -> - quals |> Array.tryFind (fun (_,_,_,_,_,rq) -> - ignore(r) // for breakpoint - posEq r.Start rq.Start) - match bestQual with - | Some (_,ty,denv,_nenv,ad,m) when isRecdTy denv.g ty -> - let items = NameResolution.ResolveRecordOrClassFieldsOfType ncenv m ad ty false - Some (items, denv, m) - | _ -> None - - /// Looks at the exact expression types at the position to the left of the - /// residue then the source when it was typechecked. - let GetPreciseCompletionListFromExprTypings(parseResults:FSharpParseFileResults, endOfExprPos, filterCtors, hasTextChangedSinceLastTypecheck: (obj * range -> bool)) = - - let thereWereSomeQuals, quals = GetExprTypingForPosition(endOfExprPos) - - match quals with - | [| |] -> - if thereWereSomeQuals then - GetPreciseCompletionListFromExprTypingsResult.NoneBecauseThereWereTypeErrors - else - GetPreciseCompletionListFromExprTypingsResult.None - | _ -> - let bestQual, textChanged = - match parseResults.ParseTree with - | Some(input) -> - match UntypedParseImpl.GetRangeOfExprLeftOfDot(endOfExprPos,Some(input)) with // TODO we say "colAtEndOfNames" everywhere, but that's not really a good name ("foo . $" hit Ctrl-Space at $) - | Some( exprRange) -> - if hasTextChangedSinceLastTypecheck(textSnapshotInfo, exprRange) then - None, true // typecheck is stale, wait for second-chance IntelliSense to bring up right result - else - // See bug 130733. We have an up-to-date sync parse, and know the exact range of the prior expression. - // The quals all already have the same ending position, so find one with a matching starting position, if it exists. - // If not, then the stale typecheck info does not have a capturedExpressionTyping for this exact expression, and the - // user can wait for typechecking to catch up and second-chance intellisense to give the right result. - let qual = - quals |> Array.tryFind (fun (_,_,_,_,_,r) -> - ignore(r) // for breakpoint - posEq exprRange.Start r.Start) - qual, false - | None -> - // TODO In theory I think we should never get to this code path; it would be nice to add an assert. - // In practice, we do get here in some weird cases like "2.0 .. 3.0" and hitting Ctrl-Space in between the two dots of the range operator. - // I wasn't able to track down what was happening in those weird cases, not worth worrying about, it doesn't manifest as a product bug or anything. - None, false - | _ -> None, false - - match bestQual with - | Some bestQual -> - let (_,ty,denv,nenv,ad,m) = bestQual - let items = ResolveCompletionsInType ncenv nenv (ResolveCompletionTargets.All(ConstraintSolver.IsApplicableMethApprox g amap m)) m ad false ty - let items = items |> List.map ItemWithNoInst - let items = items |> RemoveDuplicateItems g - let items = items |> RemoveExplicitlySuppressed g - let items = items |> FilterItemsForCtors filterCtors - GetPreciseCompletionListFromExprTypingsResult.Some((items,denv,m), ty) - | None -> - if textChanged then GetPreciseCompletionListFromExprTypingsResult.NoneBecauseTypecheckIsStaleAndTextChanged - else GetPreciseCompletionListFromExprTypingsResult.None - - /// Find items in the best naming environment. - let GetEnvironmentLookupResolutions(nenv, ad, m, plid, filterCtors, showObsolete) = - let items = NameResolution.ResolvePartialLongIdent ncenv nenv (ConstraintSolver.IsApplicableMethApprox g amap m) m ad plid showObsolete - let items = items |> List.map ItemWithNoInst - let items = items |> RemoveDuplicateItems g - let items = items |> RemoveExplicitlySuppressed g - let items = items |> FilterItemsForCtors filterCtors - (items, nenv.DisplayEnv, m) - - /// Find items in the best naming environment. - let GetEnvironmentLookupResolutionsAtPosition(cursorPos, plid, filterCtors, showObsolete) = - let (nenv,ad),m = GetBestEnvForPos cursorPos - GetEnvironmentLookupResolutions(nenv, ad, m, plid, filterCtors, showObsolete) - - /// Find record fields in the best naming environment. - let GetClassOrRecordFieldsEnvironmentLookupResolutions(cursorPos, plid) = - let (nenv, ad),m = GetBestEnvForPos cursorPos - let items = NameResolution.ResolvePartialLongIdentToClassOrRecdFields ncenv nenv m ad plid false - let items = items |> List.map ItemWithNoInst - let items = items |> RemoveDuplicateItems g - let items = items |> RemoveExplicitlySuppressed g - items, nenv.DisplayEnv, m - - /// Resolve a location and/or text to items. - // Three techniques are used - // - look for an exact known name resolution from type checking - // - use the known type of an expression, e.g. (expr).Name, to generate an item list - // - lookup an entire name in the name resolution environment, e.g. A.B.Name, to generate an item list - // - // The overall aim is to resolve as accurately as possible based on what we know from type inference - - let GetBaseClassCandidates = function - | Item.ModuleOrNamespaces _ -> true - | Item.Types(_, ty::_) when (isClassTy g ty) && not (isSealedTy g ty) -> true - | _ -> false - - let GetInterfaceCandidates = function - | Item.ModuleOrNamespaces _ -> true - | Item.Types(_, ty::_) when (isInterfaceTy g ty) -> true - | _ -> false - - - // Return only items with the specified name - let FilterDeclItemsByResidue (getItem: 'a -> Item) residue (items: 'a list) = - let attributedResidue = residue + "Attribute" - let nameMatchesResidue name = (residue = name) || (attributedResidue = name) - - items |> List.filter (fun x -> - let item = getItem x - let n1 = item.DisplayName - match item with - | Item.Types _ -> nameMatchesResidue n1 - | Item.CtorGroup (_, meths) -> - nameMatchesResidue n1 || - meths |> List.exists (fun meth -> - let tcref = meth.ApparentEnclosingTyconRef - tcref.IsProvided || nameMatchesResidue tcref.DisplayName) - | _ -> residue = n1) - - /// Post-filter items to make sure they have precisely the right name - /// This also checks that there are some remaining results - /// exactMatchResidueOpt = Some _ -- means that we are looking for exact matches - let FilterRelevantItemsBy (getItem: 'a -> Item) (exactMatchResidueOpt : _ option) check (items: 'a list, denv, m) = - - // can throw if type is in located in non-resolved CCU: i.e. bigint if reference to System.Numerics is absent - let safeCheck item = try check item with _ -> false - - // Are we looking for items with precisely the given name? - if not (isNil items) && exactMatchResidueOpt.IsSome then - let items = items |> FilterDeclItemsByResidue getItem exactMatchResidueOpt.Value |> List.filter safeCheck - if not (isNil items) then Some(items, denv, m) else None - else - // When (items = []) we must returns Some([],..) and not None - // because this value is used if we want to stop further processing (e.g. let x.$ = ...) - let items = items |> List.filter safeCheck - Some(items, denv, m) - - /// Post-filter items to make sure they have precisely the right name - /// This also checks that there are some remaining results - let (|FilterRelevantItems|_|) getItem exactMatchResidueOpt orig = - FilterRelevantItemsBy getItem exactMatchResidueOpt (fun _ -> true) orig - - /// Find the first non-whitespace position in a line prior to the given character - let FindFirstNonWhitespacePosition (lineStr: string) i = - if i >= lineStr.Length then None - else - let mutable p = i - while p >= 0 && System.Char.IsWhiteSpace(lineStr.[p]) do - p <- p - 1 - if p >= 0 then Some p else None - - let CompletionItem (ty: ValueOption) (assemblySymbol: ValueOption) (item: ItemWithInst) = - let kind = - match item.Item with - | Item.MethodGroup (_, minfo :: _, _) -> CompletionItemKind.Method minfo.IsExtensionMember - | Item.RecdField _ - | Item.Property _ -> CompletionItemKind.Property - | Item.Event _ -> CompletionItemKind.Event - | Item.ILField _ - | Item.Value _ -> CompletionItemKind.Field - | Item.CustomOperation _ -> CompletionItemKind.CustomOperation - | _ -> CompletionItemKind.Other - - { ItemWithInst = item - MinorPriority = 0 - Kind = kind - IsOwnMember = false - Type = match ty with ValueSome x -> Some x | _ -> None - Unresolved = match assemblySymbol with ValueSome x -> Some x.UnresolvedSymbol | _ -> None } - - let DefaultCompletionItem item = CompletionItem ValueNone ValueNone item - - let getItem (x: ItemWithInst) = x.Item - let GetDeclaredItems (parseResultsOpt: FSharpParseFileResults option, lineStr: string, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, - filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck, isInRangeOperator, allSymbols: unit -> AssemblySymbol list) = - - // Are the last two chars (except whitespaces) = ".." - let isLikeRangeOp = - match FindFirstNonWhitespacePosition lineStr (colAtEndOfNamesAndResidue - 1) with - | Some x when x >= 1 && lineStr.[x] = '.' && lineStr.[x - 1] = '.' -> true - | _ -> false - - // if last two chars are .. and we are not in range operator context - no completion - if isLikeRangeOp && not isInRangeOperator then None else - - // Try to use the exact results of name resolution during type checking to generate the results - // This is based on position (i.e. colAtEndOfNamesAndResidue). This is not used if a residueOpt is given. - let nameResItems = - match residueOpt with - | None -> GetPreciseItemsFromNameResolution(line, colAtEndOfNamesAndResidue, None, filterCtors,resolveOverloads, hasTextChangedSinceLastTypecheck) - | Some residue -> - // deals with cases when we have spaces between dot and\or identifier, like A . $ - // if this is our case - then we need to locate end position of the name skipping whitespaces - // this allows us to handle cases like: let x . $ = 1 - match lastDotPos |> Option.orElseWith (fun _ -> FindFirstNonWhitespacePosition lineStr (colAtEndOfNamesAndResidue - 1)) with - | Some p when lineStr.[p] = '.' -> - match FindFirstNonWhitespacePosition lineStr (p - 1) with - | Some colAtEndOfNames -> - let colAtEndOfNames = colAtEndOfNames + 1 // convert 0-based to 1-based - GetPreciseItemsFromNameResolution(line, colAtEndOfNames, Some(residue), filterCtors,resolveOverloads, hasTextChangedSinceLastTypecheck) - | None -> NameResResult.Empty - | _ -> NameResResult.Empty - - // Normalize to form A.B.C.D where D is the residue. It may be empty for "A.B.C." - // residueOpt = Some when we are looking for the exact match - let plid, exactMatchResidueOpt = - match origLongIdentOpt, residueOpt with - | None, _ -> [], None - | Some(origLongIdent), Some _ -> origLongIdent, None - | Some(origLongIdent), None -> - System.Diagnostics.Debug.Assert(not (isNil origLongIdent), "origLongIdent is empty") - // note: as above, this happens when we are called for "precise" resolution - (F1 keyword, data tip etc..) - let plid, residue = List.frontAndBack origLongIdent - plid, Some residue - - let pos = mkPos line loc - let (nenv, ad), m = GetBestEnvForPos pos - - let getType() = - match NameResolution.TryToResolveLongIdentAsType ncenv nenv m plid with - | Some x -> tryDestAppTy g x - | None -> - match lastDotPos |> Option.orElseWith (fun _ -> FindFirstNonWhitespacePosition lineStr (colAtEndOfNamesAndResidue - 1)) with - | Some p when lineStr.[p] = '.' -> - match FindFirstNonWhitespacePosition lineStr (p - 1) with - | Some colAtEndOfNames -> - let colAtEndOfNames = colAtEndOfNames + 1 // convert 0-based to 1-based - match TryGetTypeFromNameResolution(line, colAtEndOfNames, residueOpt, resolveOverloads) with - | Some x -> tryDestAppTy g x - | _ -> ValueNone - | None -> ValueNone - | _ -> ValueNone - - match nameResItems with - | NameResResult.TypecheckStaleAndTextChanged -> None // second-chance intellisense will try again - | NameResResult.Cancel(denv,m) -> Some([], denv, m) - | NameResResult.Members(FilterRelevantItems getItem exactMatchResidueOpt (items, denv, m)) -> - // lookup based on name resolution results successful - Some (items |> List.map (CompletionItem (getType()) ValueNone), denv, m) - | _ -> - match origLongIdentOpt with - | None -> None - | Some _ -> - - // Try to use the type of the expression on the left to help generate a completion list - let qualItems, thereIsADotInvolved = - match parseResultsOpt with - | None -> - // Note, you will get here if the 'reason' is not CompleteWord/MemberSelect/DisplayMemberList, as those are currently the - // only reasons we do a sync parse to have the most precise and likely-to-be-correct-and-up-to-date info. So for example, - // if you do QuickInfo hovering over A in "f(x).A()", you will only get a tip if typechecking has a name-resolution recorded - // for A, not if merely we know the capturedExpressionTyping of f(x) and you very recently typed ".A()" - in that case, - // you won't won't get a tip until the typechecking catches back up. - GetPreciseCompletionListFromExprTypingsResult.None, false - | Some parseResults -> - - match UntypedParseImpl.TryFindExpressionASTLeftOfDotLeftOfCursor(mkPos line colAtEndOfNamesAndResidue,parseResults.ParseTree) with - | Some(pos,_) -> - GetPreciseCompletionListFromExprTypings(parseResults, pos, filterCtors, hasTextChangedSinceLastTypecheck), true - | None -> - // Can get here in a case like: if "f xxx yyy" is legal, and we do "f xxx y" - // We have no interest in expression typings, those are only useful for dot-completion. We want to fallback - // to "Use an environment lookup as the last resort" below - GetPreciseCompletionListFromExprTypingsResult.None, false - - match qualItems,thereIsADotInvolved with - | GetPreciseCompletionListFromExprTypingsResult.Some(FilterRelevantItems getItem exactMatchResidueOpt (items, denv, m), ty), _ - // Initially we only use the expression typings when looking up, e.g. (expr).Nam or (expr).Name1.Nam - // These come through as an empty plid and residue "". Otherwise we try an environment lookup - // and then return to the qualItems. This is because the expression typings are a little inaccurate, primarily because - // it appears we're getting some typings recorded for non-atomic expressions like "f x" - when isNil plid -> - // lookup based on expression typings successful - Some (items |> List.map (CompletionItem (tryDestAppTy g ty) ValueNone), denv, m) - | GetPreciseCompletionListFromExprTypingsResult.NoneBecauseThereWereTypeErrors, _ -> - // There was an error, e.g. we have "." and there is an error determining the type of - // In this case, we don't want any of the fallback logic, rather, we want to produce zero results. - None - | GetPreciseCompletionListFromExprTypingsResult.NoneBecauseTypecheckIsStaleAndTextChanged, _ -> - // we want to report no result and let second-chance intellisense kick in - None - | _, true when isNil plid -> - // If the user just pressed '.' after an _expression_ (not a plid), it is never right to show environment-lookup top-level completions. - // The user might by typing quickly, and the LS didn't have an expression type right before the dot yet. - // Second-chance intellisense will bring up the correct list in a moment. - None - | _ -> - // Use an environment lookup as the last resort - let envItems, denv, m = GetEnvironmentLookupResolutions(nenv, ad, m, plid, filterCtors, residueOpt.IsSome) - - let envResult = - match nameResItems, (envItems, denv, m), qualItems with - - // First, use unfiltered name resolution items, if they're not empty - | NameResResult.Members(items, denv, m), _, _ when not (isNil items) -> - // lookup based on name resolution results successful - ValueSome(items |> List.map (CompletionItem (getType()) ValueNone), denv, m) - - // If we have nonempty items from environment that were resolved from a type, then use them... - // (that's better than the next case - here we'd return 'int' as a type) - | _, FilterRelevantItems getItem exactMatchResidueOpt (items, denv, m), _ when not (isNil items) -> - // lookup based on name and environment successful - ValueSome(items |> List.map (CompletionItem (getType()) ValueNone), denv, m) - - // Try again with the qualItems - | _, _, GetPreciseCompletionListFromExprTypingsResult.Some(FilterRelevantItems getItem exactMatchResidueOpt (items, denv, m), ty) -> - ValueSome(items |> List.map (CompletionItem (tryDestAppTy g ty) ValueNone), denv, m) - - | _ -> ValueNone - - let globalResult = - match origLongIdentOpt with - | None | Some [] -> - let globalItems = - allSymbols() - |> List.filter (fun x -> not x.Symbol.IsExplicitlySuppressed) - |> List.filter (fun x -> - match x.Symbol with - | :? FSharpMemberOrFunctionOrValue as m when m.IsConstructor && filterCtors = ResolveTypeNamesToTypeRefs -> false - | _ -> true) - - let getItem (x: AssemblySymbol) = x.Symbol.Item - - match globalItems, denv, m with - | FilterRelevantItems getItem exactMatchResidueOpt (globalItemsFiltered, denv, m) when not (isNil globalItemsFiltered) -> - globalItemsFiltered - |> List.map(fun globalItem -> CompletionItem (getType()) (ValueSome globalItem) (ItemWithNoInst globalItem.Symbol.Item)) - |> fun r -> ValueSome(r, denv, m) - | _ -> ValueNone - | _ -> ValueNone // do not return unresolved items after dot - - match envResult, globalResult with - | ValueSome (items, denv, m), ValueSome (gItems,_,_) -> Some (items @ gItems, denv, m) - | ValueSome x, ValueNone -> Some x - | ValueNone, ValueSome y -> Some y - | ValueNone, ValueNone -> None - - - let toCompletionItems (items: ItemWithInst list, denv: DisplayEnv, m: range ) = - items |> List.map DefaultCompletionItem, denv, m - - /// Get the auto-complete items at a particular location. - let GetDeclItemsForNamesAtPosition(ctok: CompilationThreadToken, parseResultsOpt: FSharpParseFileResults option, origLongIdentOpt: string list option, - residueOpt:string option, lastDotPos: int option, line:int, lineStr:string, colAtEndOfNamesAndResidue, filterCtors, resolveOverloads, - getAllSymbols: unit -> AssemblySymbol list, hasTextChangedSinceLastTypecheck: (obj * range -> bool)) - : (CompletionItem list * DisplayEnv * CompletionContext option * range) option = - RequireCompilationThread ctok // the operations in this method need the reactor thread - - let loc = - match colAtEndOfNamesAndResidue with - | pastEndOfLine when pastEndOfLine >= lineStr.Length -> lineStr.Length - | atDot when lineStr.[atDot] = '.' -> atDot + 1 - | atStart when atStart = 0 -> 0 - | otherwise -> otherwise - 1 - - // Look for a "special" completion context - let completionContext = - parseResultsOpt - |> Option.bind (fun x -> x.ParseTree) - |> Option.bind (fun parseTree -> UntypedParseImpl.TryGetCompletionContext(mkPos line colAtEndOfNamesAndResidue, parseTree, lineStr)) - - let res = - match completionContext with - // Invalid completion locations - | Some CompletionContext.Invalid -> None - - // Completion at 'inherit C(...)" - | Some (CompletionContext.Inherit(InheritanceContext.Class, (plid, _))) -> - GetEnvironmentLookupResolutionsAtPosition(mkPos line loc, plid, filterCtors, false) - |> FilterRelevantItemsBy getItem None (getItem >> GetBaseClassCandidates) - |> Option.map toCompletionItems - - // Completion at 'interface ..." - | Some (CompletionContext.Inherit(InheritanceContext.Interface, (plid, _))) -> - GetEnvironmentLookupResolutionsAtPosition(mkPos line loc, plid, filterCtors, false) - |> FilterRelevantItemsBy getItem None (getItem >> GetInterfaceCandidates) - |> Option.map toCompletionItems - - // Completion at 'implement ..." - | Some (CompletionContext.Inherit(InheritanceContext.Unknown, (plid, _))) -> - GetEnvironmentLookupResolutionsAtPosition(mkPos line loc, plid, filterCtors, false) - |> FilterRelevantItemsBy getItem None (getItem >> (fun t -> GetBaseClassCandidates t || GetInterfaceCandidates t)) - |> Option.map toCompletionItems - - // Completion at ' { XXX = ... } " - | Some(CompletionContext.RecordField(RecordContext.New(plid, _))) -> - // { x. } can be either record construction or computation expression. Try to get all visible record fields first - match GetClassOrRecordFieldsEnvironmentLookupResolutions(mkPos line loc, plid) |> toCompletionItems with - | [],_,_ -> - // no record fields found, return completion list as if we were outside any computation expression - GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors,resolveOverloads, hasTextChangedSinceLastTypecheck, false, fun() -> []) - | result -> Some(result) - - // Completion at ' { XXX = ... with ... } " - | Some(CompletionContext.RecordField(RecordContext.CopyOnUpdate(r, (plid, _)))) -> - match GetRecdFieldsForExpr(r) with - | None -> - Some (GetClassOrRecordFieldsEnvironmentLookupResolutions(mkPos line loc, plid)) - |> Option.map toCompletionItems - | Some (items, denv, m) -> - Some (List.map ItemWithNoInst items, denv, m) - |> Option.map toCompletionItems - - // Completion at ' { XXX = ... with ... } " - | Some(CompletionContext.RecordField(RecordContext.Constructor(typeName))) -> - Some(GetClassOrRecordFieldsEnvironmentLookupResolutions(mkPos line loc, [typeName])) - |> Option.map toCompletionItems - - // Completion at ' SomeMethod( ... ) ' with named arguments - | Some(CompletionContext.ParameterList (endPos, fields)) -> - let results = GetNamedParametersAndSettableFields endPos hasTextChangedSinceLastTypecheck - - let declaredItems = - GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors, resolveOverloads, - hasTextChangedSinceLastTypecheck, false, getAllSymbols) - - match results with - | NameResResult.Members(items, denv, m) -> - let filtered = - items - |> RemoveDuplicateItems g - |> RemoveExplicitlySuppressed g - |> List.filter (fun item -> not (fields.Contains item.Item.DisplayName)) - |> List.map (fun item -> - { ItemWithInst = item - Kind = CompletionItemKind.Argument - MinorPriority = 0 - IsOwnMember = false - Type = None - Unresolved = None }) - match declaredItems with - | None -> Some (toCompletionItems (items, denv, m)) - | Some (declItems, declaredDisplayEnv, declaredRange) -> Some (filtered @ declItems, declaredDisplayEnv, declaredRange) - | _ -> declaredItems - - | Some(CompletionContext.AttributeApplication) -> - GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck, false, getAllSymbols) - |> Option.map (fun (items, denv, m) -> - items - |> List.filter (fun cItem -> - match cItem.Item with - | Item.ModuleOrNamespaces _ -> true - | _ when IsAttribute infoReader cItem.Item -> true - | _ -> false), denv, m) - - | Some(CompletionContext.OpenDeclaration) -> - GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck, false, getAllSymbols) - |> Option.map (fun (items, denv, m) -> - items |> List.filter (fun x -> match x.Item with Item.ModuleOrNamespaces _ -> true | _ -> false), denv, m) - - // Completion at '(x: ...)" - | Some (CompletionContext.PatternType) -> - GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck, false, getAllSymbols) - |> Option.map (fun (items, denv, m) -> - items - |> List.filter (fun cItem -> - match cItem.Item with - | Item.ModuleOrNamespaces _ - | Item.Types _ - | Item.UnqualifiedType _ - | Item.ExnCase _ -> true - | _ -> false), denv, m) - - // Other completions - | cc -> - match residueOpt |> Option.bind Seq.tryHead with - | Some ''' -> - // The last token in - // let x = 'E - // is Ident with text "'E", however it's either unfinished char literal or generic parameter. - // We should not provide any completion in the former case, and we don't provide it for the latter one for now - // because providing generic parameters list is context aware, which we don't have here (yet). - None - | _ -> - let isInRangeOperator = (match cc with Some (CompletionContext.RangeOperator) -> true | _ -> false) - GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors,resolveOverloads, hasTextChangedSinceLastTypecheck, isInRangeOperator, getAllSymbols) - - res |> Option.map (fun (items, denv, m) -> items, denv, completionContext, m) - - /// Return 'false' if this is not a completion item valid in an interface file. - let IsValidSignatureFileItem item = - match item with - | Item.Types _ | Item.ModuleOrNamespaces _ -> true - | _ -> false - - /// Find the most precise display context for the given line and column. - member __.GetBestDisplayEnvForPos cursorPos = GetBestEnvForPos cursorPos - - member __.GetVisibleNamespacesAndModulesAtPosition(cursorPos: pos) : ModuleOrNamespaceRef list = - let (nenv, ad), m = GetBestEnvForPos cursorPos - NameResolution.GetVisibleNamespacesAndModulesAtPoint ncenv nenv m ad - - /// Determines if a long ident is resolvable at a specific point. - member __.IsRelativeNameResolvable(cursorPos: pos, plid: string list, item: Item) : bool = - ErrorScope.Protect - Range.range0 - (fun () -> - /// Find items in the best naming environment. - let (nenv, ad), m = GetBestEnvForPos cursorPos - NameResolution.IsItemResolvable ncenv nenv m ad plid item) - (fun msg -> - Trace.TraceInformation(sprintf "FCS: recovering from error in IsRelativeNameResolvable: '%s'" msg) - false) - - /// Determines if a long ident is resolvable at a specific point. - member scope.IsRelativeNameResolvableFromSymbol(cursorPos: pos, plid: string list, symbol: FSharpSymbol) : bool = - scope.IsRelativeNameResolvable(cursorPos, plid, symbol.Item) - - /// Get the auto-complete items at a location - member __.GetDeclarations (ctok, parseResultsOpt, line, lineStr, partialName, getAllEntities, hasTextChangedSinceLastTypecheck) = - let isInterfaceFile = SourceFileImpl.IsInterfaceFile mainInputFileName - ErrorScope.Protect Range.range0 - (fun () -> - match GetDeclItemsForNamesAtPosition(ctok, parseResultsOpt, Some partialName.QualifyingIdents, Some partialName.PartialIdent, partialName.LastDotPos, line, lineStr, partialName.EndColumn + 1, ResolveTypeNamesToCtors, ResolveOverloads.Yes, getAllEntities, hasTextChangedSinceLastTypecheck) with - | None -> FSharpDeclarationListInfo.Empty - | Some (items, denv, ctx, m) -> - let items = if isInterfaceFile then items |> List.filter (fun x -> IsValidSignatureFileItem x.Item) else items - let getAccessibility item = FSharpSymbol.GetAccessibility (FSharpSymbol.Create(cenv, item)) - let currentNamespaceOrModule = - parseResultsOpt - |> Option.bind (fun x -> x.ParseTree) - |> Option.map (fun parsedInput -> UntypedParseImpl.GetFullNameOfSmallestModuleOrNamespaceAtPoint(parsedInput, mkPos line 0)) - let isAttributeApplication = ctx = Some CompletionContext.AttributeApplication - FSharpDeclarationListInfo.Create(infoReader,m,denv,getAccessibility,items,reactorOps,currentNamespaceOrModule,isAttributeApplication,checkAlive)) - (fun msg -> - Trace.TraceInformation(sprintf "FCS: recovering from error in GetDeclarations: '%s'" msg) - FSharpDeclarationListInfo.Error msg) - - /// Get the symbols for auto-complete items at a location - member __.GetDeclarationListSymbols (ctok, parseResultsOpt, line, lineStr, partialName, getAllEntities, hasTextChangedSinceLastTypecheck) = - let isInterfaceFile = SourceFileImpl.IsInterfaceFile mainInputFileName - ErrorScope.Protect Range.range0 - (fun () -> - match GetDeclItemsForNamesAtPosition(ctok, parseResultsOpt, Some partialName.QualifyingIdents, Some partialName.PartialIdent, partialName.LastDotPos, line, lineStr, partialName.EndColumn + 1, ResolveTypeNamesToCtors, ResolveOverloads.Yes, getAllEntities, hasTextChangedSinceLastTypecheck) with - | None -> List.Empty - | Some (items, denv, _, m) -> - let items = if isInterfaceFile then items |> List.filter (fun x -> IsValidSignatureFileItem x.Item) else items - - //do filtering like Declarationset - let items = items |> RemoveExplicitlySuppressedCompletionItems g - - // Sort by name. For things with the same name, - // - show types with fewer generic parameters first - // - show types before over other related items - they usually have very useful XmlDocs - let items = - items |> List.sortBy (fun d -> - let n = - match d.Item with - | Item.Types (_,(TType_app(tcref,_) :: _)) -> 1 + tcref.TyparsNoRange.Length - // Put delegate ctors after types, sorted by #typars. RemoveDuplicateItems will remove FakeInterfaceCtor and DelegateCtor if an earlier type is also reported with this name - | Item.FakeInterfaceCtor (TType_app(tcref,_)) - | Item.DelegateCtor (TType_app(tcref,_)) -> 1000 + tcref.TyparsNoRange.Length - // Put type ctors after types, sorted by #typars. RemoveDuplicateItems will remove DefaultStructCtors if a type is also reported with this name - | Item.CtorGroup (_, (cinfo :: _)) -> 1000 + 10 * cinfo.DeclaringTyconRef.TyparsNoRange.Length - | _ -> 0 - (d.Item.DisplayName,n)) - - // Remove all duplicates. We've put the types first, so this removes the DelegateCtor and DefaultStructCtor's. - let items = items |> RemoveDuplicateCompletionItems g - - // Group by compiled name for types, display name for functions - // (We don't want types with the same display name to be grouped as overloads) - let items = - items |> List.groupBy (fun d -> - match d.Item with - | Item.Types (_,(TType_app(tcref,_) :: _)) - | Item.ExnCase tcref -> tcref.LogicalName - | Item.UnqualifiedType(tcref :: _) - | Item.FakeInterfaceCtor (TType_app(tcref,_)) - | Item.DelegateCtor (TType_app(tcref,_)) -> tcref.CompiledName - | Item.CtorGroup (_, (cinfo :: _)) -> - cinfo.ApparentEnclosingTyconRef.CompiledName - | _ -> d.Item.DisplayName) - - // Filter out operators (and list) - let items = - // Check whether this item looks like an operator. - let isOpItem(nm, item: CompletionItem list) = - match item |> List.map (fun x -> x.Item) with - | [Item.Value _] - | [Item.MethodGroup(_,[_],_)] -> IsOperatorName nm - | [Item.UnionCase _] -> IsOperatorName nm - | _ -> false - - let isFSharpList nm = (nm = "[]") // list shows up as a Type and a UnionCase, only such entity with a symbolic name, but want to filter out of intellisense - - items |> List.filter (fun (nm,items) -> not (isOpItem(nm,items)) && not(isFSharpList nm)) - - let items = - // Filter out duplicate names - items |> List.map (fun (_nm,itemsWithSameName) -> - match itemsWithSameName with - | [] -> failwith "Unexpected empty bag" - | items -> - items - |> List.map (fun item -> let symbol = FSharpSymbol.Create(cenv, item.Item) - FSharpSymbolUse(g, denv, symbol, ItemOccurence.Use, m))) - - //end filtering - items) - (fun msg -> - Trace.TraceInformation(sprintf "FCS: recovering from error in GetDeclarationListSymbols: '%s'" msg) - []) - - /// Get the "reference resolution" tooltip for at a location - member __.GetReferenceResolutionStructuredToolTipText(ctok, line,col) = - - RequireCompilationThread ctok // the operations in this method need the reactor thread but the reasons why are not yet grounded - - let pos = mkPos line col - let isPosMatch(pos, ar:AssemblyReference) : bool = - let isRangeMatch = (Range.rangeContainsPos ar.Range pos) - let isNotSpecialRange = (ar.Range <> rangeStartup) && (ar.Range <> range0) && (ar.Range <> rangeCmdArgs) - let isMatch = isRangeMatch && isNotSpecialRange - isMatch - - let dataTipOfReferences() = - let matches = - match loadClosure with - | None -> [] - | Some(loadClosure) -> - loadClosure.References - |> List.map snd - |> List.concat - |> List.filter(fun ar->isPosMatch(pos, ar.originalReference)) - - match matches with - | resolved::_ // Take the first seen - | [resolved] -> - let tip = wordL (TaggedTextOps.tagStringLiteral((resolved.prepareToolTip ()).TrimEnd([|'\n'|]))) - FSharpStructuredToolTipText.FSharpToolTipText [FSharpStructuredToolTipElement.Single(tip, FSharpXmlDoc.None)] - - | [] -> FSharpStructuredToolTipText.FSharpToolTipText [] - - ErrorScope.Protect Range.range0 - dataTipOfReferences - (fun err -> - Trace.TraceInformation(sprintf "FCS: recovering from error in GetReferenceResolutionStructuredToolTipText: '%s'" err) - FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError err]) - - // GetToolTipText: return the "pop up" (or "Quick Info") text given a certain context. - member __.GetStructuredToolTipText(ctok, line, lineStr, colAtEndOfNames, names) = - let Compute() = - ErrorScope.Protect Range.range0 - (fun () -> - match GetDeclItemsForNamesAtPosition(ctok, None,Some(names),None,None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToCtors,ResolveOverloads.Yes,(fun() -> []),fun _ -> false) with - | None -> FSharpToolTipText [] - | Some(items, denv, _, m) -> - FSharpToolTipText(items |> List.map (fun x -> FormatStructuredDescriptionOfItem false infoReader m denv x.ItemWithInst))) - (fun err -> - Trace.TraceInformation(sprintf "FCS: recovering from error in GetStructuredToolTipText: '%s'" err) - FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError err]) - - // See devdiv bug 646520 for rationale behind truncating and caching these quick infos (they can be big!) - let key = line,colAtEndOfNames,lineStr - match getToolTipTextCache.TryGet (ctok, key) with - | Some res -> res - | None -> - let res = Compute() - getToolTipTextCache.Put(ctok, key,res) - res - - member __.GetF1Keyword (ctok, line, lineStr, colAtEndOfNames, names) : string option = - ErrorScope.Protect Range.range0 - (fun () -> - match GetDeclItemsForNamesAtPosition(ctok, None, Some names, None, None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.No,(fun() -> []), fun _ -> false) with // F1 Keywords do not distinguish between overloads - | None -> None - | Some (items: CompletionItem list, _,_, _) -> - match items with - | [] -> None - | [item] -> - GetF1Keyword g item.Item - | _ -> - // handle new Type() - let allTypes, constr, ty = - List.fold - (fun (allTypes,constr,ty) (item: CompletionItem) -> - match item.Item, constr, ty with - | (Item.Types _) as t, _, None -> allTypes, constr, Some t - | (Item.Types _), _, _ -> allTypes, constr, ty - | (Item.CtorGroup _), None, _ -> allTypes, Some item.Item, ty - | _ -> false, None, None) - (true,None,None) items - match allTypes, constr, ty with - | true, Some (Item.CtorGroup(_, _) as item), _ - -> GetF1Keyword g item - | true, _, Some ty - -> GetF1Keyword g ty - | _ -> None - ) - (fun msg -> - Trace.TraceInformation(sprintf "FCS: recovering from error in GetF1Keyword: '%s'" msg) - None) - - member __.GetMethods (ctok, line, lineStr, colAtEndOfNames, namesOpt) = - ErrorScope.Protect Range.range0 - (fun () -> - match GetDeclItemsForNamesAtPosition(ctok, None,namesOpt,None,None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToCtors,ResolveOverloads.No,(fun() -> []),fun _ -> false) with - | None -> FSharpMethodGroup("",[| |]) - | Some (items, denv, _, m) -> - // GetDeclItemsForNamesAtPosition returns Items.Types and Item.CtorGroup for `new T(|)`, - // the Item.Types is not needed here as it duplicates (at best) parameterless ctor. - let ctors = items |> List.filter (fun x -> match x.Item with Item.CtorGroup _ -> true | _ -> false) - let items = - match ctors with - | [] -> items - | ctors -> ctors - FSharpMethodGroup.Create(infoReader, m, denv, items |> List.map (fun x -> x.ItemWithInst))) - (fun msg -> - Trace.TraceInformation(sprintf "FCS: recovering from error in GetMethods: '%s'" msg) - FSharpMethodGroup(msg,[| |])) - - member __.GetMethodsAsSymbols (ctok, line, lineStr, colAtEndOfNames, names) = - ErrorScope.Protect Range.range0 - (fun () -> - match GetDeclItemsForNamesAtPosition (ctok, None,Some(names), None, None,line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.No,(fun() -> []),fun _ -> false) with - | None | Some ([],_,_,_) -> None - | Some (items, denv, _, m) -> - let allItems = items |> List.collect (fun item -> SymbolHelpers.FlattenItems g m item.Item) - let symbols = allItems |> List.map (fun item -> FSharpSymbol.Create(cenv, item)) - Some (symbols, denv, m) - ) - (fun msg -> - Trace.TraceInformation(sprintf "FCS: recovering from error in GetMethodsAsSymbols: '%s'" msg) - None) - - member __.GetDeclarationLocation (ctok, line, lineStr, colAtEndOfNames, names, preferFlag) = - ErrorScope.Protect Range.range0 - (fun () -> - match GetDeclItemsForNamesAtPosition (ctok, None,Some(names), None, None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors,ResolveOverloads.Yes,(fun() -> []), fun _ -> false) with - | None - | Some ([], _, _, _) -> FSharpFindDeclResult.DeclNotFound (FSharpFindDeclFailureReason.Unknown "") - | Some (item :: _, _, _, _) -> - let getTypeVarNames (ilinfo: ILMethInfo) = - let classTypeParams = ilinfo.DeclaringTyconRef.ILTyconRawMetadata.GenericParams |> List.map (fun paramDef -> paramDef.Name) - let methodTypeParams = ilinfo.FormalMethodTypars |> List.map (fun ty -> ty.Name) - classTypeParams @ methodTypeParams |> Array.ofList - - let result = - match item.Item with - | Item.CtorGroup (_, (ILMeth (_,ilinfo,_)) :: _) -> - match ilinfo.MetadataScope with - | ILScopeRef.Assembly assemblyRef -> - let typeVarNames = getTypeVarNames ilinfo - ParamTypeSymbol.tryOfILTypes typeVarNames ilinfo.ILMethodRef.ArgTypes - |> Option.map (fun args -> - let externalSym = ExternalSymbol.Constructor (ilinfo.ILMethodRef.DeclaringTypeRef.FullName, args) - FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, externalSym)) - | _ -> None - - | Item.MethodGroup (name, (ILMeth (_,ilinfo,_)) :: _, _) -> - match ilinfo.MetadataScope with - | ILScopeRef.Assembly assemblyRef -> - let typeVarNames = getTypeVarNames ilinfo - ParamTypeSymbol.tryOfILTypes typeVarNames ilinfo.ILMethodRef.ArgTypes - |> Option.map (fun args -> - let externalSym = ExternalSymbol.Method (ilinfo.ILMethodRef.DeclaringTypeRef.FullName, name, args, ilinfo.ILMethodRef.GenericArity) - FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, externalSym)) - | _ -> None - - | Item.Property (name, ILProp propInfo :: _) -> - let methInfo = - if propInfo.HasGetter then Some propInfo.GetterMethod - elif propInfo.HasSetter then Some propInfo.SetterMethod - else None - - match methInfo with - | Some methInfo -> - match methInfo.MetadataScope with - | ILScopeRef.Assembly assemblyRef -> - let externalSym = ExternalSymbol.Property (methInfo.ILMethodRef.DeclaringTypeRef.FullName, name) - Some (FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, externalSym)) - | _ -> None - | None -> None - - | Item.ILField (ILFieldInfo (typeInfo, fieldDef)) when not typeInfo.TyconRefOfRawMetadata.IsLocalRef -> - match typeInfo.ILScopeRef with - | ILScopeRef.Assembly assemblyRef -> - let externalSym = ExternalSymbol.Field (typeInfo.ILTypeRef.FullName, fieldDef.Name) - Some (FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, externalSym)) - | _ -> None - - | Item.Event (ILEvent (ILEventInfo (typeInfo, eventDef))) when not typeInfo.TyconRefOfRawMetadata.IsLocalRef -> - match typeInfo.ILScopeRef with - | ILScopeRef.Assembly assemblyRef -> - let externalSym = ExternalSymbol.Event (typeInfo.ILTypeRef.FullName, eventDef.Name) - Some (FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, externalSym)) - | _ -> None - - | Item.ImplicitOp(_, {contents = Some(TraitConstraintSln.FSMethSln(_, _vref, _))}) -> - //Item.Value(vref) - None - - | Item.Types (_, TType_app (tr, _) :: _) when tr.IsLocalRef && tr.IsTypeAbbrev -> None - - | Item.Types (_, [ AppTy g (tr, _) ]) when not tr.IsLocalRef -> - match tr.TypeReprInfo, tr.PublicPath with - | TILObjectRepr(TILObjectReprData (ILScopeRef.Assembly assemblyRef, _, _)), Some (PubPath parts) -> - let fullName = parts |> String.concat "." - Some (FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, ExternalSymbol.Type fullName)) - | _ -> None - | _ -> None - match result with - | Some x -> x - | None -> - match rangeOfItem g preferFlag item.Item with - | Some itemRange -> - let projectDir = Filename.directoryName (if projectFileName = "" then mainInputFileName else projectFileName) - let range = fileNameOfItem g (Some projectDir) itemRange item.Item - mkRange range itemRange.Start itemRange.End - |> FSharpFindDeclResult.DeclFound - | None -> - match item.Item with -#if !NO_EXTENSIONTYPING -// provided items may have TypeProviderDefinitionLocationAttribute that binds them to some location - | Item.CtorGroup (name, ProvidedMeth (_)::_ ) - | Item.MethodGroup(name, ProvidedMeth (_)::_, _) - | Item.Property (name, ProvidedProp (_)::_ ) -> FSharpFindDeclFailureReason.ProvidedMember name - | Item.Event ( ProvidedEvent(_) as e ) -> FSharpFindDeclFailureReason.ProvidedMember e.EventName - | Item.ILField ( ProvidedField(_) as f ) -> FSharpFindDeclFailureReason.ProvidedMember f.FieldName - | SymbolHelpers.ItemIsProvidedType g (tcref) -> FSharpFindDeclFailureReason.ProvidedType tcref.DisplayName -#endif - | _ -> FSharpFindDeclFailureReason.Unknown "" - |> FSharpFindDeclResult.DeclNotFound - ) - (fun msg -> - Trace.TraceInformation(sprintf "FCS: recovering from error in GetDeclarationLocation: '%s'" msg) - FSharpFindDeclResult.DeclNotFound (FSharpFindDeclFailureReason.Unknown msg)) - - member __.GetSymbolUseAtLocation (ctok, line, lineStr, colAtEndOfNames, names) = - ErrorScope.Protect Range.range0 - (fun () -> - match GetDeclItemsForNamesAtPosition (ctok, None,Some(names), None, None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.Yes,(fun() -> []), fun _ -> false) with - | None | Some ([], _, _, _) -> None - | Some (item :: _, denv, _, m) -> - let symbol = FSharpSymbol.Create(cenv, item.Item) - Some (symbol, denv, m) - ) - (fun msg -> - Trace.TraceInformation(sprintf "FCS: recovering from error in GetSymbolUseAtLocation: '%s'" msg) - None) - - member __.PartialAssemblySignatureForFile = - FSharpAssemblySignature(g, thisCcu, ccuSigForFile, tcImports, None, ccuSigForFile) - - member __.AccessRights = tcAccessRights - - member __.GetReferencedAssemblies() = - [ for x in tcImports.GetImportedAssemblies() do - yield FSharpAssembly(g, tcImports, x.FSharpViewOfMetadata) ] - - member __.GetFormatSpecifierLocationsAndArity() = - sSymbolUses.GetFormatSpecifierLocationsAndArity() - - member __.GetSemanticClassification(range: range option) : (range * SemanticClassificationType) [] = - ErrorScope.Protect Range.range0 - (fun () -> - let (|LegitTypeOccurence|_|) = function - | ItemOccurence.UseInType - | ItemOccurence.UseInAttribute - | ItemOccurence.Use _ - | ItemOccurence.Binding _ - | ItemOccurence.Pattern _ -> Some() - | _ -> None - - let (|OptionalArgumentAttribute|_|) ttype = - match ttype with - | TType.TType_app(tref, _) when tref.Stamp = g.attrib_OptionalArgumentAttribute.TyconRef.Stamp -> Some() - | _ -> None - - let (|KeywordIntrinsicValue|_|) (vref: ValRef) = - if valRefEq g g.raise_vref vref || - valRefEq g g.reraise_vref vref || - valRefEq g g.typeof_vref vref || - valRefEq g g.typedefof_vref vref || - valRefEq g g.sizeof_vref vref - // TODO uncomment this after `nameof` operator is implemented - // || valRefEq g g.nameof_vref vref - then Some() - else None - - let (|EnumCaseFieldInfo|_|) (rfinfo : RecdFieldInfo) = - match rfinfo.TyconRef.TypeReprInfo with - | TFSharpObjectRepr x -> - match x.fsobjmodel_kind with - | TTyconEnum -> Some () - | _ -> None - | _ -> None - - let resolutions = - match range with - | Some range -> - sResolutions.CapturedNameResolutions - |> Seq.filter (fun cnr -> rangeContainsPos range cnr.Range.Start || rangeContainsPos range cnr.Range.End) - | None -> - sResolutions.CapturedNameResolutions :> seq<_> - - let isDisposableTy (ty: TType) = - protectAssemblyExplorationNoReraise false false (fun () -> Infos.ExistsHeadTypeInEntireHierarchy g amap range0 ty g.tcref_System_IDisposable) - - let isStructTyconRef (tyconRef: TyconRef) = - let ty = generalizedTyconRef tyconRef - let underlyingTy = stripTyEqnsAndMeasureEqns g ty - isStructTy g underlyingTy - - let isValRefMutable (vref: ValRef) = - // Mutable values, ref cells, and non-inref byrefs are mutable. - vref.IsMutable - || Tastops.isRefCellTy g vref.Type - || (Tastops.isByrefTy g vref.Type && not (Tastops.isInByrefTy g vref.Type)) - - let isRecdFieldMutable (rfinfo: RecdFieldInfo) = - (rfinfo.RecdField.IsMutable && rfinfo.LiteralValue.IsNone) - || Tastops.isRefCellTy g rfinfo.RecdField.FormalType - - resolutions - |> Seq.choose (fun cnr -> - match cnr with - // 'seq' in 'seq { ... }' gets colored as keywords - | CNR(_, (Item.Value vref), ItemOccurence.Use, _, _, _, m) when valRefEq g g.seq_vref vref -> - Some (m, SemanticClassificationType.ComputationExpression) - | CNR(_, (Item.Value vref), _, _, _, _, m) when isValRefMutable vref -> - Some (m, SemanticClassificationType.MutableVar) - | CNR(_, Item.Value KeywordIntrinsicValue, ItemOccurence.Use, _, _, _, m) -> - Some (m, SemanticClassificationType.IntrinsicFunction) - | CNR(_, (Item.Value vref), _, _, _, _, m) when isFunction g vref.Type -> - if valRefEq g g.range_op_vref vref || valRefEq g g.range_step_op_vref vref then - None - elif vref.IsPropertyGetterMethod || vref.IsPropertySetterMethod then - Some (m, SemanticClassificationType.Property) - elif IsOperatorName vref.DisplayName then - Some (m, SemanticClassificationType.Operator) - else - Some (m, SemanticClassificationType.Function) - | CNR(_, Item.RecdField rfinfo, _, _, _, _, m) when isRecdFieldMutable rfinfo -> - Some (m, SemanticClassificationType.MutableVar) - | CNR(_, Item.RecdField rfinfo, _, _, _, _, m) when isFunction g rfinfo.FieldType -> - Some (m, SemanticClassificationType.Function) - | CNR(_, Item.RecdField EnumCaseFieldInfo, _, _, _, _, m) -> - Some (m, SemanticClassificationType.Enumeration) - | CNR(_, Item.MethodGroup _, _, _, _, _, m) -> - Some (m, SemanticClassificationType.Function) - // custom builders, custom operations get colored as keywords - | CNR(_, (Item.CustomBuilder _ | Item.CustomOperation _), ItemOccurence.Use, _, _, _, m) -> - Some (m, SemanticClassificationType.ComputationExpression) - // types get colored as types when they occur in syntactic types or custom attributes - // typevariables get colored as types when they occur in syntactic types custom builders, custom operations get colored as keywords - | CNR(_, Item.Types (_, [OptionalArgumentAttribute]), LegitTypeOccurence, _, _, _, _) -> None - | CNR(_, Item.CtorGroup(_, [MethInfo.FSMeth(_, OptionalArgumentAttribute, _, _)]), LegitTypeOccurence, _, _, _, _) -> None - | CNR(_, Item.Types(_, types), LegitTypeOccurence, _, _, _, m) when types |> List.exists (isInterfaceTy g) -> - Some (m, SemanticClassificationType.Interface) - | CNR(_, Item.Types(_, types), LegitTypeOccurence, _, _, _, m) when types |> List.exists (isStructTy g) -> - Some (m, SemanticClassificationType.ValueType) - | CNR(_, Item.Types(_, TType_app(tyconRef, TType_measure _ :: _) :: _), LegitTypeOccurence, _, _, _, m) when isStructTyconRef tyconRef -> - Some (m, SemanticClassificationType.ValueType) - | CNR(_, Item.Types(_, types), LegitTypeOccurence, _, _, _, m) when types |> List.exists isDisposableTy -> - Some (m, SemanticClassificationType.Disposable) - | CNR(_, Item.Types _, LegitTypeOccurence, _, _, _, m) -> - Some (m, SemanticClassificationType.ReferenceType) - | CNR(_, (Item.TypeVar _ ), LegitTypeOccurence, _, _, _, m) -> - Some (m, SemanticClassificationType.TypeArgument) - | CNR(_, Item.UnqualifiedType tyconRefs, LegitTypeOccurence, _, _, _, m) -> - if tyconRefs |> List.exists (fun tyconRef -> tyconRef.Deref.IsStructOrEnumTycon) then - Some (m, SemanticClassificationType.ValueType) - else Some (m, SemanticClassificationType.ReferenceType) - | CNR(_, Item.CtorGroup(_, minfos), LegitTypeOccurence, _, _, _, m) -> - if minfos |> List.exists (fun minfo -> isStructTy g minfo.ApparentEnclosingType) then - Some (m, SemanticClassificationType.ValueType) - else Some (m, SemanticClassificationType.ReferenceType) - | CNR(_, Item.ExnCase _, LegitTypeOccurence, _, _, _, m) -> - Some (m, SemanticClassificationType.ReferenceType) - | CNR(_, Item.ModuleOrNamespaces refs, LegitTypeOccurence, _, _, _, m) when refs |> List.exists (fun x -> x.IsModule) -> - Some (m, SemanticClassificationType.Module) - | CNR(_, (Item.ActivePatternCase _ | Item.UnionCase _ | Item.ActivePatternResult _), _, _, _, _, m) -> - Some (m, SemanticClassificationType.UnionCase) - | _ -> None) - |> Seq.toArray - |> Array.append (sSymbolUses.GetFormatSpecifierLocationsAndArity() |> Array.map (fun m -> fst m, SemanticClassificationType.Printf)) - ) - (fun msg -> - Trace.TraceInformation(sprintf "FCS: recovering from error in GetSemanticClassification: '%s'" msg) - Array.empty) - - /// The resolutions in the file - member __.ScopeResolutions = sResolutions - - /// The uses of symbols in the analyzed file - member __.ScopeSymbolUses = sSymbolUses - - member __.TcGlobals = g - - member __.TcImports = tcImports - - /// The inferred signature of the file - member __.CcuSigForFile = ccuSigForFile - - /// The assembly being analyzed - member __.ThisCcu = thisCcu - - member __.ImplementationFile = implFileOpt - - /// All open declarations in the file, including auto open modules - member __.OpenDeclarations = openDeclarations - - member __.SymbolEnv = cenv - - override __.ToString() = "TypeCheckInfo(" + mainInputFileName + ")" - -type FSharpParsingOptions = - { SourceFiles: string [] - ConditionalCompilationDefines: string list - ErrorSeverityOptions: FSharpErrorSeverityOptions - IsInteractive: bool - LightSyntax: bool option - CompilingFsLib: bool - IsExe: bool } - - member x.LastFileName = - Debug.Assert(not (Array.isEmpty x.SourceFiles), "Parsing options don't contain any file") - Array.last x.SourceFiles - - static member Default = - { SourceFiles = Array.empty - ConditionalCompilationDefines = [] - ErrorSeverityOptions = FSharpErrorSeverityOptions.Default - IsInteractive = false - LightSyntax = None - CompilingFsLib = false - IsExe = false } - - static member FromTcConfig(tcConfig: TcConfig, sourceFiles, isInteractive: bool) = - { SourceFiles = sourceFiles - ConditionalCompilationDefines = tcConfig.conditionalCompilationDefines - ErrorSeverityOptions = tcConfig.errorSeverityOptions - IsInteractive = isInteractive - LightSyntax = tcConfig.light - CompilingFsLib = tcConfig.compilingFslib - IsExe = tcConfig.target.IsExe } - - static member FromTcConfigBuidler(tcConfigB: TcConfigBuilder, sourceFiles, isInteractive: bool) = - { - SourceFiles = sourceFiles - ConditionalCompilationDefines = tcConfigB.conditionalCompilationDefines - ErrorSeverityOptions = tcConfigB.errorSeverityOptions - IsInteractive = isInteractive - LightSyntax = tcConfigB.light - CompilingFsLib = tcConfigB.compilingFslib - IsExe = tcConfigB.target.IsExe - } - -module internal Parser = - - // We'll need number of lines for adjusting error messages at EOF - let GetFileInfoForLastLineErrors (source: string) = - // number of lines in the source file - let lastLine = (source |> Seq.sumBy (fun c -> if c = '\n' then 1 else 0)) + 1 - // length of the last line - let lastLineLength = source.Length - source.LastIndexOf("\n",StringComparison.Ordinal) - 1 - lastLine, lastLineLength - - - /// Error handler for parsing & type checking while processing a single file - type ErrorHandler(reportErrors, mainInputFileName, errorSeverityOptions: FSharpErrorSeverityOptions, source) = - let mutable options = errorSeverityOptions - let errorsAndWarningsCollector = new ResizeArray<_>() - let mutable errorCount = 0 - - // We'll need number of lines for adjusting error messages at EOF - let fileInfo = GetFileInfoForLastLineErrors source - - // This function gets called whenever an error happens during parsing or checking - let diagnosticSink sev (exn: PhasedDiagnostic) = - // Sanity check here. The phase of an error should be in a phase known to the language service. - let exn = - if not(exn.IsPhaseInCompile()) then - // Reaching this point means that the error would be sticky if we let it prop up to the language service. - // Assert and recover by replacing phase with one known to the language service. - Trace.TraceInformation(sprintf "The subcategory '%s' seen in an error should not be seen by the language service" (exn.Subcategory())) - { exn with Phase = BuildPhase.TypeCheck } - else exn - if reportErrors then - let report exn = - for ei in ErrorHelpers.ReportError (options, false, mainInputFileName, fileInfo, (exn, sev)) do - errorsAndWarningsCollector.Add ei - if sev = FSharpErrorSeverity.Error then - errorCount <- errorCount + 1 - - match exn with -#if !NO_EXTENSIONTYPING - | { Exception = (:? TypeProviderError as tpe) } -> tpe.Iter(fun e -> report { exn with Exception = e }) -#endif - | e -> report e - - let errorLogger = - { new ErrorLogger("ErrorHandler") with - member x.DiagnosticSink (exn, isError) = diagnosticSink (if isError then FSharpErrorSeverity.Error else FSharpErrorSeverity.Warning) exn - member x.ErrorCount = errorCount } - - // Public members - member x.ErrorLogger = errorLogger - member x.CollectedDiagnostics = errorsAndWarningsCollector.ToArray() - member x.ErrorCount = errorCount - member x.ErrorSeverityOptions with set opts = options <- opts - member x.AnyErrors = errorCount > 0 - - let getLightSyntaxStatus fileName options = - let lower = String.lowercase fileName - let lightOnByDefault = List.exists (Filename.checkSuffix lower) FSharpLightSyntaxFileSuffixes - let lightSyntaxStatus = if lightOnByDefault then (options.LightSyntax <> Some false) else (options.LightSyntax = Some true) - LightSyntaxStatus(lightSyntaxStatus, true) - - let createLexerFunction fileName options lexbuf (errHandler: ErrorHandler) = - let lightSyntaxStatus = getLightSyntaxStatus fileName options - - // If we're editing a script then we define INTERACTIVE otherwise COMPILED. - // Since this parsing for intellisense we always define EDITING. - let defines = (SourceFileImpl.AdditionalDefinesForUseInEditor options.IsInteractive) @ options.ConditionalCompilationDefines - - // Note: we don't really attempt to intern strings across a large scope. - let lexResourceManager = new Lexhelp.LexResourceManager() - - // When analyzing files using ParseOneFile, i.e. for the use of editing clients, we do not apply line directives. - let lexargs = mkLexargs(fileName, defines, lightSyntaxStatus, lexResourceManager, ref [], errHandler.ErrorLogger) - let lexargs = { lexargs with applyLineDirectives = false } - - let tokenizer = LexFilter.LexFilter(lightSyntaxStatus, options.CompilingFsLib, Lexer.token lexargs true, lexbuf) - tokenizer.Lexer - - // Adding this new-line character at the end of the source seems odd but is required for some unit tests - // Todo: fix tests - let addNewLine (source: string) = - if source.Length = 0 || not (source.[source.Length - 1] = '\n') then source + "\n" else source - - let matchBraces(source, fileName, options: FSharpParsingOptions, userOpName: string) = - let delayedLogger = CapturingErrorLogger("matchBraces") - use _unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> delayedLogger) - use _unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse - - Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "matchBraces", fileName) - - // Make sure there is an ErrorLogger installed whenever we do stuff that might record errors, even if we ultimately ignore the errors - let delayedLogger = CapturingErrorLogger("matchBraces") - use _unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> delayedLogger) - use _unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse - - let matchingBraces = new ResizeArray<_>() - Lexhelp.usingLexbufForParsing(UnicodeLexing.StringAsLexbuf(addNewLine source), fileName) (fun lexbuf -> - let errHandler = ErrorHandler(false, fileName, options.ErrorSeverityOptions, source) - let lexfun = createLexerFunction fileName options lexbuf errHandler - let parenTokensBalance t1 t2 = - match t1, t2 with - | (LPAREN, RPAREN) - | (LPAREN, RPAREN_IS_HERE) - | (LBRACE, RBRACE) - | (LBRACE, RBRACE_IS_HERE) - | (SIG, END) - | (STRUCT, END) - | (LBRACK_BAR, BAR_RBRACK) - | (LBRACK, RBRACK) - | (LBRACK_LESS, GREATER_RBRACK) - | (BEGIN, END) -> true - | (LQUOTE q1, RQUOTE q2) -> q1 = q2 - | _ -> false - let rec matchBraces stack = - match lexfun lexbuf, stack with - | tok2, ((tok1, m1) :: stack') when parenTokensBalance tok1 tok2 -> - matchingBraces.Add(m1, lexbuf.LexemeRange) - matchBraces stack' - | ((LPAREN | LBRACE | LBRACK | LBRACK_BAR | LQUOTE _ | LBRACK_LESS) as tok), _ -> - matchBraces ((tok, lexbuf.LexemeRange) :: stack) - | (EOF _ | LEX_FAILURE _), _ -> () - | _ -> matchBraces stack - matchBraces []) - matchingBraces.ToArray() - - let parseFile(source, fileName, options: FSharpParsingOptions, userOpName: string) = - Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "parseFile", fileName) - let errHandler = new ErrorHandler(true, fileName, options.ErrorSeverityOptions, source) - use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _oldLogger -> errHandler.ErrorLogger) - use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse - - let parseResult = - Lexhelp.usingLexbufForParsing(UnicodeLexing.StringAsLexbuf(addNewLine source), fileName) (fun lexbuf -> - let lexfun = createLexerFunction fileName options lexbuf errHandler - let isLastCompiland = - fileName.Equals(options.LastFileName, StringComparison.CurrentCultureIgnoreCase) || - CompileOps.IsScript(fileName) - let isExe = options.IsExe - try Some (ParseInput(lexfun, errHandler.ErrorLogger, lexbuf, None, fileName, (isLastCompiland, isExe))) - with e -> - errHandler.ErrorLogger.StopProcessingRecovery e Range.range0 // don't re-raise any exceptions, we must return None. - None) - errHandler.CollectedDiagnostics, parseResult, errHandler.AnyErrors - - /// Indicates if the type check got aborted because it is no longer relevant. - type TypeCheckAborted = Yes | No of TypeCheckInfo - - // Type check a single file against an initial context, gleaning both errors and intellisense information. - let CheckOneFile - (parseResults: FSharpParseFileResults, - source: string, - mainInputFileName: string, - projectFileName: string, - tcConfig: TcConfig, - tcGlobals: TcGlobals, - tcImports: TcImports, - tcState: TcState, - moduleNamesDict: ModuleNamesDict, - loadClosure: LoadClosure option, - // These are the errors and warnings seen by the background compiler for the entire antecedent - backgroundDiagnostics: (PhasedDiagnostic * FSharpErrorSeverity)[], - reactorOps: IReactorOperations, - // Used by 'FSharpDeclarationListInfo' to check the IncrementalBuilder is still alive. - checkAlive : (unit -> bool), - textSnapshotInfo : obj option, - userOpName: string) = - - async { - use _logBlock = Logger.LogBlock LogCompilerFunctionId.Service_CheckOneFile - - match parseResults.ParseTree with - // When processing the following cases, we don't need to type-check - | None -> return [||], TypeCheckAborted.Yes - - // Run the type checker... - | Some parsedMainInput -> - // Initialize the error handler - let errHandler = new ErrorHandler(true, mainInputFileName, tcConfig.errorSeverityOptions, source) - - use _unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _oldLogger -> errHandler.ErrorLogger) - use _unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck - - // Apply nowarns to tcConfig (may generate errors, so ensure errorLogger is installed) - let tcConfig = ApplyNoWarnsToTcConfig (tcConfig, parsedMainInput,Path.GetDirectoryName mainInputFileName) - - // update the error handler with the modified tcConfig - errHandler.ErrorSeverityOptions <- tcConfig.errorSeverityOptions - - // Play background errors and warnings for this file. - for (err,sev) in backgroundDiagnostics do - diagnosticSink (err, (sev = FSharpErrorSeverity.Error)) - - // If additional references were brought in by the preprocessor then we need to process them - match loadClosure with - | Some loadClosure -> - // Play unresolved references for this file. - tcImports.ReportUnresolvedAssemblyReferences(loadClosure.UnresolvedReferences) - - // If there was a loadClosure, replay the errors and warnings from resolution, excluding parsing - loadClosure.LoadClosureRootFileDiagnostics |> List.iter diagnosticSink - - let fileOfBackgroundError err = (match GetRangeOfDiagnostic (fst err) with Some m-> m.FileName | None -> null) - let sameFile file hashLoadInFile = - (0 = String.Compare(hashLoadInFile, file, StringComparison.OrdinalIgnoreCase)) - - // walk the list of #loads and keep the ones for this file. - let hashLoadsInFile = - loadClosure.SourceFiles - |> List.filter(fun (_,ms) -> ms<>[]) // #loaded file, ranges of #load - - let hashLoadBackgroundDiagnostics, otherBackgroundDiagnostics = - backgroundDiagnostics - |> Array.partition (fun backgroundError -> - hashLoadsInFile - |> List.exists (fst >> sameFile (fileOfBackgroundError backgroundError))) - - // Create single errors for the #load-ed files. - // Group errors and warnings by file name. - let hashLoadBackgroundDiagnosticsGroupedByFileName = - hashLoadBackgroundDiagnostics - |> Array.map(fun err -> fileOfBackgroundError err,err) - |> Array.groupBy fst // fileWithErrors, error list - - // Join the sets and report errors. - // It is by-design that these messages are only present in the language service. A true build would report the errors at their - // spots in the individual source files. - for (fileOfHashLoad, rangesOfHashLoad) in hashLoadsInFile do - for (file, errorGroupedByFileName) in hashLoadBackgroundDiagnosticsGroupedByFileName do - if sameFile file fileOfHashLoad then - for rangeOfHashLoad in rangesOfHashLoad do // Handle the case of two #loads of the same file - let diagnostics = errorGroupedByFileName |> Array.map(fun (_,(pe,f)) -> pe.Exception,f) // Strip the build phase here. It will be replaced, in total, with TypeCheck - let errors = [ for (err,sev) in diagnostics do if sev = FSharpErrorSeverity.Error then yield err ] - let warnings = [ for (err,sev) in diagnostics do if sev = FSharpErrorSeverity.Warning then yield err ] - - let message = HashLoadedSourceHasIssues(warnings,errors,rangeOfHashLoad) - if errors=[] then warning(message) - else errorR(message) - - // Replay other background errors. - for (phasedError,sev) in otherBackgroundDiagnostics do - if sev = FSharpErrorSeverity.Warning then - warning phasedError.Exception - else errorR phasedError.Exception - - | None -> - // For non-scripts, check for disallow #r and #load. - ApplyMetaCommandsFromInputToTcConfig (tcConfig, parsedMainInput,Path.GetDirectoryName mainInputFileName) |> ignore - - // 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. - // If we don't do this the NNG accumulates data and we get a memory leak. - tcState.NiceNameGenerator.Reset() - - // Typecheck the real input. - let sink = TcResultsSinkImpl(tcGlobals, source = source) - let! ct = Async.CancellationToken - - let! resOpt = - async { - try - let checkForErrors() = (parseResults.ParseHadErrors || errHandler.ErrorCount > 0) - - let parsedMainInput, _moduleNamesDict = DeduplicateParsedInputModuleName moduleNamesDict parsedMainInput - - // Typecheck is potentially a long running operation. We chop it up here with an Eventually continuation and, at each slice, give a chance - // for the client to claim the result as obsolete and have the typecheck abort. - - let! result = - TypeCheckOneInputAndFinishEventually(checkForErrors, tcConfig, tcImports, tcGlobals, None, TcResultsSink.WithSink sink, tcState, parsedMainInput) - |> Eventually.repeatedlyProgressUntilDoneOrTimeShareOverOrCanceled maxTimeShareMilliseconds ct (fun ctok f -> f ctok) - |> Eventually.forceAsync - (fun work -> - reactorOps.EnqueueAndAwaitOpAsync(userOpName, "CheckOneFile.Fragment", mainInputFileName, - fun ctok -> - // This work is not cancellable - let res = - // Reinstall the compilation globals each time we start or restart - use unwind = new CompilationGlobalsScope (errHandler.ErrorLogger, BuildPhase.TypeCheck) - work ctok - cancellable.Return(res) - )) - - return result |> Option.map (fun ((tcEnvAtEnd, _, implFiles, ccuSigsForFiles), tcState) -> tcEnvAtEnd, implFiles, ccuSigsForFiles, tcState) - with e -> - errorR e - return Some(tcState.TcEnvFromSignatures, [], [NewEmptyModuleOrNamespaceType Namespace], tcState) - } - - let errors = errHandler.CollectedDiagnostics - - match resOpt with - | Some (tcEnvAtEnd, implFiles, ccuSigsForFiles, tcState) -> - let scope = - TypeCheckInfo(tcConfig, tcGlobals, - List.head ccuSigsForFiles, - tcState.Ccu, - tcImports, - tcEnvAtEnd.AccessRights, - projectFileName, - mainInputFileName, - sink.GetResolutions(), - sink.GetSymbolUses(), - tcEnvAtEnd.NameEnv, - loadClosure, - reactorOps, - checkAlive, - textSnapshotInfo, - List.tryHead implFiles, - sink.GetOpenDeclarations()) - return errors, TypeCheckAborted.No scope - | None -> - return errors, TypeCheckAborted.Yes - } - -type UnresolvedReferencesSet = UnresolvedReferencesSet of UnresolvedAssemblyReference list - -// NOTE: may be better just to move to optional arguments here -type FSharpProjectOptions = - { - ProjectFileName: string - ProjectId: string option - SourceFiles: string[] - OtherOptions: string[] - ReferencedProjects: (string * FSharpProjectOptions)[] - IsIncompleteTypeCheckEnvironment : bool - UseScriptResolutionRules : bool - LoadTime : System.DateTime - UnresolvedReferences : UnresolvedReferencesSet option - OriginalLoadReferences: (range * string) list - ExtraProjectInfo : obj option - Stamp : int64 option - } - member x.ProjectOptions = x.OtherOptions - /// Whether the two parse options refer to the same project. - static member UseSameProject(options1,options2) = - match options1.ProjectId, options2.ProjectId with - | Some(projectId1), Some(projectId2) when not (String.IsNullOrWhiteSpace(projectId1)) && not (String.IsNullOrWhiteSpace(projectId2)) -> - projectId1 = projectId2 - | Some(_), Some(_) - | None, None -> options1.ProjectFileName = options2.ProjectFileName - | _ -> false - - /// Compare two options sets with respect to the parts of the options that are important to building. - static member AreSameForChecking(options1,options2) = - match options1.Stamp, options2.Stamp with - | Some x, Some y -> (x = y) - | _ -> - FSharpProjectOptions.UseSameProject(options1, options2) && - options1.SourceFiles = options2.SourceFiles && - options1.OtherOptions = options2.OtherOptions && - options1.UnresolvedReferences = options2.UnresolvedReferences && - options1.OriginalLoadReferences = options2.OriginalLoadReferences && - options1.ReferencedProjects.Length = options2.ReferencedProjects.Length && - Array.forall2 (fun (n1,a) (n2,b) -> - n1 = n2 && - FSharpProjectOptions.AreSameForChecking(a,b)) options1.ReferencedProjects options2.ReferencedProjects && - options1.LoadTime = options2.LoadTime - - /// Compute the project directory. - member po.ProjectDirectory = System.IO.Path.GetDirectoryName(po.ProjectFileName) - override this.ToString() = "FSharpProjectOptions(" + this.ProjectFileName + ")" - - -[] -type FSharpProjectContext(thisCcu: CcuThunk, assemblies: FSharpAssembly list, ad: AccessorDomain) = - - /// Get the assemblies referenced - member __.GetReferencedAssemblies() = assemblies - - member __.AccessibilityRights = FSharpAccessibilityRights(thisCcu, ad) - - -[] -// 'details' is an option because the creation of the tcGlobals etc. for the project may have failed. -type FSharpCheckProjectResults(projectFileName:string, tcConfigOption, keepAssemblyContents, errors: FSharpErrorInfo[], - details:(TcGlobals * TcImports * CcuThunk * ModuleOrNamespaceType * TcSymbolUses list * TopAttribs option * CompileOps.IRawFSharpAssemblyData option * ILAssemblyRef * AccessorDomain * TypedImplFile list option * string[]) option) = - - let getDetails() = - match details with - | None -> invalidOp ("The project has no results due to critical errors in the project options. Check the HasCriticalErrors before accessing the detailed results. Errors: " + String.concat "\n" [ for e in errors -> e.Message ]) - | Some d -> d - - let getTcConfig() = - match tcConfigOption with - | None -> invalidOp ("The project has no results due to critical errors in the project options. Check the HasCriticalErrors before accessing the detailed results. Errors: " + String.concat "\n" [ for e in errors -> e.Message ]) - | Some d -> d - - member info.Errors = errors - - member info.HasCriticalErrors = details.IsNone - - member info.AssemblySignature = - let (tcGlobals, tcImports, thisCcu, ccuSig, _tcSymbolUses, topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() - FSharpAssemblySignature(tcGlobals, thisCcu, ccuSig, tcImports, topAttribs, ccuSig) - - member info.TypedImplementionFiles = - if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to true on the FSharpChecker in order to access the checked contents of assemblies" - let (tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, tcAssemblyExpr, _dependencyFiles) = getDetails() - let mimpls = - match tcAssemblyExpr with - | None -> [] - | Some mimpls -> mimpls - tcGlobals, thisCcu, tcImports, mimpls - - member info.AssemblyContents = - if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to true on the FSharpChecker in order to access the checked contents of assemblies" - let (tcGlobals, tcImports, thisCcu, ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, tcAssemblyExpr, _dependencyFiles) = getDetails() - let mimpls = - match tcAssemblyExpr with - | None -> [] - | Some mimpls -> mimpls - FSharpAssemblyContents(tcGlobals, thisCcu, Some ccuSig, tcImports, mimpls) - - member info.GetOptimizedAssemblyContents() = - if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to true on the FSharpChecker in order to access the checked contents of assemblies" - let (tcGlobals, tcImports, thisCcu, ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, tcAssemblyExpr, _dependencyFiles) = getDetails() - let mimpls = - match tcAssemblyExpr with - | None -> [] - | Some mimpls -> mimpls - let outfile = "" // only used if tcConfig.writeTermsToFiles is true - let importMap = tcImports.GetImportMap() - let optEnv0 = GetInitialOptimizationEnv (tcImports, tcGlobals) - let tcConfig = getTcConfig() - let optimizedImpls, _optimizationData, _ = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, thisCcu, mimpls) - let mimpls = - match optimizedImpls with - | TypedAssemblyAfterOptimization files -> - files |> List.map fst - - FSharpAssemblyContents(tcGlobals, thisCcu, Some ccuSig, tcImports, mimpls) - - // Not, this does not have to be a SyncOp, it can be called from any thread - member info.GetUsesOfSymbol(symbol:FSharpSymbol) = - let (tcGlobals, _tcImports, _thisCcu, _ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() - - tcSymbolUses - |> Seq.collect (fun r -> r.GetUsesOfSymbol symbol.Item) - |> Seq.distinctBy (fun symbolUse -> symbolUse.ItemOccurence, symbolUse.Range) - |> Seq.filter (fun symbolUse -> symbolUse.ItemOccurence <> ItemOccurence.RelatedText) - |> Seq.map (fun symbolUse -> FSharpSymbolUse(tcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range)) - |> Seq.toArray - |> async.Return - - // Not, this does not have to be a SyncOp, it can be called from any thread - member __.GetAllUsesOfAllSymbols() = - let (tcGlobals, tcImports, thisCcu, ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() - let cenv = SymbolEnv(tcGlobals, thisCcu, Some ccuSig, tcImports) - - [| for r in tcSymbolUses do +// 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 Microsoft.FSharp.Compiler.SourceCodeServices + +open Internal.Utilities +open Internal.Utilities.Collections + +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 Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library + +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.CompileOptions +#if !FABLE_COMPILER +open Microsoft.FSharp.Compiler.Driver +#endif +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.Parser +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Lexhelp +open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.TypeChecker +open Microsoft.FSharp.Compiler.SourceCodeServices.SymbolHelpers + +open Microsoft.FSharp.Compiler.Layout.TaggedTextOps + +#if FX_RESHAPED_REFLECTION +open Microsoft.FSharp.Core.ReflectionAdapters +#endif + +type internal Layout = StructuredFormat.Layout + +[] +module EnvMisc = + let getToolTipTextSize = GetEnvInteger "FCS_GetToolTipTextCacheSize" 5 + let maxTypeCheckErrorsOutOfProjectContext = GetEnvInteger "FCS_MaxErrorsOutOfProjectContext" 3 + let braceMatchCacheSize = GetEnvInteger "FCS_BraceMatchCacheSize" 5 + let parseFileCacheSize = GetEnvInteger "FCS_ParseFileCacheSize" 2 + let checkFileInProjectCacheSize = GetEnvInteger "FCS_CheckFileInProjectCacheSize" 10 + + let projectCacheSizeDefault = GetEnvInteger "FCS_ProjectCacheSizeDefault" 3 + let frameworkTcImportsCacheStrongSize = GetEnvInteger "FCS_frameworkTcImportsCacheStrongSizeDefault" 8 + let maxMBDefault = GetEnvInteger "FCS_MaxMB" 1000000 // a million MB = 1TB = disabled + //let maxMBDefault = GetEnvInteger "FCS_maxMB" (if sizeof = 4 then 1700 else 3400) + + /// Maximum time share for a piece of background work before it should (cooperatively) yield + /// 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 = int64 (GetEnvInteger "FCS_MaxTimeShare" 100) + + +//---------------------------------------------------------------------------- +// Scopes. +//-------------------------------------------------------------------------- + +[] +type FSharpFindDeclFailureReason = + // generic reason: no particular information about error + | Unknown of message: string + // source code file is not available + | NoSourceCode + // trying to find declaration of ProvidedType without TypeProviderDefinitionLocationAttribute + | ProvidedType of string + // trying to find declaration of ProvidedMember without TypeProviderDefinitionLocationAttribute + | ProvidedMember of string + +[] +type FSharpFindDeclResult = + /// declaration not found + reason + | DeclNotFound of FSharpFindDeclFailureReason + /// found declaration + | DeclFound of range + /// Indicates an external declaration was found + | ExternalDecl of assembly : string * externalSym : ExternalSymbol + +/// This type is used to describe what was found during the name resolution. +/// (Depending on the kind of the items, we may stop processing or continue to find better items) +[] +[] +type internal NameResResult = + | Members of (ItemWithInst list * DisplayEnv * range) + | Cancel of DisplayEnv * range + | Empty + | TypecheckStaleAndTextChanged + + +[] +type ResolveOverloads = +| Yes +| No + +[] +type GetPreciseCompletionListFromExprTypingsResult = + | NoneBecauseTypecheckIsStaleAndTextChanged + | NoneBecauseThereWereTypeErrors + | None + | Some of (ItemWithInst list * DisplayEnv * range) * TType + +type Names = string list + +[] +type SemanticClassificationType = + | ReferenceType + | ValueType + | UnionCase + | Function + | Property + | MutableVar + | Module + | Printf + | ComputationExpression + | IntrinsicFunction + | Enumeration + | Interface + | TypeArgument + | Operator + | Disposable + +/// A TypeCheckInfo represents everything we get back from the typecheck of a file. +/// It acts like an in-memory database about the file. +/// It is effectively immutable and not updated: when we re-typecheck we just drop the previous +/// scope object on the floor and make a new one. +[] +type TypeCheckInfo + (// Information corresponding to miscellaneous command-line options (--define, etc). + _sTcConfig: TcConfig, + g: TcGlobals, + // The signature of the assembly being checked, up to and including the current file + ccuSigForFile: ModuleOrNamespaceType, + thisCcu: CcuThunk, + tcImports: TcImports, + tcAccessRights: AccessorDomain, + projectFileName: string, + mainInputFileName: string, + sResolutions: TcResolutions, + sSymbolUses: TcSymbolUses, + // This is a name resolution environment to use if no better match can be found. + sFallback: NameResolutionEnv, + loadClosure : LoadClosure option, + reactorOps : IReactorOperations, + checkAlive : (unit -> bool), + textSnapshotInfo:obj option, + implFileOpt: TypedImplFile option, + openDeclarations: OpenDeclaration[]) = + + let textSnapshotInfo = defaultArg textSnapshotInfo null + let (|CNR|) (cnr:CapturedNameResolution) = + (cnr.Pos, cnr.Item, cnr.ItemOccurence, cnr.DisplayEnv, cnr.NameResolutionEnv, cnr.AccessorDomain, cnr.Range) + + // These strings are potentially large and the editor may choose to hold them for a while. + // Use this cache to fold together data tip text results that are the same. + // Is not keyed on 'Names' collection because this is invariant for the current position in + // this unchanged file. Keyed on lineStr though to prevent a change to the currently line + // being available against a stale scope. + let getToolTipTextCache = AgedLookup>(getToolTipTextSize,areSimilar=(fun (x,y) -> x = y)) + + let amap = tcImports.GetImportMap() + let infoReader = new InfoReader(g,amap) + let ncenv = new NameResolver(g,amap,infoReader,NameResolution.FakeInstantiationGenerator) + let cenv = SymbolEnv(g, thisCcu, Some ccuSigForFile, tcImports, amap, infoReader) + + /// Find the most precise naming environment for the given line and column + let GetBestEnvForPos cursorPos = + + let mutable bestSoFar = None + + // Find the most deeply nested enclosing scope that contains given position + sResolutions.CapturedEnvs |> ResizeArray.iter (fun (possm,env,ad) -> + if rangeContainsPos possm cursorPos then + match bestSoFar with + | Some (bestm,_,_) -> + if rangeContainsRange bestm possm then + bestSoFar <- Some (possm,env,ad) + | None -> + bestSoFar <- Some (possm,env,ad)) + + let mostDeeplyNestedEnclosingScope = bestSoFar + + // Look for better subtrees on the r.h.s. of the subtree to the left of where we are + // Should really go all the way down the r.h.s. of the subtree to the left of where we are + // This is all needed when the index is floating free in the area just after the environment we really want to capture + // We guarantee to only refine to a more nested environment. It may not be strictly + // the right environment, but will always be at least as rich + + let bestAlmostIncludedSoFar = ref None + + sResolutions.CapturedEnvs |> ResizeArray.iter (fun (possm,env,ad) -> + // take only ranges that strictly do not include cursorPos (all ranges that touch cursorPos were processed during 'Strict Inclusion' part) + if rangeBeforePos possm cursorPos && not (posEq possm.End cursorPos) then + let contained = + match mostDeeplyNestedEnclosingScope with + | Some (bestm,_,_) -> rangeContainsRange bestm possm + | None -> true + + if contained then + match !bestAlmostIncludedSoFar with + | Some (rightm:range,_,_) -> + if posGt possm.End rightm.End || + (posEq possm.End rightm.End && posGt possm.Start rightm.Start) then + bestAlmostIncludedSoFar := Some (possm,env,ad) + | _ -> bestAlmostIncludedSoFar := Some (possm,env,ad)) + + let resEnv = + match !bestAlmostIncludedSoFar, mostDeeplyNestedEnclosingScope with + | Some (_,env,ad), None -> env, ad + | Some (_,almostIncludedEnv,ad), Some (_,mostDeeplyNestedEnv,_) + when almostIncludedEnv.eFieldLabels.Count >= mostDeeplyNestedEnv.eFieldLabels.Count -> + almostIncludedEnv,ad + | _ -> + match mostDeeplyNestedEnclosingScope with + | Some (_,env,ad) -> + env,ad + | None -> + sFallback,AccessibleFromSomeFSharpCode + let pm = mkRange mainInputFileName cursorPos cursorPos + + resEnv,pm + + /// The items that come back from ResolveCompletionsInType are a bit + /// noisy. Filter a few things out. + /// + /// e.g. prefer types to constructors for FSharpToolTipText + let FilterItemsForCtors filterCtors (items: ItemWithInst list) = + let items = items |> List.filter (fun item -> match item.Item with (Item.CtorGroup _) when filterCtors = ResolveTypeNamesToTypeRefs -> false | _ -> true) + items + + // Filter items to show only valid & return Some if there are any + let ReturnItemsOfType (items: ItemWithInst list) g denv (m:range) filterCtors hasTextChangedSinceLastTypecheck = + let items = + items + |> RemoveDuplicateItems g + |> RemoveExplicitlySuppressed g + |> FilterItemsForCtors filterCtors + + if not (isNil items) then + if hasTextChangedSinceLastTypecheck(textSnapshotInfo, m) then + NameResResult.TypecheckStaleAndTextChanged // typecheck is stale, wait for second-chance IntelliSense to bring up right result + else + NameResResult.Members (items, denv, m) + else NameResResult.Empty + + let GetCapturedNameResolutions endOfNamesPos resolveOverloads = + + let quals = + match resolveOverloads with + | ResolveOverloads.Yes -> sResolutions.CapturedNameResolutions + | ResolveOverloads.No -> sResolutions.CapturedMethodGroupResolutions + + let quals = quals |> ResizeArray.filter (fun cnr -> posEq cnr.Pos endOfNamesPos) + + quals + + /// Looks at the exact name resolutions that occurred during type checking + /// If 'membersByResidue' is specified, we look for members of the item obtained + /// from the name resolution and filter them by the specified residue (?) + let GetPreciseItemsFromNameResolution(line, colAtEndOfNames, membersByResidue, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck) = + let endOfNamesPos = mkPos line colAtEndOfNames + + // Logic below expects the list to be in reverse order of resolution + let cnrs = GetCapturedNameResolutions endOfNamesPos resolveOverloads |> ResizeArray.toList |> List.rev + + match cnrs, membersByResidue with + + // If we're looking for members using a residue, we'd expect only + // a single item (pick the first one) and we need the residue (which may be "") + | CNR(_,Item.Types(_,(ty::_)), _, denv, nenv, ad, m)::_, Some _ -> + let items = ResolveCompletionsInType ncenv nenv (ResolveCompletionTargets.All(ConstraintSolver.IsApplicableMethApprox g amap m)) m ad true ty + let items = List.map ItemWithNoInst items + ReturnItemsOfType items g denv m filterCtors hasTextChangedSinceLastTypecheck + + // Value reference from the name resolution. Primarily to disallow "let x.$ = 1" + // In most of the cases, value references can be obtained from expression typings or from environment, + // so we wouldn't have to handle values here. However, if we have something like: + // let varA = "string" + // let varA = if b then 0 else varA. + // then the expression typings get confused (thinking 'varA:int'), so we use name resolution even for usual values. + + | CNR(_, Item.Value(vref), occurence, denv, nenv, ad, m)::_, Some _ -> + if (occurence = ItemOccurence.Binding || occurence = ItemOccurence.Pattern) then + // Return empty list to stop further lookup - for value declarations + NameResResult.Cancel(denv, m) + else + // If we have any valid items for the value, then return completions for its type now. + // Adjust the type in case this is the 'this' pointer stored in a reference cell. + let ty = StripSelfRefCell(g, vref.BaseOrThisInfo, vref.TauType) + // patch accessibility domain to remove protected members if accessing NormalVal + let ad = + match vref.BaseOrThisInfo, ad with + | ValBaseOrThisInfo.NormalVal, AccessibleFrom(paths, Some tcref) -> + let tcref = generalizedTyconRef tcref + // check that type of value is the same or subtype of tcref + // yes - allow access to protected members + // no - strip ability to access protected members + if Microsoft.FSharp.Compiler.TypeRelations.TypeFeasiblySubsumesType 0 g amap m tcref Microsoft.FSharp.Compiler.TypeRelations.CanCoerce ty then + ad + else + AccessibleFrom(paths, None) + | _ -> ad + + let items = ResolveCompletionsInType ncenv nenv (ResolveCompletionTargets.All(ConstraintSolver.IsApplicableMethApprox g amap m)) m ad false ty + let items = List.map ItemWithNoInst items + ReturnItemsOfType items g denv m filterCtors hasTextChangedSinceLastTypecheck + + // No residue, so the items are the full resolution of the name + | CNR(_, _, _, denv, _, _, m) :: _, None -> + let items = + cnrs + |> List.map (fun cnr -> cnr.ItemWithInst) + // "into" is special magic syntax, not an identifier or a library call. It is part of capturedNameResolutions as an + // implementation detail of syntax coloring, but we should not report name resolution results for it, to prevent spurious QuickInfo. + |> List.filter (fun item -> match item.Item with Item.CustomOperation(CustomOperations.Into,_,_) -> false | _ -> true) + ReturnItemsOfType items g denv m filterCtors hasTextChangedSinceLastTypecheck + | _, _ -> NameResResult.Empty + + let TryGetTypeFromNameResolution(line, colAtEndOfNames, membersByResidue, resolveOverloads) = + let endOfNamesPos = mkPos line colAtEndOfNames + let items = GetCapturedNameResolutions endOfNamesPos resolveOverloads |> ResizeArray.toList |> List.rev + + match items, membersByResidue with + | CNR(_,Item.Types(_,(ty::_)),_,_,_,_,_)::_, Some _ -> Some ty + | CNR(_, Item.Value(vref), occurence,_,_,_,_)::_, Some _ -> + if (occurence = ItemOccurence.Binding || occurence = ItemOccurence.Pattern) then None + else Some (StripSelfRefCell(g, vref.BaseOrThisInfo, vref.TauType)) + | _, _ -> None + + let CollectParameters (methods: MethInfo list) amap m: Item list = + methods + |> List.collect (fun meth -> + match meth.GetParamDatas(amap, m, meth.FormalMethodInst) with + | x::_ -> x |> List.choose(fun (ParamData(_isParamArray, _isInArg, _isOutArg, _optArgInfo, _callerInfo, name, _, ty)) -> + match name with + | Some n -> Some (Item.ArgName(n, ty, Some (ArgumentContainer.Method meth))) + | None -> None + ) + | _ -> [] + ) + + let GetNamedParametersAndSettableFields endOfExprPos hasTextChangedSinceLastTypecheck = + let cnrs = GetCapturedNameResolutions endOfExprPos ResolveOverloads.No |> ResizeArray.toList |> List.rev + let result = + match cnrs with + | CNR(_, Item.CtorGroup(_, ((ctor::_) as ctors)), _, denv, nenv, ad, m) ::_ -> + let props = ResolveCompletionsInType ncenv nenv ResolveCompletionTargets.SettablePropertiesAndFields m ad false ctor.ApparentEnclosingType + let parameters = CollectParameters ctors amap m + let items = props @ parameters + Some (denv, m, items) + | CNR(_, Item.MethodGroup(_, methods, _), _, denv, nenv, ad, m) ::_ -> + let props = + methods + |> List.collect (fun meth -> + let retTy = meth.GetFSharpReturnTy(amap, m, meth.FormalMethodInst) + ResolveCompletionsInType ncenv nenv ResolveCompletionTargets.SettablePropertiesAndFields m ad false retTy + ) + let parameters = CollectParameters methods amap m + let items = props @ parameters + Some (denv, m, items) + | _ -> + None + match result with + | None -> + NameResResult.Empty + | Some (denv, m, items) -> + let items = List.map ItemWithNoInst items + ReturnItemsOfType items g denv m TypeNameResolutionFlag.ResolveTypeNamesToTypeRefs hasTextChangedSinceLastTypecheck + + /// finds captured typing for the given position + let GetExprTypingForPosition(endOfExprPos) = + let quals = + sResolutions.CapturedExpressionTypings + |> Seq.filter (fun (pos,ty,denv,_,_,_) -> + // We only want expression types that end at the particular position in the file we are looking at. + let isLocationWeCareAbout = posEq pos endOfExprPos + // Get rid of function types. True, given a 2-arg curried function "f x y", it is legal to do "(f x).GetType()", + // but you almost never want to do this in practice, and we choose not to offer up any intellisense for + // F# function types. + let isFunction = isFunTy denv.g ty + isLocationWeCareAbout && not isFunction) + |> Seq.toArray + + let thereWereSomeQuals = not (Array.isEmpty quals) + // filter out errors + + let quals = quals + |> Array.filter (fun (_,ty,denv,_,_,_) -> not (isTyparTy denv.g ty && (destTyparTy denv.g ty).IsFromError)) + thereWereSomeQuals, quals + + /// obtains captured typing for the given position + /// if type of captured typing is record - returns list of record fields + let GetRecdFieldsForExpr(r : range) = + let _, quals = GetExprTypingForPosition(r.End) + let bestQual = + match quals with + | [||] -> None + | quals -> + quals |> Array.tryFind (fun (_,_,_,_,_,rq) -> + ignore(r) // for breakpoint + posEq r.Start rq.Start) + match bestQual with + | Some (_,ty,denv,_nenv,ad,m) when isRecdTy denv.g ty -> + let items = NameResolution.ResolveRecordOrClassFieldsOfType ncenv m ad ty false + Some (items, denv, m) + | _ -> None + + /// Looks at the exact expression types at the position to the left of the + /// residue then the source when it was typechecked. + let GetPreciseCompletionListFromExprTypings(parseResults:FSharpParseFileResults, endOfExprPos, filterCtors, hasTextChangedSinceLastTypecheck: (obj * range -> bool)) = + + let thereWereSomeQuals, quals = GetExprTypingForPosition(endOfExprPos) + + match quals with + | [| |] -> + if thereWereSomeQuals then + GetPreciseCompletionListFromExprTypingsResult.NoneBecauseThereWereTypeErrors + else + GetPreciseCompletionListFromExprTypingsResult.None + | _ -> + let bestQual, textChanged = + match parseResults.ParseTree with + | Some(input) -> + match UntypedParseImpl.GetRangeOfExprLeftOfDot(endOfExprPos,Some(input)) with // TODO we say "colAtEndOfNames" everywhere, but that's not really a good name ("foo . $" hit Ctrl-Space at $) + | Some( exprRange) -> + if hasTextChangedSinceLastTypecheck(textSnapshotInfo, exprRange) then + None, true // typecheck is stale, wait for second-chance IntelliSense to bring up right result + else + // See bug 130733. We have an up-to-date sync parse, and know the exact range of the prior expression. + // The quals all already have the same ending position, so find one with a matching starting position, if it exists. + // If not, then the stale typecheck info does not have a capturedExpressionTyping for this exact expression, and the + // user can wait for typechecking to catch up and second-chance intellisense to give the right result. + let qual = + quals |> Array.tryFind (fun (_,_,_,_,_,r) -> + ignore(r) // for breakpoint + posEq exprRange.Start r.Start) + qual, false + | None -> + // TODO In theory I think we should never get to this code path; it would be nice to add an assert. + // In practice, we do get here in some weird cases like "2.0 .. 3.0" and hitting Ctrl-Space in between the two dots of the range operator. + // I wasn't able to track down what was happening in those weird cases, not worth worrying about, it doesn't manifest as a product bug or anything. + None, false + | _ -> None, false + + match bestQual with + | Some bestQual -> + let (_,ty,denv,nenv,ad,m) = bestQual + let items = ResolveCompletionsInType ncenv nenv (ResolveCompletionTargets.All(ConstraintSolver.IsApplicableMethApprox g amap m)) m ad false ty + let items = items |> List.map ItemWithNoInst + let items = items |> RemoveDuplicateItems g + let items = items |> RemoveExplicitlySuppressed g + let items = items |> FilterItemsForCtors filterCtors + GetPreciseCompletionListFromExprTypingsResult.Some((items,denv,m), ty) + | None -> + if textChanged then GetPreciseCompletionListFromExprTypingsResult.NoneBecauseTypecheckIsStaleAndTextChanged + else GetPreciseCompletionListFromExprTypingsResult.None + + /// Find items in the best naming environment. + let GetEnvironmentLookupResolutions(nenv, ad, m, plid, filterCtors, showObsolete) = + let items = NameResolution.ResolvePartialLongIdent ncenv nenv (ConstraintSolver.IsApplicableMethApprox g amap m) m ad plid showObsolete + let items = items |> List.map ItemWithNoInst + let items = items |> RemoveDuplicateItems g + let items = items |> RemoveExplicitlySuppressed g + let items = items |> FilterItemsForCtors filterCtors + (items, nenv.DisplayEnv, m) + + /// Find items in the best naming environment. + let GetEnvironmentLookupResolutionsAtPosition(cursorPos, plid, filterCtors, showObsolete) = + let (nenv,ad),m = GetBestEnvForPos cursorPos + GetEnvironmentLookupResolutions(nenv, ad, m, plid, filterCtors, showObsolete) + + /// Find record fields in the best naming environment. + let GetClassOrRecordFieldsEnvironmentLookupResolutions(cursorPos, plid) = + let (nenv, ad),m = GetBestEnvForPos cursorPos + let items = NameResolution.ResolvePartialLongIdentToClassOrRecdFields ncenv nenv m ad plid false + let items = items |> List.map ItemWithNoInst + let items = items |> RemoveDuplicateItems g + let items = items |> RemoveExplicitlySuppressed g + items, nenv.DisplayEnv, m + + /// Resolve a location and/or text to items. + // Three techniques are used + // - look for an exact known name resolution from type checking + // - use the known type of an expression, e.g. (expr).Name, to generate an item list + // - lookup an entire name in the name resolution environment, e.g. A.B.Name, to generate an item list + // + // The overall aim is to resolve as accurately as possible based on what we know from type inference + + let GetBaseClassCandidates = function + | Item.ModuleOrNamespaces _ -> true + | Item.Types(_, ty::_) when (isClassTy g ty) && not (isSealedTy g ty) -> true + | _ -> false + + let GetInterfaceCandidates = function + | Item.ModuleOrNamespaces _ -> true + | Item.Types(_, ty::_) when (isInterfaceTy g ty) -> true + | _ -> false + + + // Return only items with the specified name + let FilterDeclItemsByResidue (getItem: 'a -> Item) residue (items: 'a list) = + let attributedResidue = residue + "Attribute" + let nameMatchesResidue name = (residue = name) || (attributedResidue = name) + + items |> List.filter (fun x -> + let item = getItem x + let n1 = item.DisplayName + match item with + | Item.Types _ -> nameMatchesResidue n1 + | Item.CtorGroup (_, meths) -> + nameMatchesResidue n1 || + meths |> List.exists (fun meth -> + let tcref = meth.ApparentEnclosingTyconRef +#if !NO_EXTENSIONTYPING + tcref.IsProvided || +#endif + nameMatchesResidue tcref.DisplayName) + | _ -> residue = n1) + + /// Post-filter items to make sure they have precisely the right name + /// This also checks that there are some remaining results + /// exactMatchResidueOpt = Some _ -- means that we are looking for exact matches + let FilterRelevantItemsBy (getItem: 'a -> Item) (exactMatchResidueOpt : _ option) check (items: 'a list, denv, m) = + + // can throw if type is in located in non-resolved CCU: i.e. bigint if reference to System.Numerics is absent + let safeCheck item = try check item with _ -> false + + // Are we looking for items with precisely the given name? + if not (isNil items) && exactMatchResidueOpt.IsSome then + let items = items |> FilterDeclItemsByResidue getItem exactMatchResidueOpt.Value |> List.filter safeCheck + if not (isNil items) then Some(items, denv, m) else None + else + // When (items = []) we must returns Some([],..) and not None + // because this value is used if we want to stop further processing (e.g. let x.$ = ...) + let items = items |> List.filter safeCheck + Some(items, denv, m) + + /// Post-filter items to make sure they have precisely the right name + /// This also checks that there are some remaining results + let (|FilterRelevantItems|_|) getItem exactMatchResidueOpt orig = + FilterRelevantItemsBy getItem exactMatchResidueOpt (fun _ -> true) orig + + /// Find the first non-whitespace position in a line prior to the given character + let FindFirstNonWhitespacePosition (lineStr: string) i = + if i >= lineStr.Length then None + else + let mutable p = i + while p >= 0 && System.Char.IsWhiteSpace(lineStr.[p]) do + p <- p - 1 + if p >= 0 then Some p else None + + let CompletionItem (ty: ValueOption) (assemblySymbol: ValueOption) (item: ItemWithInst) = + let kind = + match item.Item with + | Item.MethodGroup (_, minfo :: _, _) -> CompletionItemKind.Method minfo.IsExtensionMember + | Item.RecdField _ + | Item.Property _ -> CompletionItemKind.Property + | Item.Event _ -> CompletionItemKind.Event + | Item.ILField _ + | Item.Value _ -> CompletionItemKind.Field + | Item.CustomOperation _ -> CompletionItemKind.CustomOperation + | _ -> CompletionItemKind.Other + + { ItemWithInst = item + MinorPriority = 0 + Kind = kind + IsOwnMember = false + Type = match ty with ValueSome x -> Some x | _ -> None + Unresolved = match assemblySymbol with ValueSome x -> Some x.UnresolvedSymbol | _ -> None } + + let DefaultCompletionItem item = CompletionItem ValueNone ValueNone item + + let getItem (x: ItemWithInst) = x.Item + let GetDeclaredItems (parseResultsOpt: FSharpParseFileResults option, lineStr: string, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, + filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck, isInRangeOperator, allSymbols: unit -> AssemblySymbol list) = + + // Are the last two chars (except whitespaces) = ".." + let isLikeRangeOp = + match FindFirstNonWhitespacePosition lineStr (colAtEndOfNamesAndResidue - 1) with + | Some x when x >= 1 && lineStr.[x] = '.' && lineStr.[x - 1] = '.' -> true + | _ -> false + + // if last two chars are .. and we are not in range operator context - no completion + if isLikeRangeOp && not isInRangeOperator then None else + + // Try to use the exact results of name resolution during type checking to generate the results + // This is based on position (i.e. colAtEndOfNamesAndResidue). This is not used if a residueOpt is given. + let nameResItems = + match residueOpt with + | None -> GetPreciseItemsFromNameResolution(line, colAtEndOfNamesAndResidue, None, filterCtors,resolveOverloads, hasTextChangedSinceLastTypecheck) + | Some residue -> + // deals with cases when we have spaces between dot and\or identifier, like A . $ + // if this is our case - then we need to locate end position of the name skipping whitespaces + // this allows us to handle cases like: let x . $ = 1 + match lastDotPos |> Option.orElseWith (fun _ -> FindFirstNonWhitespacePosition lineStr (colAtEndOfNamesAndResidue - 1)) with + | Some p when lineStr.[p] = '.' -> + match FindFirstNonWhitespacePosition lineStr (p - 1) with + | Some colAtEndOfNames -> + let colAtEndOfNames = colAtEndOfNames + 1 // convert 0-based to 1-based + GetPreciseItemsFromNameResolution(line, colAtEndOfNames, Some(residue), filterCtors,resolveOverloads, hasTextChangedSinceLastTypecheck) + | None -> NameResResult.Empty + | _ -> NameResResult.Empty + + // Normalize to form A.B.C.D where D is the residue. It may be empty for "A.B.C." + // residueOpt = Some when we are looking for the exact match + let plid, exactMatchResidueOpt = + match origLongIdentOpt, residueOpt with + | None, _ -> [], None + | Some(origLongIdent), Some _ -> origLongIdent, None + | Some(origLongIdent), None -> + System.Diagnostics.Debug.Assert(not (isNil origLongIdent), "origLongIdent is empty") + // note: as above, this happens when we are called for "precise" resolution - (F1 keyword, data tip etc..) + let plid, residue = List.frontAndBack origLongIdent + plid, Some residue + + let pos = mkPos line loc + let (nenv, ad), m = GetBestEnvForPos pos + + let getType() = + match NameResolution.TryToResolveLongIdentAsType ncenv nenv m plid with + | Some x -> tryDestAppTy g x + | None -> + match lastDotPos |> Option.orElseWith (fun _ -> FindFirstNonWhitespacePosition lineStr (colAtEndOfNamesAndResidue - 1)) with + | Some p when lineStr.[p] = '.' -> + match FindFirstNonWhitespacePosition lineStr (p - 1) with + | Some colAtEndOfNames -> + let colAtEndOfNames = colAtEndOfNames + 1 // convert 0-based to 1-based + match TryGetTypeFromNameResolution(line, colAtEndOfNames, residueOpt, resolveOverloads) with + | Some x -> tryDestAppTy g x + | _ -> ValueNone + | None -> ValueNone + | _ -> ValueNone + + match nameResItems with + | NameResResult.TypecheckStaleAndTextChanged -> None // second-chance intellisense will try again + | NameResResult.Cancel(denv,m) -> Some([], denv, m) + | NameResResult.Members(FilterRelevantItems getItem exactMatchResidueOpt (items, denv, m)) -> + // lookup based on name resolution results successful + Some (items |> List.map (CompletionItem (getType()) ValueNone), denv, m) + | _ -> + match origLongIdentOpt with + | None -> None + | Some _ -> + + // Try to use the type of the expression on the left to help generate a completion list + let qualItems, thereIsADotInvolved = + match parseResultsOpt with + | None -> + // Note, you will get here if the 'reason' is not CompleteWord/MemberSelect/DisplayMemberList, as those are currently the + // only reasons we do a sync parse to have the most precise and likely-to-be-correct-and-up-to-date info. So for example, + // if you do QuickInfo hovering over A in "f(x).A()", you will only get a tip if typechecking has a name-resolution recorded + // for A, not if merely we know the capturedExpressionTyping of f(x) and you very recently typed ".A()" - in that case, + // you won't won't get a tip until the typechecking catches back up. + GetPreciseCompletionListFromExprTypingsResult.None, false + | Some parseResults -> + + match UntypedParseImpl.TryFindExpressionASTLeftOfDotLeftOfCursor(mkPos line colAtEndOfNamesAndResidue,parseResults.ParseTree) with + | Some(pos,_) -> + GetPreciseCompletionListFromExprTypings(parseResults, pos, filterCtors, hasTextChangedSinceLastTypecheck), true + | None -> + // Can get here in a case like: if "f xxx yyy" is legal, and we do "f xxx y" + // We have no interest in expression typings, those are only useful for dot-completion. We want to fallback + // to "Use an environment lookup as the last resort" below + GetPreciseCompletionListFromExprTypingsResult.None, false + + match qualItems,thereIsADotInvolved with + | GetPreciseCompletionListFromExprTypingsResult.Some(FilterRelevantItems getItem exactMatchResidueOpt (items, denv, m), ty), _ + // Initially we only use the expression typings when looking up, e.g. (expr).Nam or (expr).Name1.Nam + // These come through as an empty plid and residue "". Otherwise we try an environment lookup + // and then return to the qualItems. This is because the expression typings are a little inaccurate, primarily because + // it appears we're getting some typings recorded for non-atomic expressions like "f x" + when isNil plid -> + // lookup based on expression typings successful + Some (items |> List.map (CompletionItem (tryDestAppTy g ty) ValueNone), denv, m) + | GetPreciseCompletionListFromExprTypingsResult.NoneBecauseThereWereTypeErrors, _ -> + // There was an error, e.g. we have "." and there is an error determining the type of + // In this case, we don't want any of the fallback logic, rather, we want to produce zero results. + None + | GetPreciseCompletionListFromExprTypingsResult.NoneBecauseTypecheckIsStaleAndTextChanged, _ -> + // we want to report no result and let second-chance intellisense kick in + None + | _, true when isNil plid -> + // If the user just pressed '.' after an _expression_ (not a plid), it is never right to show environment-lookup top-level completions. + // The user might by typing quickly, and the LS didn't have an expression type right before the dot yet. + // Second-chance intellisense will bring up the correct list in a moment. + None + | _ -> + // Use an environment lookup as the last resort + let envItems, denv, m = GetEnvironmentLookupResolutions(nenv, ad, m, plid, filterCtors, residueOpt.IsSome) + + let envResult = + match nameResItems, (envItems, denv, m), qualItems with + + // First, use unfiltered name resolution items, if they're not empty + | NameResResult.Members(items, denv, m), _, _ when not (isNil items) -> + // lookup based on name resolution results successful + ValueSome(items |> List.map (CompletionItem (getType()) ValueNone), denv, m) + + // If we have nonempty items from environment that were resolved from a type, then use them... + // (that's better than the next case - here we'd return 'int' as a type) + | _, FilterRelevantItems getItem exactMatchResidueOpt (items, denv, m), _ when not (isNil items) -> + // lookup based on name and environment successful + ValueSome(items |> List.map (CompletionItem (getType()) ValueNone), denv, m) + + // Try again with the qualItems + | _, _, GetPreciseCompletionListFromExprTypingsResult.Some(FilterRelevantItems getItem exactMatchResidueOpt (items, denv, m), ty) -> + ValueSome(items |> List.map (CompletionItem (tryDestAppTy g ty) ValueNone), denv, m) + + | _ -> ValueNone + + let globalResult = + match origLongIdentOpt with + | None | Some [] -> + let globalItems = + allSymbols() + |> List.filter (fun x -> not x.Symbol.IsExplicitlySuppressed) + |> List.filter (fun x -> + match x.Symbol with + | :? FSharpMemberOrFunctionOrValue as m when m.IsConstructor && filterCtors = ResolveTypeNamesToTypeRefs -> false + | _ -> true) + + let getItem (x: AssemblySymbol) = x.Symbol.Item + + match globalItems, denv, m with + | FilterRelevantItems getItem exactMatchResidueOpt (globalItemsFiltered, denv, m) when not (isNil globalItemsFiltered) -> + globalItemsFiltered + |> List.map(fun globalItem -> CompletionItem (getType()) (ValueSome globalItem) (ItemWithNoInst globalItem.Symbol.Item)) + |> fun r -> ValueSome(r, denv, m) + | _ -> ValueNone + | _ -> ValueNone // do not return unresolved items after dot + + match envResult, globalResult with + | ValueSome (items, denv, m), ValueSome (gItems,_,_) -> Some (items @ gItems, denv, m) + | ValueSome x, ValueNone -> Some x + | ValueNone, ValueSome y -> Some y + | ValueNone, ValueNone -> None + + + let toCompletionItems (items: ItemWithInst list, denv: DisplayEnv, m: range ) = + items |> List.map DefaultCompletionItem, denv, m + + /// Get the auto-complete items at a particular location. + let GetDeclItemsForNamesAtPosition(ctok: CompilationThreadToken, parseResultsOpt: FSharpParseFileResults option, origLongIdentOpt: string list option, + residueOpt:string option, lastDotPos: int option, line:int, lineStr:string, colAtEndOfNamesAndResidue, filterCtors, resolveOverloads, + getAllSymbols: unit -> AssemblySymbol list, hasTextChangedSinceLastTypecheck: (obj * range -> bool)) + : (CompletionItem list * DisplayEnv * CompletionContext option * range) option = + RequireCompilationThread ctok // the operations in this method need the reactor thread + + let loc = + match colAtEndOfNamesAndResidue with + | pastEndOfLine when pastEndOfLine >= lineStr.Length -> lineStr.Length + | atDot when lineStr.[atDot] = '.' -> atDot + 1 + | atStart when atStart = 0 -> 0 + | otherwise -> otherwise - 1 + + // Look for a "special" completion context + let completionContext = + parseResultsOpt + |> Option.bind (fun x -> x.ParseTree) + |> Option.bind (fun parseTree -> UntypedParseImpl.TryGetCompletionContext(mkPos line colAtEndOfNamesAndResidue, parseTree, lineStr)) + + let res = + match completionContext with + // Invalid completion locations + | Some CompletionContext.Invalid -> None + + // Completion at 'inherit C(...)" + | Some (CompletionContext.Inherit(InheritanceContext.Class, (plid, _))) -> + GetEnvironmentLookupResolutionsAtPosition(mkPos line loc, plid, filterCtors, false) + |> FilterRelevantItemsBy getItem None (getItem >> GetBaseClassCandidates) + |> Option.map toCompletionItems + + // Completion at 'interface ..." + | Some (CompletionContext.Inherit(InheritanceContext.Interface, (plid, _))) -> + GetEnvironmentLookupResolutionsAtPosition(mkPos line loc, plid, filterCtors, false) + |> FilterRelevantItemsBy getItem None (getItem >> GetInterfaceCandidates) + |> Option.map toCompletionItems + + // Completion at 'implement ..." + | Some (CompletionContext.Inherit(InheritanceContext.Unknown, (plid, _))) -> + GetEnvironmentLookupResolutionsAtPosition(mkPos line loc, plid, filterCtors, false) + |> FilterRelevantItemsBy getItem None (getItem >> (fun t -> GetBaseClassCandidates t || GetInterfaceCandidates t)) + |> Option.map toCompletionItems + + // Completion at ' { XXX = ... } " + | Some(CompletionContext.RecordField(RecordContext.New(plid, _))) -> + // { x. } can be either record construction or computation expression. Try to get all visible record fields first + match GetClassOrRecordFieldsEnvironmentLookupResolutions(mkPos line loc, plid) |> toCompletionItems with + | [],_,_ -> + // no record fields found, return completion list as if we were outside any computation expression + GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors,resolveOverloads, hasTextChangedSinceLastTypecheck, false, fun() -> []) + | result -> Some(result) + + // Completion at ' { XXX = ... with ... } " + | Some(CompletionContext.RecordField(RecordContext.CopyOnUpdate(r, (plid, _)))) -> + match GetRecdFieldsForExpr(r) with + | None -> + Some (GetClassOrRecordFieldsEnvironmentLookupResolutions(mkPos line loc, plid)) + |> Option.map toCompletionItems + | Some (items, denv, m) -> + Some (List.map ItemWithNoInst items, denv, m) + |> Option.map toCompletionItems + + // Completion at ' { XXX = ... with ... } " + | Some(CompletionContext.RecordField(RecordContext.Constructor(typeName))) -> + Some(GetClassOrRecordFieldsEnvironmentLookupResolutions(mkPos line loc, [typeName])) + |> Option.map toCompletionItems + + // Completion at ' SomeMethod( ... ) ' with named arguments + | Some(CompletionContext.ParameterList (endPos, fields)) -> + let results = GetNamedParametersAndSettableFields endPos hasTextChangedSinceLastTypecheck + + let declaredItems = + GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors, resolveOverloads, + hasTextChangedSinceLastTypecheck, false, getAllSymbols) + + match results with + | NameResResult.Members(items, denv, m) -> + let filtered = + items + |> RemoveDuplicateItems g + |> RemoveExplicitlySuppressed g + |> List.filter (fun item -> not (fields.Contains item.Item.DisplayName)) + |> List.map (fun item -> + { ItemWithInst = item + Kind = CompletionItemKind.Argument + MinorPriority = 0 + IsOwnMember = false + Type = None + Unresolved = None }) + match declaredItems with + | None -> Some (toCompletionItems (items, denv, m)) + | Some (declItems, declaredDisplayEnv, declaredRange) -> Some (filtered @ declItems, declaredDisplayEnv, declaredRange) + | _ -> declaredItems + + | Some(CompletionContext.AttributeApplication) -> + GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck, false, getAllSymbols) + |> Option.map (fun (items, denv, m) -> + items + |> List.filter (fun cItem -> + match cItem.Item with + | Item.ModuleOrNamespaces _ -> true + | _ when IsAttribute infoReader cItem.Item -> true + | _ -> false), denv, m) + + | Some(CompletionContext.OpenDeclaration) -> + GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck, false, getAllSymbols) + |> Option.map (fun (items, denv, m) -> + items |> List.filter (fun x -> match x.Item with Item.ModuleOrNamespaces _ -> true | _ -> false), denv, m) + + // Completion at '(x: ...)" + | Some (CompletionContext.PatternType) -> + GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck, false, getAllSymbols) + |> Option.map (fun (items, denv, m) -> + items + |> List.filter (fun cItem -> + match cItem.Item with + | Item.ModuleOrNamespaces _ + | Item.Types _ + | Item.UnqualifiedType _ + | Item.ExnCase _ -> true + | _ -> false), denv, m) + + // Other completions + | cc -> + match residueOpt |> Option.bind Seq.tryHead with + | Some ''' -> + // The last token in + // let x = 'E + // is Ident with text "'E", however it's either unfinished char literal or generic parameter. + // We should not provide any completion in the former case, and we don't provide it for the latter one for now + // because providing generic parameters list is context aware, which we don't have here (yet). + None + | _ -> + let isInRangeOperator = (match cc with Some (CompletionContext.RangeOperator) -> true | _ -> false) + GetDeclaredItems (parseResultsOpt, lineStr, origLongIdentOpt, colAtEndOfNamesAndResidue, residueOpt, lastDotPos, line, loc, filterCtors,resolveOverloads, hasTextChangedSinceLastTypecheck, isInRangeOperator, getAllSymbols) + + res |> Option.map (fun (items, denv, m) -> items, denv, completionContext, m) + + /// Return 'false' if this is not a completion item valid in an interface file. + let IsValidSignatureFileItem item = + match item with + | Item.Types _ | Item.ModuleOrNamespaces _ -> true + | _ -> false + + /// Find the most precise display context for the given line and column. + member __.GetBestDisplayEnvForPos cursorPos = GetBestEnvForPos cursorPos + + member __.GetVisibleNamespacesAndModulesAtPosition(cursorPos: pos) : ModuleOrNamespaceRef list = + let (nenv, ad), m = GetBestEnvForPos cursorPos + NameResolution.GetVisibleNamespacesAndModulesAtPoint ncenv nenv m ad + + /// Determines if a long ident is resolvable at a specific point. + member __.IsRelativeNameResolvable(cursorPos: pos, plid: string list, item: Item) : bool = + ErrorScope.Protect + Range.range0 + (fun () -> + /// Find items in the best naming environment. + let (nenv, ad), m = GetBestEnvForPos cursorPos + NameResolution.IsItemResolvable ncenv nenv m ad plid item) + (fun msg -> + Trace.TraceInformation(sprintf "FCS: recovering from error in IsRelativeNameResolvable: '%s'" msg) + false) + + /// Determines if a long ident is resolvable at a specific point. + member scope.IsRelativeNameResolvableFromSymbol(cursorPos: pos, plid: string list, symbol: FSharpSymbol) : bool = + scope.IsRelativeNameResolvable(cursorPos, plid, symbol.Item) + + /// Get the auto-complete items at a location + member __.GetDeclarations (ctok, parseResultsOpt, line, lineStr, partialName, getAllEntities, hasTextChangedSinceLastTypecheck) = + let isInterfaceFile = SourceFileImpl.IsInterfaceFile mainInputFileName + ErrorScope.Protect Range.range0 + (fun () -> + match GetDeclItemsForNamesAtPosition(ctok, parseResultsOpt, Some partialName.QualifyingIdents, Some partialName.PartialIdent, partialName.LastDotPos, line, lineStr, partialName.EndColumn + 1, ResolveTypeNamesToCtors, ResolveOverloads.Yes, getAllEntities, hasTextChangedSinceLastTypecheck) with + | None -> FSharpDeclarationListInfo.Empty + | Some (items, denv, ctx, m) -> + let items = if isInterfaceFile then items |> List.filter (fun x -> IsValidSignatureFileItem x.Item) else items + let getAccessibility item = FSharpSymbol.GetAccessibility (FSharpSymbol.Create(cenv, item)) + let currentNamespaceOrModule = + parseResultsOpt + |> Option.bind (fun x -> x.ParseTree) + |> Option.map (fun parsedInput -> UntypedParseImpl.GetFullNameOfSmallestModuleOrNamespaceAtPoint(parsedInput, mkPos line 0)) + let isAttributeApplication = ctx = Some CompletionContext.AttributeApplication + FSharpDeclarationListInfo.Create(infoReader,m,denv,getAccessibility,items,reactorOps,currentNamespaceOrModule,isAttributeApplication,checkAlive)) + (fun msg -> + Trace.TraceInformation(sprintf "FCS: recovering from error in GetDeclarations: '%s'" msg) + FSharpDeclarationListInfo.Error msg) + + /// Get the symbols for auto-complete items at a location + member __.GetDeclarationListSymbols (ctok, parseResultsOpt, line, lineStr, partialName, getAllEntities, hasTextChangedSinceLastTypecheck) = + let isInterfaceFile = SourceFileImpl.IsInterfaceFile mainInputFileName + ErrorScope.Protect Range.range0 + (fun () -> + match GetDeclItemsForNamesAtPosition(ctok, parseResultsOpt, Some partialName.QualifyingIdents, Some partialName.PartialIdent, partialName.LastDotPos, line, lineStr, partialName.EndColumn + 1, ResolveTypeNamesToCtors, ResolveOverloads.Yes, getAllEntities, hasTextChangedSinceLastTypecheck) with + | None -> List.Empty + | Some (items, denv, _, m) -> + let items = if isInterfaceFile then items |> List.filter (fun x -> IsValidSignatureFileItem x.Item) else items + + //do filtering like Declarationset + let items = items |> RemoveExplicitlySuppressedCompletionItems g + + // Sort by name. For things with the same name, + // - show types with fewer generic parameters first + // - show types before over other related items - they usually have very useful XmlDocs + let items = + items |> List.sortBy (fun d -> + let n = + match d.Item with + | Item.Types (_,(TType_app(tcref,_) :: _)) -> 1 + tcref.TyparsNoRange.Length + // Put delegate ctors after types, sorted by #typars. RemoveDuplicateItems will remove FakeInterfaceCtor and DelegateCtor if an earlier type is also reported with this name + | Item.FakeInterfaceCtor (TType_app(tcref,_)) + | Item.DelegateCtor (TType_app(tcref,_)) -> 1000 + tcref.TyparsNoRange.Length + // Put type ctors after types, sorted by #typars. RemoveDuplicateItems will remove DefaultStructCtors if a type is also reported with this name + | Item.CtorGroup (_, (cinfo :: _)) -> 1000 + 10 * cinfo.DeclaringTyconRef.TyparsNoRange.Length + | _ -> 0 + (d.Item.DisplayName,n)) + + // Remove all duplicates. We've put the types first, so this removes the DelegateCtor and DefaultStructCtor's. + let items = items |> RemoveDuplicateCompletionItems g + + // Group by compiled name for types, display name for functions + // (We don't want types with the same display name to be grouped as overloads) + let items = + items |> List.groupBy (fun d -> + match d.Item with + | Item.Types (_,(TType_app(tcref,_) :: _)) + | Item.ExnCase tcref -> tcref.LogicalName + | Item.UnqualifiedType(tcref :: _) + | Item.FakeInterfaceCtor (TType_app(tcref,_)) + | Item.DelegateCtor (TType_app(tcref,_)) -> tcref.CompiledName + | Item.CtorGroup (_, (cinfo :: _)) -> + cinfo.ApparentEnclosingTyconRef.CompiledName + | _ -> d.Item.DisplayName) + + // Filter out operators (and list) + let items = + // Check whether this item looks like an operator. + let isOpItem(nm, item: CompletionItem list) = + match item |> List.map (fun x -> x.Item) with + | [Item.Value _] + | [Item.MethodGroup(_,[_],_)] -> IsOperatorName nm + | [Item.UnionCase _] -> IsOperatorName nm + | _ -> false + + let isFSharpList nm = (nm = "[]") // list shows up as a Type and a UnionCase, only such entity with a symbolic name, but want to filter out of intellisense + + items |> List.filter (fun (nm,items) -> not (isOpItem(nm,items)) && not(isFSharpList nm)) + + let items = + // Filter out duplicate names + items |> List.map (fun (_nm,itemsWithSameName) -> + match itemsWithSameName with + | [] -> failwith "Unexpected empty bag" + | items -> + items + |> List.map (fun item -> let symbol = FSharpSymbol.Create(cenv, item.Item) + FSharpSymbolUse(g, denv, symbol, ItemOccurence.Use, m))) + + //end filtering + items) + (fun msg -> + Trace.TraceInformation(sprintf "FCS: recovering from error in GetDeclarationListSymbols: '%s'" msg) + []) + + /// Get the "reference resolution" tooltip for at a location + member __.GetReferenceResolutionStructuredToolTipText(ctok, line,col) = + + RequireCompilationThread ctok // the operations in this method need the reactor thread but the reasons why are not yet grounded + + let pos = mkPos line col + let isPosMatch(pos, ar:AssemblyReference) : bool = + let isRangeMatch = (Range.rangeContainsPos ar.Range pos) + let isNotSpecialRange = (ar.Range <> rangeStartup) && (ar.Range <> range0) && (ar.Range <> rangeCmdArgs) + let isMatch = isRangeMatch && isNotSpecialRange + isMatch + + let dataTipOfReferences() = + let matches = + match loadClosure with + | None -> [] + | Some(loadClosure) -> + loadClosure.References + |> List.map snd + |> List.concat + |> List.filter(fun ar->isPosMatch(pos, ar.originalReference)) + + match matches with + | resolved::_ // Take the first seen + | [resolved] -> + let tip = wordL (TaggedTextOps.tagStringLiteral((resolved.prepareToolTip ()).TrimEnd([|'\n'|]))) + FSharpStructuredToolTipText.FSharpToolTipText [FSharpStructuredToolTipElement.Single(tip, FSharpXmlDoc.None)] + + | [] -> FSharpStructuredToolTipText.FSharpToolTipText [] + + ErrorScope.Protect Range.range0 + dataTipOfReferences + (fun err -> + Trace.TraceInformation(sprintf "FCS: recovering from error in GetReferenceResolutionStructuredToolTipText: '%s'" err) + FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError err]) + + // GetToolTipText: return the "pop up" (or "Quick Info") text given a certain context. + member __.GetStructuredToolTipText(ctok, line, lineStr, colAtEndOfNames, names) = + let Compute() = + ErrorScope.Protect Range.range0 + (fun () -> + match GetDeclItemsForNamesAtPosition(ctok, None,Some(names),None,None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToCtors,ResolveOverloads.Yes,(fun() -> []),fun _ -> false) with + | None -> FSharpToolTipText [] + | Some(items, denv, _, m) -> + FSharpToolTipText(items |> List.map (fun x -> FormatStructuredDescriptionOfItem false infoReader m denv x.ItemWithInst))) + (fun err -> + Trace.TraceInformation(sprintf "FCS: recovering from error in GetStructuredToolTipText: '%s'" err) + FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError err]) + + // See devdiv bug 646520 for rationale behind truncating and caching these quick infos (they can be big!) + let key = line,colAtEndOfNames,lineStr + match getToolTipTextCache.TryGet (ctok, key) with + | Some res -> res + | None -> + let res = Compute() + getToolTipTextCache.Put(ctok, key,res) + res + + member __.GetF1Keyword (ctok, line, lineStr, colAtEndOfNames, names) : string option = + ErrorScope.Protect Range.range0 + (fun () -> + match GetDeclItemsForNamesAtPosition(ctok, None, Some names, None, None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.No,(fun() -> []), fun _ -> false) with // F1 Keywords do not distinguish between overloads + | None -> None + | Some (items: CompletionItem list, _,_, _) -> + match items with + | [] -> None + | [item] -> + GetF1Keyword g item.Item + | _ -> + // handle new Type() + let allTypes, constr, ty = + List.fold + (fun (allTypes,constr,ty) (item: CompletionItem) -> + match item.Item, constr, ty with + | (Item.Types _) as t, _, None -> allTypes, constr, Some t + | (Item.Types _), _, _ -> allTypes, constr, ty + | (Item.CtorGroup _), None, _ -> allTypes, Some item.Item, ty + | _ -> false, None, None) + (true,None,None) items + match allTypes, constr, ty with + | true, Some (Item.CtorGroup(_, _) as item), _ + -> GetF1Keyword g item + | true, _, Some ty + -> GetF1Keyword g ty + | _ -> None + ) + (fun msg -> + Trace.TraceInformation(sprintf "FCS: recovering from error in GetF1Keyword: '%s'" msg) + None) + + member __.GetMethods (ctok, line, lineStr, colAtEndOfNames, namesOpt) = + ErrorScope.Protect Range.range0 + (fun () -> + match GetDeclItemsForNamesAtPosition(ctok, None,namesOpt,None,None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToCtors,ResolveOverloads.No,(fun() -> []),fun _ -> false) with + | None -> FSharpMethodGroup("",[| |]) + | Some (items, denv, _, m) -> + // GetDeclItemsForNamesAtPosition returns Items.Types and Item.CtorGroup for `new T(|)`, + // the Item.Types is not needed here as it duplicates (at best) parameterless ctor. + let ctors = items |> List.filter (fun x -> match x.Item with Item.CtorGroup _ -> true | _ -> false) + let items = + match ctors with + | [] -> items + | ctors -> ctors + FSharpMethodGroup.Create(infoReader, m, denv, items |> List.map (fun x -> x.ItemWithInst))) + (fun msg -> + Trace.TraceInformation(sprintf "FCS: recovering from error in GetMethods: '%s'" msg) + FSharpMethodGroup(msg,[| |])) + + member __.GetMethodsAsSymbols (ctok, line, lineStr, colAtEndOfNames, names) = + ErrorScope.Protect Range.range0 + (fun () -> + match GetDeclItemsForNamesAtPosition (ctok, None,Some(names), None, None,line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.No,(fun() -> []),fun _ -> false) with + | None | Some ([],_,_,_) -> None + | Some (items, denv, _, m) -> + let allItems = items |> List.collect (fun item -> SymbolHelpers.FlattenItems g m item.Item) + let symbols = allItems |> List.map (fun item -> FSharpSymbol.Create(cenv, item)) + Some (symbols, denv, m) + ) + (fun msg -> + Trace.TraceInformation(sprintf "FCS: recovering from error in GetMethodsAsSymbols: '%s'" msg) + None) + + member __.GetDeclarationLocation (ctok, line, lineStr, colAtEndOfNames, names, preferFlag) = + ErrorScope.Protect Range.range0 + (fun () -> + match GetDeclItemsForNamesAtPosition (ctok, None,Some(names), None, None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors,ResolveOverloads.Yes,(fun() -> []), fun _ -> false) with + | None + | Some ([], _, _, _) -> FSharpFindDeclResult.DeclNotFound (FSharpFindDeclFailureReason.Unknown "") + | Some (item :: _, _, _, _) -> + let getTypeVarNames (ilinfo: ILMethInfo) = + let classTypeParams = ilinfo.DeclaringTyconRef.ILTyconRawMetadata.GenericParams |> List.map (fun paramDef -> paramDef.Name) + let methodTypeParams = ilinfo.FormalMethodTypars |> List.map (fun ty -> ty.Name) + classTypeParams @ methodTypeParams |> Array.ofList + + let result = + match item.Item with + | Item.CtorGroup (_, (ILMeth (_,ilinfo,_)) :: _) -> + match ilinfo.MetadataScope with + | ILScopeRef.Assembly assemblyRef -> + let typeVarNames = getTypeVarNames ilinfo + ParamTypeSymbol.tryOfILTypes typeVarNames ilinfo.ILMethodRef.ArgTypes + |> Option.map (fun args -> + let externalSym = ExternalSymbol.Constructor (ilinfo.ILMethodRef.DeclaringTypeRef.FullName, args) + FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, externalSym)) + | _ -> None + + | Item.MethodGroup (name, (ILMeth (_,ilinfo,_)) :: _, _) -> + match ilinfo.MetadataScope with + | ILScopeRef.Assembly assemblyRef -> + let typeVarNames = getTypeVarNames ilinfo + ParamTypeSymbol.tryOfILTypes typeVarNames ilinfo.ILMethodRef.ArgTypes + |> Option.map (fun args -> + let externalSym = ExternalSymbol.Method (ilinfo.ILMethodRef.DeclaringTypeRef.FullName, name, args, ilinfo.ILMethodRef.GenericArity) + FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, externalSym)) + | _ -> None + + | Item.Property (name, ILProp propInfo :: _) -> + let methInfo = + if propInfo.HasGetter then Some propInfo.GetterMethod + elif propInfo.HasSetter then Some propInfo.SetterMethod + else None + + match methInfo with + | Some methInfo -> + match methInfo.MetadataScope with + | ILScopeRef.Assembly assemblyRef -> + let externalSym = ExternalSymbol.Property (methInfo.ILMethodRef.DeclaringTypeRef.FullName, name) + Some (FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, externalSym)) + | _ -> None + | None -> None + + | Item.ILField (ILFieldInfo (typeInfo, fieldDef)) when not typeInfo.TyconRefOfRawMetadata.IsLocalRef -> + match typeInfo.ILScopeRef with + | ILScopeRef.Assembly assemblyRef -> + let externalSym = ExternalSymbol.Field (typeInfo.ILTypeRef.FullName, fieldDef.Name) + Some (FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, externalSym)) + | _ -> None + + | Item.Event (ILEvent (ILEventInfo (typeInfo, eventDef))) when not typeInfo.TyconRefOfRawMetadata.IsLocalRef -> + match typeInfo.ILScopeRef with + | ILScopeRef.Assembly assemblyRef -> + let externalSym = ExternalSymbol.Event (typeInfo.ILTypeRef.FullName, eventDef.Name) + Some (FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, externalSym)) + | _ -> None + + | Item.ImplicitOp(_, {contents = Some(TraitConstraintSln.FSMethSln(_, _vref, _))}) -> + //Item.Value(vref) + None + + | Item.Types (_, TType_app (tr, _) :: _) when tr.IsLocalRef && tr.IsTypeAbbrev -> None + + | Item.Types (_, [ AppTy g (tr, _) ]) when not tr.IsLocalRef -> + match tr.TypeReprInfo, tr.PublicPath with + | TILObjectRepr(TILObjectReprData (ILScopeRef.Assembly assemblyRef, _, _)), Some (PubPath parts) -> + let fullName = parts |> String.concat "." + Some (FSharpFindDeclResult.ExternalDecl (assemblyRef.Name, ExternalSymbol.Type fullName)) + | _ -> None + | _ -> None + match result with + | Some x -> x + | None -> + match rangeOfItem g preferFlag item.Item with + | Some itemRange -> + let projectDir = Filename.directoryName (if projectFileName = "" then mainInputFileName else projectFileName) + let range = fileNameOfItem g (Some projectDir) itemRange item.Item + mkRange range itemRange.Start itemRange.End + |> FSharpFindDeclResult.DeclFound + | None -> + match item.Item with +#if !NO_EXTENSIONTYPING +// provided items may have TypeProviderDefinitionLocationAttribute that binds them to some location + | Item.CtorGroup (name, ProvidedMeth (_)::_ ) + | Item.MethodGroup(name, ProvidedMeth (_)::_, _) + | Item.Property (name, ProvidedProp (_)::_ ) -> FSharpFindDeclFailureReason.ProvidedMember name + | Item.Event ( ProvidedEvent(_) as e ) -> FSharpFindDeclFailureReason.ProvidedMember e.EventName + | Item.ILField ( ProvidedField(_) as f ) -> FSharpFindDeclFailureReason.ProvidedMember f.FieldName + | SymbolHelpers.ItemIsProvidedType g (tcref) -> FSharpFindDeclFailureReason.ProvidedType tcref.DisplayName +#endif + | _ -> FSharpFindDeclFailureReason.Unknown "" + |> FSharpFindDeclResult.DeclNotFound + ) + (fun msg -> + Trace.TraceInformation(sprintf "FCS: recovering from error in GetDeclarationLocation: '%s'" msg) + FSharpFindDeclResult.DeclNotFound (FSharpFindDeclFailureReason.Unknown msg)) + + member __.GetSymbolUseAtLocation (ctok, line, lineStr, colAtEndOfNames, names) = + ErrorScope.Protect Range.range0 + (fun () -> + match GetDeclItemsForNamesAtPosition (ctok, None,Some(names), None, None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.Yes,(fun() -> []), fun _ -> false) with + | None | Some ([], _, _, _) -> None + | Some (item :: _, denv, _, m) -> + let symbol = FSharpSymbol.Create(cenv, item.Item) + Some (symbol, denv, m) + ) + (fun msg -> + Trace.TraceInformation(sprintf "FCS: recovering from error in GetSymbolUseAtLocation: '%s'" msg) + None) + + member __.PartialAssemblySignatureForFile = + FSharpAssemblySignature(g, thisCcu, ccuSigForFile, tcImports, None, ccuSigForFile) + + member __.AccessRights = tcAccessRights + + member __.GetReferencedAssemblies() = + [ for x in tcImports.GetImportedAssemblies() do + yield FSharpAssembly(g, tcImports, x.FSharpViewOfMetadata) ] + + member __.GetFormatSpecifierLocationsAndArity() = + sSymbolUses.GetFormatSpecifierLocationsAndArity() + + member __.GetSemanticClassification(range: range option) : (range * SemanticClassificationType) [] = + ErrorScope.Protect Range.range0 + (fun () -> + let (|LegitTypeOccurence|_|) = function + | ItemOccurence.UseInType + | ItemOccurence.UseInAttribute + | ItemOccurence.Use _ + | ItemOccurence.Binding _ + | ItemOccurence.Pattern _ -> Some() + | _ -> None + + let (|OptionalArgumentAttribute|_|) ttype = + match ttype with + | TType.TType_app(tref, _) when tref.Stamp = g.attrib_OptionalArgumentAttribute.TyconRef.Stamp -> Some() + | _ -> None + + let (|KeywordIntrinsicValue|_|) (vref: ValRef) = + if valRefEq g g.raise_vref vref || + valRefEq g g.reraise_vref vref || + valRefEq g g.typeof_vref vref || + valRefEq g g.typedefof_vref vref || + valRefEq g g.sizeof_vref vref + // TODO uncomment this after `nameof` operator is implemented + // || valRefEq g g.nameof_vref vref + then Some() + else None + + let (|EnumCaseFieldInfo|_|) (rfinfo : RecdFieldInfo) = + match rfinfo.TyconRef.TypeReprInfo with + | TFSharpObjectRepr x -> + match x.fsobjmodel_kind with + | TTyconEnum -> Some () + | _ -> None + | _ -> None + + let resolutions = + match range with + | Some range -> + sResolutions.CapturedNameResolutions + |> Seq.filter (fun cnr -> rangeContainsPos range cnr.Range.Start || rangeContainsPos range cnr.Range.End) + | None -> + sResolutions.CapturedNameResolutions :> seq<_> + + let isDisposableTy (ty: TType) = + protectAssemblyExplorationNoReraise false false (fun () -> Infos.ExistsHeadTypeInEntireHierarchy g amap range0 ty g.tcref_System_IDisposable) + + let isStructTyconRef (tyconRef: TyconRef) = + let ty = generalizedTyconRef tyconRef + let underlyingTy = stripTyEqnsAndMeasureEqns g ty + isStructTy g underlyingTy + + let isValRefMutable (vref: ValRef) = + // Mutable values, ref cells, and non-inref byrefs are mutable. + vref.IsMutable + || Tastops.isRefCellTy g vref.Type + || (Tastops.isByrefTy g vref.Type && not (Tastops.isInByrefTy g vref.Type)) + + let isRecdFieldMutable (rfinfo: RecdFieldInfo) = + (rfinfo.RecdField.IsMutable && rfinfo.LiteralValue.IsNone) + || Tastops.isRefCellTy g rfinfo.RecdField.FormalType + + resolutions + |> Seq.choose (fun cnr -> + match cnr with + // 'seq' in 'seq { ... }' gets colored as keywords + | CNR(_, (Item.Value vref), ItemOccurence.Use, _, _, _, m) when valRefEq g g.seq_vref vref -> + Some (m, SemanticClassificationType.ComputationExpression) + | CNR(_, (Item.Value vref), _, _, _, _, m) when isValRefMutable vref -> + Some (m, SemanticClassificationType.MutableVar) + | CNR(_, Item.Value KeywordIntrinsicValue, ItemOccurence.Use, _, _, _, m) -> + Some (m, SemanticClassificationType.IntrinsicFunction) + | CNR(_, (Item.Value vref), _, _, _, _, m) when isFunction g vref.Type -> + if valRefEq g g.range_op_vref vref || valRefEq g g.range_step_op_vref vref then + None + elif vref.IsPropertyGetterMethod || vref.IsPropertySetterMethod then + Some (m, SemanticClassificationType.Property) + elif IsOperatorName vref.DisplayName then + Some (m, SemanticClassificationType.Operator) + else + Some (m, SemanticClassificationType.Function) + | CNR(_, Item.RecdField rfinfo, _, _, _, _, m) when isRecdFieldMutable rfinfo -> + Some (m, SemanticClassificationType.MutableVar) + | CNR(_, Item.RecdField rfinfo, _, _, _, _, m) when isFunction g rfinfo.FieldType -> + Some (m, SemanticClassificationType.Function) + | CNR(_, Item.RecdField EnumCaseFieldInfo, _, _, _, _, m) -> + Some (m, SemanticClassificationType.Enumeration) + | CNR(_, Item.MethodGroup _, _, _, _, _, m) -> + Some (m, SemanticClassificationType.Function) + // custom builders, custom operations get colored as keywords + | CNR(_, (Item.CustomBuilder _ | Item.CustomOperation _), ItemOccurence.Use, _, _, _, m) -> + Some (m, SemanticClassificationType.ComputationExpression) + // types get colored as types when they occur in syntactic types or custom attributes + // typevariables get colored as types when they occur in syntactic types custom builders, custom operations get colored as keywords + | CNR(_, Item.Types (_, [OptionalArgumentAttribute]), LegitTypeOccurence, _, _, _, _) -> None + | CNR(_, Item.CtorGroup(_, [MethInfo.FSMeth(_, OptionalArgumentAttribute, _, _)]), LegitTypeOccurence, _, _, _, _) -> None + | CNR(_, Item.Types(_, types), LegitTypeOccurence, _, _, _, m) when types |> List.exists (isInterfaceTy g) -> + Some (m, SemanticClassificationType.Interface) + | CNR(_, Item.Types(_, types), LegitTypeOccurence, _, _, _, m) when types |> List.exists (isStructTy g) -> + Some (m, SemanticClassificationType.ValueType) + | CNR(_, Item.Types(_, TType_app(tyconRef, TType_measure _ :: _) :: _), LegitTypeOccurence, _, _, _, m) when isStructTyconRef tyconRef -> + Some (m, SemanticClassificationType.ValueType) + | CNR(_, Item.Types(_, types), LegitTypeOccurence, _, _, _, m) when types |> List.exists isDisposableTy -> + Some (m, SemanticClassificationType.Disposable) + | CNR(_, Item.Types _, LegitTypeOccurence, _, _, _, m) -> + Some (m, SemanticClassificationType.ReferenceType) + | CNR(_, (Item.TypeVar _ ), LegitTypeOccurence, _, _, _, m) -> + Some (m, SemanticClassificationType.TypeArgument) + | CNR(_, Item.UnqualifiedType tyconRefs, LegitTypeOccurence, _, _, _, m) -> + if tyconRefs |> List.exists (fun tyconRef -> tyconRef.Deref.IsStructOrEnumTycon) then + Some (m, SemanticClassificationType.ValueType) + else Some (m, SemanticClassificationType.ReferenceType) + | CNR(_, Item.CtorGroup(_, minfos), LegitTypeOccurence, _, _, _, m) -> + if minfos |> List.exists (fun minfo -> isStructTy g minfo.ApparentEnclosingType) then + Some (m, SemanticClassificationType.ValueType) + else Some (m, SemanticClassificationType.ReferenceType) + | CNR(_, Item.ExnCase _, LegitTypeOccurence, _, _, _, m) -> + Some (m, SemanticClassificationType.ReferenceType) + | CNR(_, Item.ModuleOrNamespaces refs, LegitTypeOccurence, _, _, _, m) when refs |> List.exists (fun x -> x.IsModule) -> + Some (m, SemanticClassificationType.Module) + | CNR(_, (Item.ActivePatternCase _ | Item.UnionCase _ | Item.ActivePatternResult _), _, _, _, _, m) -> + Some (m, SemanticClassificationType.UnionCase) + | _ -> None) + |> Seq.toArray + |> Array.append (sSymbolUses.GetFormatSpecifierLocationsAndArity() |> Array.map (fun m -> fst m, SemanticClassificationType.Printf)) + ) + (fun msg -> + Trace.TraceInformation(sprintf "FCS: recovering from error in GetSemanticClassification: '%s'" msg) + Array.empty) + + /// The resolutions in the file + member __.ScopeResolutions = sResolutions + + /// The uses of symbols in the analyzed file + member __.ScopeSymbolUses = sSymbolUses + + member __.TcGlobals = g + + member __.TcImports = tcImports + + /// The inferred signature of the file + member __.CcuSigForFile = ccuSigForFile + + /// The assembly being analyzed + member __.ThisCcu = thisCcu + + member __.ImplementationFile = implFileOpt + + /// All open declarations in the file, including auto open modules + member __.OpenDeclarations = openDeclarations + + member __.SymbolEnv = cenv + + override __.ToString() = "TypeCheckInfo(" + mainInputFileName + ")" + +type FSharpParsingOptions = + { SourceFiles: string [] + ConditionalCompilationDefines: string list + ErrorSeverityOptions: FSharpErrorSeverityOptions + IsInteractive: bool + LightSyntax: bool option + CompilingFsLib: bool + IsExe: bool } + + member x.LastFileName = + Debug.Assert(not (Array.isEmpty x.SourceFiles), "Parsing options don't contain any file") + Array.last x.SourceFiles + + static member Default = + { SourceFiles = Array.empty + ConditionalCompilationDefines = [] + ErrorSeverityOptions = FSharpErrorSeverityOptions.Default + IsInteractive = false + LightSyntax = None + CompilingFsLib = false + IsExe = false } + + static member FromTcConfig(tcConfig: TcConfig, sourceFiles, isInteractive: bool) = + { SourceFiles = sourceFiles + ConditionalCompilationDefines = tcConfig.conditionalCompilationDefines + ErrorSeverityOptions = tcConfig.errorSeverityOptions + IsInteractive = isInteractive + LightSyntax = tcConfig.light + CompilingFsLib = tcConfig.compilingFslib + IsExe = tcConfig.target.IsExe } + +#if !FABLE_COMPILER + static member FromTcConfigBuidler(tcConfigB: TcConfigBuilder, sourceFiles, isInteractive: bool) = + { + SourceFiles = sourceFiles + ConditionalCompilationDefines = tcConfigB.conditionalCompilationDefines + ErrorSeverityOptions = tcConfigB.errorSeverityOptions + IsInteractive = isInteractive + LightSyntax = tcConfigB.light + CompilingFsLib = tcConfigB.compilingFslib + IsExe = tcConfigB.target.IsExe + } +#endif //!FABLE_COMPILER + +module internal Parser = + + // We'll need number of lines for adjusting error messages at EOF + let GetFileInfoForLastLineErrors (source: string) = + // number of lines in the source file + let lastLine = (source |> Seq.sumBy (fun c -> if c = '\n' then 1 else 0)) + 1 + // length of the last line +#if FABLE_COMPILER + let lastLineLength = source.Length - source.LastIndexOf("\n") - 1 +#else + let lastLineLength = source.Length - source.LastIndexOf("\n",StringComparison.Ordinal) - 1 +#endif + lastLine, lastLineLength + + + /// Error handler for parsing & type checking while processing a single file + type ErrorHandler(reportErrors, mainInputFileName, errorSeverityOptions: FSharpErrorSeverityOptions, source) = + let mutable options = errorSeverityOptions + let errorsAndWarningsCollector = new ResizeArray<_>() + let mutable errorCount = 0 + + // We'll need number of lines for adjusting error messages at EOF + let fileInfo = GetFileInfoForLastLineErrors source + + // This function gets called whenever an error happens during parsing or checking + let diagnosticSink sev (exn: PhasedDiagnostic) = + // Sanity check here. The phase of an error should be in a phase known to the language service. + let exn = + if not(exn.IsPhaseInCompile()) then + // Reaching this point means that the error would be sticky if we let it prop up to the language service. + // Assert and recover by replacing phase with one known to the language service. + Trace.TraceInformation(sprintf "The subcategory '%s' seen in an error should not be seen by the language service" (exn.Subcategory())) + { exn with Phase = BuildPhase.TypeCheck } + else exn + if reportErrors then + let report exn = + for ei in ErrorHelpers.ReportError (options, false, mainInputFileName, fileInfo, (exn, sev)) do + errorsAndWarningsCollector.Add ei + if sev = FSharpErrorSeverity.Error then + errorCount <- errorCount + 1 + + match exn with +#if !NO_EXTENSIONTYPING + | { Exception = (:? TypeProviderError as tpe) } -> tpe.Iter(fun e -> report { exn with Exception = e }) +#endif + | e -> report e + + let errorLogger = + { new ErrorLogger("ErrorHandler") with + member x.DiagnosticSink (exn, isError) = diagnosticSink (if isError then FSharpErrorSeverity.Error else FSharpErrorSeverity.Warning) exn + member x.ErrorCount = errorCount } + + // Public members + member x.ErrorLogger = errorLogger + member x.CollectedDiagnostics = errorsAndWarningsCollector.ToArray() + member x.ErrorCount = errorCount + member x.ErrorSeverityOptions with set opts = options <- opts + member x.AnyErrors = errorCount > 0 + + let getLightSyntaxStatus fileName options = + let lower = String.lowercase fileName + let lightOnByDefault = List.exists (Filename.checkSuffix lower) FSharpLightSyntaxFileSuffixes + let lightSyntaxStatus = if lightOnByDefault then (options.LightSyntax <> Some false) else (options.LightSyntax = Some true) + LightSyntaxStatus(lightSyntaxStatus, true) + + let createLexerFunction fileName options lexbuf (errHandler: ErrorHandler) = + let lightSyntaxStatus = getLightSyntaxStatus fileName options + + // If we're editing a script then we define INTERACTIVE otherwise COMPILED. + // Since this parsing for intellisense we always define EDITING. + let defines = (SourceFileImpl.AdditionalDefinesForUseInEditor options.IsInteractive) @ options.ConditionalCompilationDefines + + // Note: we don't really attempt to intern strings across a large scope. + let lexResourceManager = new Lexhelp.LexResourceManager() + + // When analyzing files using ParseOneFile, i.e. for the use of editing clients, we do not apply line directives. + let lexargs = mkLexargs(fileName, defines, lightSyntaxStatus, lexResourceManager, ref [], errHandler.ErrorLogger) + let lexargs = { lexargs with applyLineDirectives = false } + + let tokenizer = LexFilter.LexFilter(lightSyntaxStatus, options.CompilingFsLib, Lexer.token lexargs true, lexbuf) + tokenizer.Lexer + + // Adding this new-line character at the end of the source seems odd but is required for some unit tests + // Todo: fix tests + let addNewLine (source: string) = + if source.Length = 0 || not (source.[source.Length - 1] = '\n') then source + "\n" else source + + let matchBraces(source, fileName, options: FSharpParsingOptions, userOpName: string) = + let delayedLogger = CapturingErrorLogger("matchBraces") + use _unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> delayedLogger) + use _unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse + + Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "matchBraces", fileName) + + // Make sure there is an ErrorLogger installed whenever we do stuff that might record errors, even if we ultimately ignore the errors + let delayedLogger = CapturingErrorLogger("matchBraces") + use _unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> delayedLogger) + use _unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse + + let matchingBraces = new ResizeArray<_>() + Lexhelp.usingLexbufForParsing(UnicodeLexing.StringAsLexbuf(addNewLine source), fileName) (fun lexbuf -> + let errHandler = ErrorHandler(false, fileName, options.ErrorSeverityOptions, source) + let lexfun = createLexerFunction fileName options lexbuf errHandler + let parenTokensBalance t1 t2 = + match t1, t2 with + | (LPAREN, RPAREN) + | (LPAREN, RPAREN_IS_HERE) + | (LBRACE, RBRACE) + | (LBRACE, RBRACE_IS_HERE) + | (SIG, END) + | (STRUCT, END) + | (LBRACK_BAR, BAR_RBRACK) + | (LBRACK, RBRACK) + | (LBRACK_LESS, GREATER_RBRACK) + | (BEGIN, END) -> true + | (LQUOTE q1, RQUOTE q2) -> q1 = q2 + | _ -> false + let rec matchBraces stack = + match lexfun lexbuf, stack with + | tok2, ((tok1, m1) :: stack') when parenTokensBalance tok1 tok2 -> + matchingBraces.Add(m1, lexbuf.LexemeRange) + matchBraces stack' + | ((LPAREN | LBRACE | LBRACK | LBRACK_BAR | LQUOTE _ | LBRACK_LESS) as tok), _ -> + matchBraces ((tok, lexbuf.LexemeRange) :: stack) + | (EOF _ | LEX_FAILURE _), _ -> () + | _ -> matchBraces stack + matchBraces []) + matchingBraces.ToArray() + + let parseFile(source, fileName, options: FSharpParsingOptions, userOpName: string) = + Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "parseFile", fileName) + let errHandler = new ErrorHandler(true, fileName, options.ErrorSeverityOptions, source) + use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _oldLogger -> errHandler.ErrorLogger) + use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse + + let parseResult = + Lexhelp.usingLexbufForParsing(UnicodeLexing.StringAsLexbuf(addNewLine source), fileName) (fun lexbuf -> + let lexfun = createLexerFunction fileName options lexbuf errHandler + let isLastCompiland = +#if FABLE_COMPILER + fileName.Equals(options.LastFileName, StringComparison.OrdinalIgnoreCase) || +#else + fileName.Equals(options.LastFileName, StringComparison.CurrentCultureIgnoreCase) || +#endif + CompileOps.IsScript(fileName) + let isExe = options.IsExe + try Some (ParseInput(lexfun, errHandler.ErrorLogger, lexbuf, None, fileName, (isLastCompiland, isExe))) + with e -> + errHandler.ErrorLogger.StopProcessingRecovery e Range.range0 // don't re-raise any exceptions, we must return None. + None) + errHandler.CollectedDiagnostics, parseResult, errHandler.AnyErrors + + /// Indicates if the type check got aborted because it is no longer relevant. + type TypeCheckAborted = Yes | No of TypeCheckInfo + + // Type check a single file against an initial context, gleaning both errors and intellisense information. + let CheckOneFile + (parseResults: FSharpParseFileResults, + source: string, + mainInputFileName: string, + projectFileName: string, + tcConfig: TcConfig, + tcGlobals: TcGlobals, + tcImports: TcImports, + tcState: TcState, + moduleNamesDict: ModuleNamesDict, + loadClosure: LoadClosure option, + // These are the errors and warnings seen by the background compiler for the entire antecedent + backgroundDiagnostics: (PhasedDiagnostic * FSharpErrorSeverity)[], + reactorOps: IReactorOperations, + // Used by 'FSharpDeclarationListInfo' to check the IncrementalBuilder is still alive. + checkAlive : (unit -> bool), + textSnapshotInfo : obj option, + userOpName: string) = + +#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 -> [||], TypeCheckAborted.Yes +#else + | None -> return [||], TypeCheckAborted.Yes +#endif + + // Run the type checker... + | Some parsedMainInput -> + // Initialize the error handler + let errHandler = new ErrorHandler(true, mainInputFileName, tcConfig.errorSeverityOptions, source) + + 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 + + // Play background errors and warnings for this file. + 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 + match loadClosure with + | Some loadClosure -> + // Play unresolved references for this file. + tcImports.ReportUnresolvedAssemblyReferences(loadClosure.UnresolvedReferences) + + // If there was a loadClosure, replay the errors and warnings from resolution, excluding parsing + loadClosure.LoadClosureRootFileDiagnostics |> List.iter diagnosticSink + + let fileOfBackgroundError err = (match GetRangeOfDiagnostic (fst err) with Some m-> m.FileName | None -> null) + let sameFile file hashLoadInFile = + (0 = String.Compare(hashLoadInFile, file, StringComparison.OrdinalIgnoreCase)) + + // walk the list of #loads and keep the ones for this file. + let hashLoadsInFile = + loadClosure.SourceFiles + |> List.filter(fun (_,ms) -> ms<>[]) // #loaded file, ranges of #load + + let hashLoadBackgroundDiagnostics, otherBackgroundDiagnostics = + backgroundDiagnostics + |> Array.partition (fun backgroundError -> + hashLoadsInFile + |> List.exists (fst >> sameFile (fileOfBackgroundError backgroundError))) + + // Create single errors for the #load-ed files. + // Group errors and warnings by file name. + let hashLoadBackgroundDiagnosticsGroupedByFileName = + hashLoadBackgroundDiagnostics + |> Array.map(fun err -> fileOfBackgroundError err,err) + |> Array.groupBy fst // fileWithErrors, error list + + // Join the sets and report errors. + // It is by-design that these messages are only present in the language service. A true build would report the errors at their + // spots in the individual source files. + for (fileOfHashLoad, rangesOfHashLoad) in hashLoadsInFile do + for (file, errorGroupedByFileName) in hashLoadBackgroundDiagnosticsGroupedByFileName do + if sameFile file fileOfHashLoad then + for rangeOfHashLoad in rangesOfHashLoad do // Handle the case of two #loads of the same file + let diagnostics = errorGroupedByFileName |> Array.map(fun (_,(pe,f)) -> pe.Exception,f) // Strip the build phase here. It will be replaced, in total, with TypeCheck + let errors = [ for (err,sev) in diagnostics do if sev = FSharpErrorSeverity.Error then yield err ] + let warnings = [ for (err,sev) in diagnostics do if sev = FSharpErrorSeverity.Warning then yield err ] + + let message = HashLoadedSourceHasIssues(warnings,errors,rangeOfHashLoad) + if errors=[] then warning(message) + else errorR(message) + + // Replay other background errors. + for (phasedError,sev) in otherBackgroundDiagnostics do + if sev = FSharpErrorSeverity.Warning then + warning phasedError.Exception + else errorR phasedError.Exception + + | None -> + // For non-scripts, check for disallow #r and #load. + ApplyMetaCommandsFromInputToTcConfig (tcConfig, parsedMainInput,Path.GetDirectoryName mainInputFileName) |> ignore +#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. + // If we don't do this the NNG accumulates data and we get a memory leak. + tcState.NiceNameGenerator.Reset() + + // Typecheck the real input. + let sink = TcResultsSinkImpl(tcGlobals, source = source) +#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 (tcEnvAtEnd, _, implFiles, ccuSigsForFiles), tcState = + TypeCheckOneInputAndFinishEventually(checkForErrors, tcConfig, tcImports, tcGlobals, None, TcResultsSink.WithSink sink, tcState, parsedMainInput) + |> Eventually.force ctok + Some (tcEnvAtEnd, implFiles, ccuSigsForFiles, tcState) + with + | e -> + errorR e + Some(tcState.TcEnvFromSignatures, [], [NewEmptyModuleOrNamespaceType Namespace], tcState) +#else //!FABLE_COMPILER + let! ct = Async.CancellationToken + + let! resOpt = + async { + try + let checkForErrors() = (parseResults.ParseHadErrors || errHandler.ErrorCount > 0) + + let parsedMainInput, _moduleNamesDict = DeduplicateParsedInputModuleName moduleNamesDict parsedMainInput + + // Typecheck is potentially a long running operation. We chop it up here with an Eventually continuation and, at each slice, give a chance + // for the client to claim the result as obsolete and have the typecheck abort. + + let! result = + TypeCheckOneInputAndFinishEventually(checkForErrors, tcConfig, tcImports, tcGlobals, None, TcResultsSink.WithSink sink, tcState, parsedMainInput) + |> Eventually.repeatedlyProgressUntilDoneOrTimeShareOverOrCanceled maxTimeShareMilliseconds ct (fun ctok f -> f ctok) + |> Eventually.forceAsync + (fun work -> + reactorOps.EnqueueAndAwaitOpAsync(userOpName, "CheckOneFile.Fragment", mainInputFileName, + fun ctok -> + // This work is not cancellable + let res = + // Reinstall the compilation globals each time we start or restart + use unwind = new CompilationGlobalsScope (errHandler.ErrorLogger, BuildPhase.TypeCheck) + work ctok + cancellable.Return(res) + )) + + return result |> Option.map (fun ((tcEnvAtEnd, _, implFiles, ccuSigsForFiles), tcState) -> tcEnvAtEnd, implFiles, ccuSigsForFiles, tcState) + with e -> + errorR e + return Some(tcState.TcEnvFromSignatures, [], [NewEmptyModuleOrNamespaceType Namespace], tcState) + } +#endif //!FABLE_COMPILER + + let errors = errHandler.CollectedDiagnostics + + match resOpt with + | Some (tcEnvAtEnd, implFiles, ccuSigsForFiles, tcState) -> + let scope = + TypeCheckInfo(tcConfig, tcGlobals, + List.head ccuSigsForFiles, + tcState.Ccu, + tcImports, + tcEnvAtEnd.AccessRights, + projectFileName, + mainInputFileName, + sink.GetResolutions(), + sink.GetSymbolUses(), + tcEnvAtEnd.NameEnv, + loadClosure, + reactorOps, + checkAlive, + textSnapshotInfo, + List.tryHead implFiles, + sink.GetOpenDeclarations()) +#if FABLE_COMPILER + errors, TypeCheckAborted.No scope + | None -> + errors, TypeCheckAborted.Yes +#else + return errors, TypeCheckAborted.No scope + | None -> + return errors, TypeCheckAborted.Yes + } +#endif + +type UnresolvedReferencesSet = UnresolvedReferencesSet of UnresolvedAssemblyReference list + +// NOTE: may be better just to move to optional arguments here +type FSharpProjectOptions = + { + ProjectFileName: string + ProjectId: string option + SourceFiles: string[] + OtherOptions: string[] + ReferencedProjects: (string * FSharpProjectOptions)[] + IsIncompleteTypeCheckEnvironment : bool + UseScriptResolutionRules : bool + LoadTime : System.DateTime + UnresolvedReferences : UnresolvedReferencesSet option + OriginalLoadReferences: (range * string) list + ExtraProjectInfo : obj option + Stamp : int64 option + } + member x.ProjectOptions = x.OtherOptions + /// Whether the two parse options refer to the same project. + static member UseSameProject(options1,options2) = + match options1.ProjectId, options2.ProjectId with + | Some(projectId1), Some(projectId2) when not (String.IsNullOrWhiteSpace(projectId1)) && not (String.IsNullOrWhiteSpace(projectId2)) -> + projectId1 = projectId2 + | Some(_), Some(_) + | None, None -> options1.ProjectFileName = options2.ProjectFileName + | _ -> false + + /// Compare two options sets with respect to the parts of the options that are important to building. + static member AreSameForChecking(options1,options2) = + match options1.Stamp, options2.Stamp with + | Some x, Some y -> (x = y) + | _ -> + FSharpProjectOptions.UseSameProject(options1, options2) && + options1.SourceFiles = options2.SourceFiles && + options1.OtherOptions = options2.OtherOptions && + options1.UnresolvedReferences = options2.UnresolvedReferences && + options1.OriginalLoadReferences = options2.OriginalLoadReferences && + options1.ReferencedProjects.Length = options2.ReferencedProjects.Length && + Array.forall2 (fun (n1,a) (n2,b) -> + n1 = n2 && + FSharpProjectOptions.AreSameForChecking(a,b)) options1.ReferencedProjects options2.ReferencedProjects && + options1.LoadTime = options2.LoadTime + + /// Compute the project directory. + member po.ProjectDirectory = System.IO.Path.GetDirectoryName(po.ProjectFileName) + override this.ToString() = "FSharpProjectOptions(" + this.ProjectFileName + ")" + + +[] +type FSharpProjectContext(thisCcu: CcuThunk, assemblies: FSharpAssembly list, ad: AccessorDomain) = + + /// Get the assemblies referenced + member __.GetReferencedAssemblies() = assemblies + + member __.AccessibilityRights = FSharpAccessibilityRights(thisCcu, ad) + + +[] +// 'details' is an option because the creation of the tcGlobals etc. for the project may have failed. +type FSharpCheckProjectResults(projectFileName:string, tcConfigOption, keepAssemblyContents:bool, errors: FSharpErrorInfo[], + details:(TcGlobals * TcImports * CcuThunk * ModuleOrNamespaceType * TcSymbolUses list * TopAttribs option * CompileOps.IRawFSharpAssemblyData option * ILAssemblyRef * AccessorDomain * TypedImplFile list option * string[]) option) = + + let getDetails() = + match details with + | None -> invalidOp ("The project has no results due to critical errors in the project options. Check the HasCriticalErrors before accessing the detailed results. Errors: " + String.concat "\n" [ for e in errors -> e.Message ]) + | Some d -> d + + let getTcConfig() = + match tcConfigOption with + | None -> invalidOp ("The project has no results due to critical errors in the project options. Check the HasCriticalErrors before accessing the detailed results. Errors: " + String.concat "\n" [ for e in errors -> e.Message ]) + | Some d -> d + + member info.Errors = errors + + member info.HasCriticalErrors = details.IsNone + + member info.AssemblySignature = + let (tcGlobals, tcImports, thisCcu, ccuSig, _tcSymbolUses, topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() + FSharpAssemblySignature(tcGlobals, thisCcu, ccuSig, tcImports, topAttribs, ccuSig) + + member info.TypedImplementionFiles = + if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to true on the FSharpChecker in order to access the checked contents of assemblies" + let (tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, tcAssemblyExpr, _dependencyFiles) = getDetails() + let mimpls = + match tcAssemblyExpr with + | None -> [] + | Some mimpls -> mimpls + tcGlobals, thisCcu, tcImports, mimpls + + member info.AssemblyContents = + if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to true on the FSharpChecker in order to access the checked contents of assemblies" + let (tcGlobals, tcImports, thisCcu, ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, tcAssemblyExpr, _dependencyFiles) = getDetails() + let mimpls = + match tcAssemblyExpr with + | None -> [] + | Some mimpls -> mimpls + FSharpAssemblyContents(tcGlobals, thisCcu, Some ccuSig, tcImports, mimpls) + + member info.GetOptimizedAssemblyContents() = + if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to true on the FSharpChecker in order to access the checked contents of assemblies" + let (tcGlobals, tcImports, thisCcu, ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, tcAssemblyExpr, _dependencyFiles) = getDetails() + let mimpls = + match tcAssemblyExpr with + | None -> [] + | Some mimpls -> mimpls + let outfile = "" // only used if tcConfig.writeTermsToFiles is true + let importMap = tcImports.GetImportMap() + let optEnv0 = GetInitialOptimizationEnv (tcImports, tcGlobals) + let tcConfig = getTcConfig() + let optimizedImpls, _optimizationData, _ = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, thisCcu, mimpls) + let mimpls = + match optimizedImpls with + | TypedAssemblyAfterOptimization files -> + files |> List.map fst + + FSharpAssemblyContents(tcGlobals, thisCcu, Some ccuSig, tcImports, mimpls) + + // Not, this does not have to be a SyncOp, it can be called from any thread + member info.GetUsesOfSymbol(symbol:FSharpSymbol) = + let (tcGlobals, _tcImports, _thisCcu, _ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() + + tcSymbolUses + |> Seq.collect (fun r -> r.GetUsesOfSymbol symbol.Item) + |> Seq.distinctBy (fun symbolUse -> symbolUse.ItemOccurence, symbolUse.Range) + |> Seq.filter (fun symbolUse -> symbolUse.ItemOccurence <> ItemOccurence.RelatedText) + |> Seq.map (fun symbolUse -> FSharpSymbolUse(tcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range)) + |> Seq.toArray + |> async.Return + + // Not, this does not have to be a SyncOp, it can be called from any thread + member __.GetAllUsesOfAllSymbols() = + let (tcGlobals, tcImports, thisCcu, ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() + let cenv = SymbolEnv(tcGlobals, thisCcu, Some ccuSig, tcImports) + + [| for r in tcSymbolUses do for symbolUseChunk in r.AllUsesOfSymbols do for symbolUse in symbolUseChunk do - if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then - let symbol = FSharpSymbol.Create(cenv, symbolUse.Item) - yield FSharpSymbolUse(tcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range) |] - |> async.Return - - member __.ProjectContext = - let (tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() - let assemblies = - [ for x in tcImports.GetImportedAssemblies() do - yield FSharpAssembly(tcGlobals, tcImports, x.FSharpViewOfMetadata) ] - FSharpProjectContext(thisCcu, assemblies, ad) - - member __.RawFSharpAssemblyData = - let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() - tcAssemblyData - - member __.DependencyFiles = - let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, dependencyFiles) = getDetails() - dependencyFiles - - member __.AssemblyFullName = - let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() - ilAssemRef.QualifiedName - - override info.ToString() = "FSharpCheckProjectResults(" + projectFileName + ")" - -[] -/// A live object of this type keeps the background corresponding background builder (and type providers) alive (through reference-counting). -// -// There is an important property of all the objects returned by the methods of this type: they do not require -// the corresponding background builder to be alive. That is, they are simply plain-old-data through pre-formatting of all result text. -type FSharpCheckFileResults(filename: string, errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo option, dependencyFiles: string[], builderX: IncrementalBuilder option, reactorOpsX:IReactorOperations, keepAssemblyContents: bool) = - - // This may be None initially, or may be set to None when the object is disposed or finalized - let mutable details = match scopeOptX with None -> None | Some scopeX -> Some (scopeX, builderX, reactorOpsX) - - // Increment the usage count on the IncrementalBuilder. We want to keep the IncrementalBuilder and all associated - // resources and type providers alive for the duration of the lifetime of this object. - let decrementer = - match details with - | Some (_,builderOpt,_) -> IncrementalBuilder.KeepBuilderAlive builderOpt - | _ -> { new System.IDisposable with member x.Dispose() = () } - - let mutable disposed = false - - let dispose() = - if not disposed then - disposed <- true - match details with - | Some (_,_,reactor) -> - // Make sure we run disposal in the reactor thread, since it may trigger type provider disposals etc. - details <- None - reactor.EnqueueOp ("GCFinalizer","FSharpCheckFileResults.DecrementUsageCountOnIncrementalBuilder", filename, fun ctok -> - RequireCompilationThread ctok - decrementer.Dispose()) - | _ -> () - - // Run an operation that needs to access a builder and be run in the reactor thread - let reactorOp userOpName opName dflt f = - async { - match details with - | None -> - return dflt - | Some (_, Some builder, _) when not builder.IsAlive -> - System.Diagnostics.Debug.Assert(false,"unexpected dead builder") - return dflt - | Some (scope, builderOpt, reactor) -> - // Increment the usage count to ensure the builder doesn't get released while running operations asynchronously. - use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt - let! res = reactor.EnqueueAndAwaitOpAsync(userOpName, opName, filename, fun ctok -> f ctok scope |> cancellable.Return) - return res - } - - // Run an operation that can be called from any thread - let threadSafeOp dflt f = - match details with - | None -> dflt() - | Some (scope, _builderOpt, _ops) -> f scope - - // At the moment we only dispose on finalize - we never explicitly dispose these objects. Explicitly disposing is not - // really worth much since the underlying project builds are likely to still be in the incrementalBuilder cache. - override info.Finalize() = dispose() - - member info.Errors = errors - - member info.HasFullTypeCheckInfo = details.IsSome - - /// Intellisense autocompletions - member info.GetDeclarationListInfo(parseResultsOpt, line, lineStr, partialName, ?getAllEntities, ?hasTextChangedSinceLastTypecheck, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - let getAllEntities = defaultArg getAllEntities (fun() -> []) - let hasTextChangedSinceLastTypecheck = defaultArg hasTextChangedSinceLastTypecheck (fun _ -> false) - reactorOp userOpName "GetDeclarations" FSharpDeclarationListInfo.Empty (fun ctok scope -> - scope.GetDeclarations(ctok, parseResultsOpt, line, lineStr, partialName, getAllEntities, hasTextChangedSinceLastTypecheck)) - - member info.GetDeclarationListSymbols(parseResultsOpt, line, lineStr, partialName, ?getAllEntities, ?hasTextChangedSinceLastTypecheck, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - let hasTextChangedSinceLastTypecheck = defaultArg hasTextChangedSinceLastTypecheck (fun _ -> false) - let getAllEntities = defaultArg getAllEntities (fun() -> []) - reactorOp userOpName "GetDeclarationListSymbols" List.empty (fun ctok scope -> scope.GetDeclarationListSymbols(ctok, parseResultsOpt, line, lineStr, partialName, getAllEntities, hasTextChangedSinceLastTypecheck)) - - /// Resolve the names at the given location to give a data tip - member info.GetStructuredToolTipText(line, colAtEndOfNames, lineStr, names, tokenTag, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - let dflt = FSharpToolTipText [] - match tokenTagToTokenId tokenTag with - | TOKEN_IDENT -> - reactorOp userOpName "GetStructuredToolTipText" dflt (fun ctok scope -> scope.GetStructuredToolTipText(ctok, line, lineStr, colAtEndOfNames, names)) - | TOKEN_STRING | TOKEN_STRING_TEXT -> - reactorOp userOpName "GetReferenceResolutionToolTipText" dflt (fun ctok scope -> scope.GetReferenceResolutionStructuredToolTipText(ctok, line, colAtEndOfNames) ) - | _ -> - async.Return dflt - - - member info.GetToolTipText(line, colAtEndOfNames, lineStr, names, tokenTag, userOpName) = - info.GetStructuredToolTipText(line, colAtEndOfNames, lineStr, names, tokenTag, ?userOpName=userOpName) - |> Tooltips.Map Tooltips.ToFSharpToolTipText - - member info.GetF1Keyword (line, colAtEndOfNames, lineStr, names, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - reactorOp userOpName "GetF1Keyword" None (fun ctok scope -> - scope.GetF1Keyword (ctok, line, lineStr, colAtEndOfNames, names)) - - // Resolve the names at the given location to a set of methods - member info.GetMethods(line, colAtEndOfNames, lineStr, names, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - let dflt = FSharpMethodGroup("",[| |]) - reactorOp userOpName "GetMethods" dflt (fun ctok scope -> - scope.GetMethods (ctok, line, lineStr, colAtEndOfNames, names)) - - member info.GetDeclarationLocation (line, colAtEndOfNames, lineStr, names, ?preferFlag, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - let dflt = FSharpFindDeclResult.DeclNotFound (FSharpFindDeclFailureReason.Unknown "") - reactorOp userOpName "GetDeclarationLocation" dflt (fun ctok scope -> - scope.GetDeclarationLocation (ctok, line, lineStr, colAtEndOfNames, names, preferFlag)) - - member info.GetSymbolUseAtLocation (line, colAtEndOfNames, lineStr, names, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - reactorOp userOpName "GetSymbolUseAtLocation" None (fun ctok scope -> - scope.GetSymbolUseAtLocation (ctok, line, lineStr, colAtEndOfNames, names) - |> Option.map (fun (sym,denv,m) -> FSharpSymbolUse(scope.TcGlobals,denv,sym,ItemOccurence.Use,m))) - - member info.GetMethodsAsSymbols (line, colAtEndOfNames, lineStr, names, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - reactorOp userOpName "GetMethodsAsSymbols" None (fun ctok scope -> - scope.GetMethodsAsSymbols (ctok, line, lineStr, colAtEndOfNames, names) - |> Option.map (fun (symbols,denv,m) -> - symbols |> List.map (fun sym -> FSharpSymbolUse(scope.TcGlobals,denv,sym,ItemOccurence.Use,m)))) - - member info.GetSymbolAtLocation (line, colAtEndOfNames, lineStr, names, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - reactorOp userOpName "GetSymbolAtLocation" None (fun ctok scope -> - scope.GetSymbolUseAtLocation (ctok, line, lineStr, colAtEndOfNames, names) - |> Option.map (fun (sym,_,_) -> sym)) - - member info.GetFormatSpecifierLocations() = - info.GetFormatSpecifierLocationsAndArity() |> Array.map fst - - member info.GetFormatSpecifierLocationsAndArity() = - threadSafeOp - (fun () -> [| |]) - (fun scope -> - // This operation is not asynchronous - GetFormatSpecifierLocationsAndArity can be run on the calling thread - scope.GetFormatSpecifierLocationsAndArity()) - - member __.GetSemanticClassification(range: range option) = - threadSafeOp - (fun () -> [| |]) - (fun scope -> - // This operation is not asynchronous - GetSemanticClassification can be run on the calling thread - scope.GetSemanticClassification(range)) - - member __.PartialAssemblySignature = - threadSafeOp - (fun () -> failwith "not available") - (fun scope -> - // This operation is not asynchronous - PartialAssemblySignature can be run on the calling thread - scope.PartialAssemblySignatureForFile) - - member __.ProjectContext = - threadSafeOp - (fun () -> failwith "not available") - (fun scope -> - // This operation is not asynchronous - GetReferencedAssemblies can be run on the calling thread - FSharpProjectContext(scope.ThisCcu, scope.GetReferencedAssemblies(), scope.AccessRights)) - - member __.DependencyFiles = dependencyFiles - - member info.GetAllUsesOfAllSymbolsInFile() = - threadSafeOp - (fun () -> [| |]) - (fun scope -> - let cenv = scope.SymbolEnv + if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then + let symbol = FSharpSymbol.Create(cenv, symbolUse.Item) + yield FSharpSymbolUse(tcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range) |] + |> async.Return + + member __.ProjectContext = + let (tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() + let assemblies = + [ for x in tcImports.GetImportedAssemblies() do + yield FSharpAssembly(tcGlobals, tcImports, x.FSharpViewOfMetadata) ] + FSharpProjectContext(thisCcu, assemblies, ad) + + member __.RawFSharpAssemblyData = + let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() + tcAssemblyData + + member __.DependencyFiles = + let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, dependencyFiles) = getDetails() + dependencyFiles + + member __.AssemblyFullName = + let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() + ilAssemRef.QualifiedName + + override info.ToString() = "FSharpCheckProjectResults(" + projectFileName + ")" + +[] +/// A live object of this type keeps the background corresponding background builder (and type providers) alive (through reference-counting). +// +// There is an important property of all the objects returned by the methods of this type: they do not require +// the corresponding background builder to be alive. That is, they are simply plain-old-data through pre-formatting of all result text. +type FSharpCheckFileResults(filename: string, errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo option, dependencyFiles: string[], builderX: IncrementalBuilder option, reactorOpsX:IReactorOperations, keepAssemblyContents: bool) = + + // This may be None initially, or may be set to None when the object is disposed or finalized + let mutable details = match scopeOptX with None -> None | Some scopeX -> Some (scopeX, builderX, reactorOpsX) + + // Increment the usage count on the IncrementalBuilder. We want to keep the IncrementalBuilder and all associated + // resources and type providers alive for the duration of the lifetime of this object. + let decrementer = + match details with + | Some (_,builderOpt,_) -> IncrementalBuilder.KeepBuilderAlive builderOpt + | _ -> { new System.IDisposable with member x.Dispose() = () } + + let mutable disposed = false + + let dispose() = + if not disposed then + disposed <- true + match details with + | Some (_,_,reactor) -> + // Make sure we run disposal in the reactor thread, since it may trigger type provider disposals etc. + details <- None + reactor.EnqueueOp ("GCFinalizer","FSharpCheckFileResults.DecrementUsageCountOnIncrementalBuilder", filename, fun ctok -> + RequireCompilationThread ctok + decrementer.Dispose()) + | _ -> () + + // Run an operation that needs to access a builder and be run in the reactor thread + let reactorOp userOpName opName dflt f = + async { + match details with + | None -> + return dflt + | Some (_, Some builder, _) when not builder.IsAlive -> + System.Diagnostics.Debug.Assert(false,"unexpected dead builder") + return dflt + | Some (scope, builderOpt, reactor) -> + // Increment the usage count to ensure the builder doesn't get released while running operations asynchronously. + use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt + let! res = reactor.EnqueueAndAwaitOpAsync(userOpName, opName, filename, fun ctok -> f ctok scope |> cancellable.Return) + return res + } + + // Run an operation that can be called from any thread + let threadSafeOp dflt f = + match details with + | None -> dflt() + | Some (scope, _builderOpt, _ops) -> f scope + + // At the moment we only dispose on finalize - we never explicitly dispose these objects. Explicitly disposing is not + // really worth much since the underlying project builds are likely to still be in the incrementalBuilder cache. + override info.Finalize() = dispose() + + member info.Errors = errors + + member info.HasFullTypeCheckInfo = details.IsSome + + /// Intellisense autocompletions + member info.GetDeclarationListInfo(parseResultsOpt, line, lineStr, partialName, ?getAllEntities, ?hasTextChangedSinceLastTypecheck, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + let getAllEntities = defaultArg getAllEntities (fun() -> []) + let hasTextChangedSinceLastTypecheck = defaultArg hasTextChangedSinceLastTypecheck (fun _ -> false) + reactorOp userOpName "GetDeclarations" FSharpDeclarationListInfo.Empty (fun ctok scope -> + scope.GetDeclarations(ctok, parseResultsOpt, line, lineStr, partialName, getAllEntities, hasTextChangedSinceLastTypecheck)) + + member info.GetDeclarationListSymbols(parseResultsOpt, line, lineStr, partialName, ?getAllEntities, ?hasTextChangedSinceLastTypecheck, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + let hasTextChangedSinceLastTypecheck = defaultArg hasTextChangedSinceLastTypecheck (fun _ -> false) + let getAllEntities = defaultArg getAllEntities (fun() -> []) + reactorOp userOpName "GetDeclarationListSymbols" List.empty (fun ctok scope -> scope.GetDeclarationListSymbols(ctok, parseResultsOpt, line, lineStr, partialName, getAllEntities, hasTextChangedSinceLastTypecheck)) + + /// Resolve the names at the given location to give a data tip + member info.GetStructuredToolTipText(line, colAtEndOfNames, lineStr, names, tokenTag, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + let dflt = FSharpToolTipText [] + match tokenTagToTokenId tokenTag with + | TOKEN_IDENT -> + reactorOp userOpName "GetStructuredToolTipText" dflt (fun ctok scope -> scope.GetStructuredToolTipText(ctok, line, lineStr, colAtEndOfNames, names)) + | TOKEN_STRING | TOKEN_STRING_TEXT -> + reactorOp userOpName "GetReferenceResolutionToolTipText" dflt (fun ctok scope -> scope.GetReferenceResolutionStructuredToolTipText(ctok, line, colAtEndOfNames) ) + | _ -> + async.Return dflt + + + member info.GetToolTipText(line, colAtEndOfNames, lineStr, names, tokenTag, userOpName) = + info.GetStructuredToolTipText(line, colAtEndOfNames, lineStr, names, tokenTag, ?userOpName=userOpName) + |> Tooltips.Map Tooltips.ToFSharpToolTipText + + member info.GetF1Keyword (line, colAtEndOfNames, lineStr, names, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + reactorOp userOpName "GetF1Keyword" None (fun ctok scope -> + scope.GetF1Keyword (ctok, line, lineStr, colAtEndOfNames, names)) + + // Resolve the names at the given location to a set of methods + member info.GetMethods(line, colAtEndOfNames, lineStr, names, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + let dflt = FSharpMethodGroup("",[| |]) + reactorOp userOpName "GetMethods" dflt (fun ctok scope -> + scope.GetMethods (ctok, line, lineStr, colAtEndOfNames, names)) + + member info.GetDeclarationLocation (line, colAtEndOfNames, lineStr, names, ?preferFlag, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + let dflt = FSharpFindDeclResult.DeclNotFound (FSharpFindDeclFailureReason.Unknown "") + reactorOp userOpName "GetDeclarationLocation" dflt (fun ctok scope -> + scope.GetDeclarationLocation (ctok, line, lineStr, colAtEndOfNames, names, preferFlag)) + + member info.GetSymbolUseAtLocation (line, colAtEndOfNames, lineStr, names, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + reactorOp userOpName "GetSymbolUseAtLocation" None (fun ctok scope -> + scope.GetSymbolUseAtLocation (ctok, line, lineStr, colAtEndOfNames, names) + |> Option.map (fun (sym,denv,m) -> FSharpSymbolUse(scope.TcGlobals,denv,sym,ItemOccurence.Use,m))) + + member info.GetMethodsAsSymbols (line, colAtEndOfNames, lineStr, names, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + reactorOp userOpName "GetMethodsAsSymbols" None (fun ctok scope -> + scope.GetMethodsAsSymbols (ctok, line, lineStr, colAtEndOfNames, names) + |> Option.map (fun (symbols,denv,m) -> + symbols |> List.map (fun sym -> FSharpSymbolUse(scope.TcGlobals,denv,sym,ItemOccurence.Use,m)))) + + member info.GetSymbolAtLocation (line, colAtEndOfNames, lineStr, names, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + reactorOp userOpName "GetSymbolAtLocation" None (fun ctok scope -> + scope.GetSymbolUseAtLocation (ctok, line, lineStr, colAtEndOfNames, names) + |> Option.map (fun (sym,_,_) -> sym)) + + member info.GetFormatSpecifierLocations() = + info.GetFormatSpecifierLocationsAndArity() |> Array.map fst + + member info.GetFormatSpecifierLocationsAndArity() = + threadSafeOp + (fun () -> [| |]) + (fun scope -> + // This operation is not asynchronous - GetFormatSpecifierLocationsAndArity can be run on the calling thread + scope.GetFormatSpecifierLocationsAndArity()) + + member __.GetSemanticClassification(range: range option) = + threadSafeOp + (fun () -> [| |]) + (fun scope -> + // This operation is not asynchronous - GetSemanticClassification can be run on the calling thread + scope.GetSemanticClassification(range)) + + member __.PartialAssemblySignature = + threadSafeOp + (fun () -> failwith "not available") + (fun scope -> + // This operation is not asynchronous - PartialAssemblySignature can be run on the calling thread + scope.PartialAssemblySignatureForFile) + + member __.ProjectContext = + threadSafeOp + (fun () -> failwith "not available") + (fun scope -> + // This operation is not asynchronous - GetReferencedAssemblies can be run on the calling thread + FSharpProjectContext(scope.ThisCcu, scope.GetReferencedAssemblies(), scope.AccessRights)) + + member __.DependencyFiles = dependencyFiles + + member info.GetAllUsesOfAllSymbolsInFile() = + threadSafeOp + (fun () -> [| |]) + (fun scope -> + let cenv = scope.SymbolEnv [| for symbolUseChunk in scope.ScopeSymbolUses.AllUsesOfSymbols do for symbolUse in symbolUseChunk do - if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then - let symbol = FSharpSymbol.Create(cenv, symbolUse.Item) - yield FSharpSymbolUse(scope.TcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range) |]) - |> async.Return - - member info.GetUsesOfSymbolInFile(symbol:FSharpSymbol) = - threadSafeOp - (fun () -> [| |]) - (fun scope -> - [| for symbolUse in scope.ScopeSymbolUses.GetUsesOfSymbol(symbol.Item) |> Seq.distinctBy (fun symbolUse -> symbolUse.ItemOccurence, symbolUse.Range) do - if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then - yield FSharpSymbolUse(scope.TcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range) |]) - |> async.Return - - member info.GetVisibleNamespacesAndModulesAtPoint(pos: pos) = - threadSafeOp - (fun () -> [| |]) - (fun scope -> scope.GetVisibleNamespacesAndModulesAtPosition(pos) |> List.toArray) - |> async.Return - - member info.IsRelativeNameResolvable(pos: pos, plid: string list, item: Item, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - reactorOp userOpName "IsRelativeNameResolvable" true (fun ctok scope -> - RequireCompilationThread ctok - scope.IsRelativeNameResolvable(pos, plid, item)) - - member info.IsRelativeNameResolvableFromSymbol(pos: pos, plid: string list, symbol: FSharpSymbol, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - reactorOp userOpName "IsRelativeNameResolvableFromSymbol" true (fun ctok scope -> - RequireCompilationThread ctok - scope.IsRelativeNameResolvableFromSymbol(pos, plid, symbol)) - - member info.GetDisplayEnvForPos(pos: pos) : Async = - let userOpName = "CodeLens" - reactorOp userOpName "GetDisplayContextAtPos" None (fun ctok scope -> - DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok - let (nenv, _), _ = scope.GetBestDisplayEnvForPos pos - Some nenv.DisplayEnv) - - member info.ImplementationFile = - if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to true on the FSharpChecker in order to access the checked contents of assemblies" - scopeOptX - |> Option.map (fun scope -> - let cenv = SymbolEnv(scope.TcGlobals, scope.ThisCcu, Some scope.CcuSigForFile, scope.TcImports) - scope.ImplementationFile |> Option.map (fun implFile -> FSharpImplementationFileContents(cenv, implFile))) - |> Option.defaultValue None - - member info.OpenDeclarations = - scopeOptX - |> Option.map (fun scope -> - let cenv = scope.SymbolEnv - scope.OpenDeclarations |> Array.map (fun x -> FSharpOpenDeclaration(x.LongId, x.Range, (x.Modules |> List.map (fun x -> FSharpEntity(cenv, x))), x.AppliedScope, x.IsOwnNamespace))) - |> Option.defaultValue [| |] - - override info.ToString() = "FSharpCheckFileResults(" + filename + ")" - -//---------------------------------------------------------------------------- -// BackgroundCompiler -// - -[] -type FSharpCheckFileAnswer = - | Aborted - | Succeeded of FSharpCheckFileResults - - -/// Callback that indicates whether a requested result has become obsolete. -[] -type IsResultObsolete = - | IsResultObsolete of (unit->bool) - - -[] -module Helpers = - - // Look for DLLs in the location of the service DLL first. - let defaultFSharpBinariesDir = FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(Some(typeof.Assembly.Location)).Value - - /// Determine whether two (fileName,options) keys are identical w.r.t. affect on checking - let AreSameForChecking2((fileName1: string, options1: FSharpProjectOptions), (fileName2, options2)) = - (fileName1 = fileName2) - && FSharpProjectOptions.AreSameForChecking(options1,options2) - - /// Determine whether two (fileName,options) keys should be identical w.r.t. resource usage - let AreSubsumable2((fileName1:string,o1:FSharpProjectOptions),(fileName2:string,o2:FSharpProjectOptions)) = - (fileName1 = fileName2) - && FSharpProjectOptions.UseSameProject(o1,o2) - - /// Determine whether two (fileName,sourceText,options) keys should be identical w.r.t. parsing - let AreSameForParsing((fileName1: string, source1: string, options1), (fileName2, source2, options2)) = - fileName1 = fileName2 && options1 = options2 && source1 = source2 - - let AreSimilarForParsing((fileName1, _, _), (fileName2, _, _)) = - fileName1 = fileName2 - - /// Determine whether two (fileName,sourceText,options) keys should be identical w.r.t. checking - let AreSameForChecking3((fileName1: string, source1: string, options1: FSharpProjectOptions), (fileName2, source2, options2)) = - (fileName1 = fileName2) - && FSharpProjectOptions.AreSameForChecking(options1,options2) - && (source1 = source2) - - /// Determine whether two (fileName,sourceText,options) keys should be identical w.r.t. resource usage - let AreSubsumable3((fileName1:string,_,o1:FSharpProjectOptions),(fileName2:string,_,o2:FSharpProjectOptions)) = - (fileName1 = fileName2) - && FSharpProjectOptions.UseSameProject(o1,o2) - -module CompileHelpers = - let mkCompilationErorHandlers() = - let errors = ResizeArray<_>() - - let errorSink isError exn = - let mainError, relatedErrors = SplitRelatedDiagnostics exn - let oneError e = errors.Add(FSharpErrorInfo.CreateFromException (e, isError, Range.range0)) - oneError mainError - List.iter oneError relatedErrors - - let errorLogger = - { new ErrorLogger("CompileAPI") with - member x.DiagnosticSink(exn, isError) = errorSink isError exn - member x.ErrorCount = errors |> Seq.filter (fun e -> e.Severity = FSharpErrorSeverity.Error) |> Seq.length } - - let loggerProvider = - { new ErrorLoggerProvider() with - member x.CreateErrorLoggerUpToMaxErrors(_tcConfigBuilder, _exiter) = errorLogger } - errors, errorLogger, loggerProvider - - let tryCompile errorLogger f = - use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) - use unwindEL_2 = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger) - let exiter = { new Exiter with member x.Exit n = raise StopProcessing } - try - f exiter - 0 - with e -> - stopProcessingRecovery e Range.range0 - 1 - - /// Compile using the given flags. Source files names are resolved via the FileSystem API. The output file must be given by a -o flag. - let compileFromArgs (ctok, argv: string[], legacyReferenceResolver, tcImportsCapture, dynamicAssemblyCreator) = - - let errors, errorLogger, loggerProvider = mkCompilationErorHandlers() - let result = - tryCompile errorLogger (fun exiter -> - mainCompile (ctok, argv, legacyReferenceResolver, (*bannerAlreadyPrinted*)true, ReduceMemoryFlag.Yes, CopyFSharpCoreFlag.No, exiter, loggerProvider, tcImportsCapture, dynamicAssemblyCreator) ) - - errors.ToArray(), result - - let compileFromAsts (ctok, legacyReferenceResolver, asts, assemblyName, outFile, dependencies, noframework, pdbFile, executable, tcImportsCapture, dynamicAssemblyCreator) = - - let errors, errorLogger, loggerProvider = mkCompilationErorHandlers() - - let executable = defaultArg executable true - let target = if executable then CompilerTarget.ConsoleExe else CompilerTarget.Dll - - let result = - tryCompile errorLogger (fun exiter -> - compileOfAst (ctok, legacyReferenceResolver, ReduceMemoryFlag.Yes, assemblyName, target, outFile, pdbFile, dependencies, noframework, exiter, loggerProvider, asts, tcImportsCapture, dynamicAssemblyCreator)) - - errors.ToArray(), result - - let createDynamicAssembly (ctok, debugInfo: bool, tcImportsRef: TcImports option ref, execute: bool, assemblyBuilderRef: _ option ref) (tcGlobals:TcGlobals, outfile, ilxMainModule) = - - // Create an assembly builder - let assemblyName = System.Reflection.AssemblyName(System.IO.Path.GetFileNameWithoutExtension outfile) - let flags = System.Reflection.Emit.AssemblyBuilderAccess.Run -#if FX_NO_APP_DOMAINS - let assemblyBuilder = System.Reflection.Emit.AssemblyBuilder.DefineDynamicAssembly(assemblyName, flags) - let moduleBuilder = assemblyBuilder.DefineDynamicModule("IncrementalModule") -#else - let assemblyBuilder = AppDomain.CurrentDomain.DefineDynamicAssembly(assemblyName, flags) - let moduleBuilder = assemblyBuilder.DefineDynamicModule("IncrementalModule", debugInfo) -#endif - // Omit resources in dynamic assemblies, because the module builder is constructed without a filename the module - // is tagged as transient and as such DefineManifestResource will throw an invalid operation if resources are present. - // - // Also, the dynamic assembly creator can't currently handle types called "" from statically linked assemblies. - let ilxMainModule = - { ilxMainModule with - TypeDefs = ilxMainModule.TypeDefs.AsList |> List.filter (fun td -> not (isTypeNameForGlobalFunctions td.Name)) |> mkILTypeDefs - Resources=mkILResources [] } - - // The function used to resolve typees while emitting the code - let assemblyResolver s = - match tcImportsRef.Value.Value.TryFindExistingFullyQualifiedPathByExactAssemblyRef (ctok, s) with - | Some res -> Some (Choice1Of2 res) - | None -> None - - // Emit the code - let _emEnv,execs = ILRuntimeWriter.emitModuleFragment(tcGlobals.ilg, ILRuntimeWriter.emEnv0, assemblyBuilder, moduleBuilder, ilxMainModule, debugInfo, assemblyResolver, tcGlobals.TryFindSysILTypeRef) - - // Execute the top-level initialization, if requested - if execute then - for exec in execs do - match exec() with - | None -> () - | Some exn -> - PreserveStackTrace(exn) - raise exn - - // Register the reflected definitions for the dynamically generated assembly - for resource in ilxMainModule.Resources.AsList do - if IsReflectedDefinitionsResource resource then - Quotations.Expr.RegisterReflectedDefinitions(assemblyBuilder, moduleBuilder.Name, resource.GetBytes()) - - // Save the result - assemblyBuilderRef := Some assemblyBuilder - - let setOutputStreams execute = - // Set the output streams, if requested - match execute with - | Some (writer,error) -> - System.Console.SetOut writer - System.Console.SetError error - | None -> () - - -type FileName = string -type Source = string -type FilePath = string -type ProjectPath = string -type FileVersion = int - -type ParseCacheLockToken() = interface LockToken -type ScriptClosureCacheToken() = interface LockToken - - -// There is only one instance of this type, held in FSharpChecker -type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) as self = - // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.reactor: The one and only Reactor - let reactor = Reactor.Singleton - let beforeFileChecked = Event() - let fileParsed = Event() - let fileChecked = Event() - let projectChecked = Event() - - - let mutable implicitlyStartBackgroundWork = true - let reactorOps = - { new IReactorOperations with - member __.EnqueueAndAwaitOpAsync (userOpName, opName, opArg, op) = reactor.EnqueueAndAwaitOpAsync (userOpName, opName, opArg, op) - member __.EnqueueOp (userOpName, opName, opArg, op) = reactor.EnqueueOp (userOpName, opName, opArg, op) } - - // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.scriptClosureCache - /// Information about the derived script closure. - let scriptClosureCache = - MruCache(projectCacheSize, - areSame=FSharpProjectOptions.AreSameForChecking, - areSimilar=FSharpProjectOptions.UseSameProject) - - let scriptClosureCacheLock = Lock() - let frameworkTcImportsCache = FrameworkImportsCache(frameworkTcImportsCacheStrongSize) - - /// CreateOneIncrementalBuilder (for background type checking). Note that fsc.fs also - /// creates an incremental builder used by the command line compiler. - let CreateOneIncrementalBuilder (ctok, options:FSharpProjectOptions, userOpName) = - cancellable { - Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "CreateOneIncrementalBuilder", options.ProjectFileName) - let projectReferences = - [ for (nm,opts) in options.ReferencedProjects do - - // Don't use cross-project references for FSharp.Core, since various bits of code require a concrete FSharp.Core to exist on-disk. - // The only solutions that have these cross-project references to FSharp.Core are VisualFSharp.sln and FSharp.sln. The only ramification - // of this is that you need to build FSharp.Core to get intellisense in those projects. - - if (try Path.GetFileNameWithoutExtension(nm) with _ -> "") <> GetFSharpCoreLibraryName() then - - yield - { new IProjectReference with - member x.EvaluateRawContents(ctok) = - cancellable { - Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "ParseAndCheckProjectImpl", nm) - let! r = self.ParseAndCheckProjectImpl(opts, ctok, userOpName + ".CheckReferencedProject("+nm+")") - return r.RawFSharpAssemblyData - } - member x.TryGetLogicalTimeStamp(cache, ctok) = - self.TryGetLogicalTimeStampForProject(cache, ctok, opts, userOpName + ".TimeStampReferencedProject("+nm+")") - member x.FileName = nm } ] - - let loadClosure = scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.TryGet (ltok, options)) - let! builderOpt, diagnostics = - IncrementalBuilder.TryCreateBackgroundBuilderForProjectOptions - (ctok, legacyReferenceResolver, defaultFSharpBinariesDir, frameworkTcImportsCache, loadClosure, Array.toList options.SourceFiles, - Array.toList options.OtherOptions, projectReferences, options.ProjectDirectory, - options.UseScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds, - tryGetMetadataSnapshot) - - // We're putting the builder in the cache, so increment its count. - let decrement = IncrementalBuilder.KeepBuilderAlive builderOpt - - match builderOpt with - | None -> () - | Some builder -> - - // Register the behaviour that responds to CCUs being invalidated because of type - // provider Invalidate events. This invalidates the configuration in the build. - builder.ImportedCcusInvalidated.Add (fun _ -> - self.InvalidateConfiguration(options, None, userOpName)) - - // Register the callback called just before a file is typechecked by the background builder (without recording - // errors or intellisense information). - // - // This indicates to the UI that the file type check state is dirty. If the file is open and visible then - // the UI will sooner or later request a typecheck of the file, recording errors and intellisense information. - builder.BeforeFileChecked.Add (fun file -> beforeFileChecked.Trigger(file, options.ExtraProjectInfo)) - builder.FileParsed.Add (fun file -> fileParsed.Trigger(file, options.ExtraProjectInfo)) - builder.FileChecked.Add (fun file -> fileChecked.Trigger(file, options.ExtraProjectInfo)) - builder.ProjectChecked.Add (fun () -> projectChecked.Trigger (options.ProjectFileName, options.ExtraProjectInfo)) - - return (builderOpt, diagnostics, decrement) - } - - // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.incrementalBuildersCache. This root typically holds more - // live information than anything else in the F# Language Service, since it holds up to 3 (projectCacheStrongSize) background project builds - // strongly. - // - /// Cache of builds keyed by options. - let incrementalBuildersCache = - MruCache - (keepStrongly=projectCacheSize, keepMax=projectCacheSize, - areSame = FSharpProjectOptions.AreSameForChecking, - areSimilar = FSharpProjectOptions.UseSameProject, - requiredToKeep=(fun (builderOpt,_,_) -> match builderOpt with None -> false | Some (b:IncrementalBuilder) -> b.IsBeingKeptAliveApartFromCacheEntry), - onDiscard = (fun (_, _, decrement:IDisposable) -> decrement.Dispose())) - - let getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) = - cancellable { - RequireCompilationThread ctok - match incrementalBuildersCache.TryGet (ctok, options) with - | Some (builderOpt,creationErrors,_) -> - Logger.Log LogCompilerFunctionId.Service_IncrementalBuildersCache_BuildingNewCache - let decrement = IncrementalBuilder.KeepBuilderAlive builderOpt - return builderOpt,creationErrors, decrement - | None -> - Logger.Log LogCompilerFunctionId.Service_IncrementalBuildersCache_GettingCache - let! (builderOpt,creationErrors,_) as info = CreateOneIncrementalBuilder (ctok, options, userOpName) - incrementalBuildersCache.Set (ctok, options, info) - let decrement = IncrementalBuilder.KeepBuilderAlive builderOpt - return builderOpt, creationErrors, decrement - } - - let parseCacheLock = Lock() - - - // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.parseFileInProjectCache. Most recently used cache for parsing files. - let parseFileCache = MruCache(parseFileCacheSize, areSimilar = AreSimilarForParsing, areSame = AreSameForParsing) - - // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.checkFileInProjectCachePossiblyStale - // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.checkFileInProjectCache - // - /// Cache which holds recently seen type-checks. - /// This cache may hold out-of-date entries, in two senses - /// - there may be a more recent antecedent state available because the background build has made it available - /// - the source for the file may have changed - - let checkFileInProjectCachePossiblyStale = - MruCache - (keepStrongly=checkFileInProjectCacheSize, - areSame=AreSameForChecking2, - areSimilar=AreSubsumable2) - - // Also keyed on source. This can only be out of date if the antecedent is out of date - let checkFileInProjectCache = - MruCache - (keepStrongly=checkFileInProjectCacheSize, - areSame=AreSameForChecking3, - areSimilar=AreSubsumable3) - - /// Holds keys for files being currently checked. It's used to prevent checking same file in parallel (interleaving chunck queued to Reactor). - let beingCheckedFileTable = - ConcurrentDictionary - (HashIdentity.FromFunctions - hash - (fun (f1, o1, v1) (f2, o2, v2) -> f1 = f2 && v1 = v2 && FSharpProjectOptions.AreSameForChecking(o1, o2))) - - static let mutable foregroundParseCount = 0 - static let mutable foregroundTypeCheckCount = 0 - - let MakeCheckFileResultsEmpty(filename, creationErrors) = - FSharpCheckFileResults (filename, creationErrors, None, [| |], None, reactorOps, keepAssemblyContents) - - let MakeCheckFileResults(filename, options:FSharpProjectOptions, builder, scope, dependencyFiles, creationErrors, parseErrors, tcErrors) = - let errors = - [| yield! creationErrors - yield! parseErrors - if options.IsIncompleteTypeCheckEnvironment then - yield! Seq.truncate maxTypeCheckErrorsOutOfProjectContext tcErrors - else - yield! tcErrors |] - - FSharpCheckFileResults (filename, errors, Some scope, dependencyFiles, Some builder, reactorOps, keepAssemblyContents) - - let MakeCheckFileAnswer(filename, tcFileResult, options:FSharpProjectOptions, builder, dependencyFiles, creationErrors, parseErrors, tcErrors) = - match tcFileResult with - | Parser.TypeCheckAborted.Yes -> FSharpCheckFileAnswer.Aborted - | Parser.TypeCheckAborted.No scope -> FSharpCheckFileAnswer.Succeeded(MakeCheckFileResults(filename, options, builder, scope, dependencyFiles, creationErrors, parseErrors, tcErrors)) - - member bc.RecordTypeCheckFileInProjectResults(filename,options,parsingOptions,parseResults,fileVersion,priorTimeStamp,checkAnswer,source) = - match checkAnswer with - | None - | Some FSharpCheckFileAnswer.Aborted -> () - | Some (FSharpCheckFileAnswer.Succeeded typedResults) -> - foregroundTypeCheckCount <- foregroundTypeCheckCount + 1 - parseCacheLock.AcquireLock (fun ltok -> - checkFileInProjectCachePossiblyStale.Set(ltok, (filename,options),(parseResults,typedResults,fileVersion)) - checkFileInProjectCache.Set(ltok, (filename,source,options),(parseResults,typedResults,fileVersion,priorTimeStamp)) - parseFileCache.Set(ltok, (filename, source, parsingOptions), parseResults)) - - member bc.ImplicitlyStartCheckProjectInBackground(options, userOpName) = - if implicitlyStartBackgroundWork then - bc.CheckProjectInBackground(options, userOpName + ".ImplicitlyStartCheckProjectInBackground") - - member bc.ParseFile(filename: string, source: string, options: FSharpParsingOptions, userOpName: string) = - async { - match parseCacheLock.AcquireLock(fun ltok -> parseFileCache.TryGet(ltok, (filename, source, options))) with - | Some res -> return res - | None -> - foregroundParseCount <- foregroundParseCount + 1 - let parseErrors, parseTreeOpt, anyErrors = Parser.parseFile(source, filename, options, userOpName) - let res = FSharpParseFileResults(parseErrors, parseTreeOpt, anyErrors, options.SourceFiles) - parseCacheLock.AcquireLock(fun ltok -> parseFileCache.Set(ltok, (filename, source, options), res)) - return res - } - - /// Fetch the parse information from the background compiler (which checks w.r.t. the FileSystem API) - member bc.GetBackgroundParseResultsForFileInProject(filename, options, userOpName) = - reactor.EnqueueAndAwaitOpAsync(userOpName, "GetBackgroundParseResultsForFileInProject ", filename, fun ctok -> - cancellable { - let! builderOpt, creationErrors, decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) - use _unwind = decrement - match builderOpt with - | None -> return FSharpParseFileResults(creationErrors, None, true, [| |]) - | Some builder -> - let! parseTreeOpt,_,_,parseErrors = builder.GetParseResultsForFile (ctok, filename) - let errors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (builder.TcConfig.errorSeverityOptions, false, filename, parseErrors) |] - return FSharpParseFileResults(errors = errors, input = parseTreeOpt, parseHadErrors = false, dependencyFiles = builder.AllDependenciesDeprecated) - } - ) - - member bc.GetCachedCheckFileResult(builder: IncrementalBuilder,filename,source,options) = - // Check the cache. We can only use cached results when there is no work to do to bring the background builder up-to-date - let cachedResults = parseCacheLock.AcquireLock (fun ltok -> checkFileInProjectCache.TryGet(ltok, (filename,source,options))) - - match cachedResults with -// | Some (parseResults, checkResults, _, _) when builder.AreCheckResultsBeforeFileInProjectReady(filename) -> - | Some (parseResults, checkResults,_,priorTimeStamp) - when - (match builder.GetCheckResultsBeforeFileInProjectEvenIfStale filename with - | None -> false - | Some(tcPrior) -> - tcPrior.TimeStamp = priorTimeStamp && - builder.AreCheckResultsBeforeFileInProjectReady(filename)) -> - Some (parseResults,checkResults) - | _ -> None - - /// 1. Repeatedly try to get cached file check results or get file "lock". - /// - /// 2. If it've got cached results, returns them. - /// - /// 3. If it've not got the lock for 1 minute, returns `FSharpCheckFileAnswer.Aborted`. - /// - /// 4. Type checks the file. - /// - /// 5. Records results in `BackgroundCompiler` caches. - /// - /// 6. Starts whole project background compilation. - /// - /// 7. Releases the file "lock". - member private bc.CheckOneFileImpl - (parseResults: FSharpParseFileResults, - source: string, - fileName: string, - options: FSharpProjectOptions, - textSnapshotInfo: obj option, - fileVersion: int, - builder: IncrementalBuilder, - tcPrior: PartialCheckResults, - creationErrors: FSharpErrorInfo[], - userOpName: string) = - - async { - let beingCheckedFileKey = fileName, options, fileVersion - let stopwatch = Stopwatch.StartNew() - let rec loop() = - async { - // results may appear while we were waiting for the lock, let's recheck if it's the case - let cachedResults = bc.GetCachedCheckFileResult(builder, fileName, source, options) - - match cachedResults with - | Some (_, checkResults) -> return FSharpCheckFileAnswer.Succeeded checkResults - | None -> - if beingCheckedFileTable.TryAdd(beingCheckedFileKey, ()) then - try - // Get additional script #load closure information if applicable. - // For scripts, this will have been recorded by GetProjectOptionsFromScript. - let loadClosure = scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.TryGet (ltok, options)) - let! tcErrors, tcFileResult = - Parser.CheckOneFile(parseResults, source, fileName, options.ProjectFileName, tcPrior.TcConfig, tcPrior.TcGlobals, tcPrior.TcImports, - tcPrior.TcState, tcPrior.ModuleNamesDict, loadClosure, tcPrior.TcErrors, reactorOps, (fun () -> builder.IsAlive), textSnapshotInfo, userOpName) - let parsingOptions = FSharpParsingOptions.FromTcConfig(tcPrior.TcConfig, Array.ofList builder.SourceFiles, options.UseScriptResolutionRules) - let checkAnswer = MakeCheckFileAnswer(fileName, tcFileResult, options, builder, Array.ofList tcPrior.TcDependencyFiles, creationErrors, parseResults.Errors, tcErrors) - bc.RecordTypeCheckFileInProjectResults(fileName, options, parsingOptions, parseResults, fileVersion, tcPrior.TimeStamp, Some checkAnswer, source) - return checkAnswer - finally - let dummy = ref () - beingCheckedFileTable.TryRemove(beingCheckedFileKey, dummy) |> ignore - else - do! Async.Sleep 100 - if stopwatch.Elapsed > TimeSpan.FromMinutes 1. then - return FSharpCheckFileAnswer.Aborted - else - return! loop() - } - return! loop() - } - - /// Type-check the result obtained by parsing, but only if the antecedent type checking context is available. - member bc.CheckFileInProjectAllowingStaleCachedResults(parseResults: FSharpParseFileResults, filename, fileVersion, source, options, textSnapshotInfo: obj option, userOpName) = - let execWithReactorAsync action = reactor.EnqueueAndAwaitOpAsync(userOpName, "CheckFileInProjectAllowingStaleCachedResults ", filename, action) - async { - try - if implicitlyStartBackgroundWork then - reactor.CancelBackgroundOp() // cancel the background work, since we will start new work after we're done - - let! cachedResults = - execWithReactorAsync <| fun ctok -> - cancellable { - let! _builderOpt,_creationErrors,decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) - use _unwind = decrement - - match incrementalBuildersCache.TryGetAny (ctok, options) with - | Some (Some builder, creationErrors, _) -> - match bc.GetCachedCheckFileResult(builder, filename, source, options) with - | Some (_, checkResults) -> return Some (builder, creationErrors, Some (FSharpCheckFileAnswer.Succeeded checkResults)) - | _ -> return Some (builder, creationErrors, None) - | _ -> return None // the builder wasn't ready - } - - match cachedResults with - | None -> return None - | Some (_, _, Some x) -> return Some x - | Some (builder, creationErrors, None) -> - Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "CheckFileInProjectAllowingStaleCachedResults.CacheMiss", filename) - let! tcPrior = - execWithReactorAsync <| fun ctok -> - cancellable { - DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok - return builder.GetCheckResultsBeforeFileInProjectEvenIfStale filename - } - - match tcPrior with - | Some tcPrior -> - let! checkResults = bc.CheckOneFileImpl(parseResults, source, filename, options, textSnapshotInfo, fileVersion, builder, tcPrior, creationErrors, userOpName) - return Some checkResults - | None -> return None // the incremental builder was not up to date - finally - bc.ImplicitlyStartCheckProjectInBackground(options, userOpName) - } - - /// Type-check the result obtained by parsing. Force the evaluation of the antecedent type checking context if needed. - member bc.CheckFileInProject(parseResults: FSharpParseFileResults, filename, fileVersion, source, options, textSnapshotInfo, userOpName) = - let execWithReactorAsync action = reactor.EnqueueAndAwaitOpAsync(userOpName, "CheckFileInProject", filename, action) - async { - try - if implicitlyStartBackgroundWork then - reactor.CancelBackgroundOp() // cancel the background work, since we will start new work after we're done - let! builderOpt,creationErrors, decrement = execWithReactorAsync (fun ctok -> getOrCreateBuilderAndKeepAlive (ctok, options, userOpName)) - use _unwind = decrement - match builderOpt with - | None -> return FSharpCheckFileAnswer.Succeeded (MakeCheckFileResultsEmpty(filename, creationErrors)) - | Some builder -> - // Check the cache. We can only use cached results when there is no work to do to bring the background builder up-to-date - let cachedResults = bc.GetCachedCheckFileResult(builder, filename, source, options) - - match cachedResults with - | Some (_, checkResults) -> return FSharpCheckFileAnswer.Succeeded checkResults - | _ -> - Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "CheckFileInProject.CacheMiss", filename) - let! tcPrior = execWithReactorAsync <| fun ctok -> builder.GetCheckResultsBeforeFileInProject (ctok, filename) - let! checkAnswer = bc.CheckOneFileImpl(parseResults, source, filename, options, textSnapshotInfo, fileVersion, builder, tcPrior, creationErrors, userOpName) - return checkAnswer - finally - bc.ImplicitlyStartCheckProjectInBackground(options, userOpName) - } - - /// Parses and checks the source file and returns untyped AST and check results. - member bc.ParseAndCheckFileInProject (filename:string, fileVersion, source, options:FSharpProjectOptions, textSnapshotInfo, userOpName) = - let execWithReactorAsync action = reactor.EnqueueAndAwaitOpAsync(userOpName, "ParseAndCheckFileInProject", filename, action) - async { - try - let strGuid = "_ProjectId=" + (options.ProjectId |> Option.defaultValue "null") - Logger.LogBlockMessageStart (filename + strGuid) LogCompilerFunctionId.Service_ParseAndCheckFileInProject - - if implicitlyStartBackgroundWork then - Logger.LogMessage (filename + strGuid + "-Cancelling background work") LogCompilerFunctionId.Service_ParseAndCheckFileInProject - reactor.CancelBackgroundOp() // cancel the background work, since we will start new work after we're done - - let! builderOpt,creationErrors,decrement = execWithReactorAsync (fun ctok -> getOrCreateBuilderAndKeepAlive (ctok, options, userOpName)) - use _unwind = decrement - match builderOpt with - | None -> - Logger.LogBlockMessageStop (filename + strGuid + "-Failed_Aborted") LogCompilerFunctionId.Service_ParseAndCheckFileInProject - - let parseResults = FSharpParseFileResults(creationErrors, None, true, [| |]) - return (parseResults, FSharpCheckFileAnswer.Aborted) - - | Some builder -> - let cachedResults = bc.GetCachedCheckFileResult(builder, filename, source, options) - - match cachedResults with - | Some (parseResults, checkResults) -> - Logger.LogBlockMessageStop (filename + strGuid + "-Successful_Cached") LogCompilerFunctionId.Service_ParseAndCheckFileInProject - - return parseResults, FSharpCheckFileAnswer.Succeeded checkResults - | _ -> - // todo this blocks the Reactor queue until all files up to the current are type checked. It's OK while editing the file, - // but results with non cooperative blocking when a firts file from a project opened. - let! tcPrior = execWithReactorAsync <| fun ctok -> builder.GetCheckResultsBeforeFileInProject (ctok, filename) - - // Do the parsing. - let parsingOptions = FSharpParsingOptions.FromTcConfig(builder.TcConfig, Array.ofList (builder.SourceFiles), options.UseScriptResolutionRules) - let parseErrors, parseTreeOpt, anyErrors = Parser.parseFile (source, filename, parsingOptions, userOpName) - let parseResults = FSharpParseFileResults(parseErrors, parseTreeOpt, anyErrors, builder.AllDependenciesDeprecated) - let! checkResults = bc.CheckOneFileImpl(parseResults, source, filename, options, textSnapshotInfo, fileVersion, builder, tcPrior, creationErrors, userOpName) - - Logger.LogBlockMessageStop (filename + strGuid + "-Successful") LogCompilerFunctionId.Service_ParseAndCheckFileInProject - - return parseResults, checkResults - finally - bc.ImplicitlyStartCheckProjectInBackground(options, userOpName) - } - - /// Fetch the check information from the background compiler (which checks w.r.t. the FileSystem API) - member bc.GetBackgroundCheckResultsForFileInProject(filename, options, userOpName) = - reactor.EnqueueAndAwaitOpAsync(userOpName, "GetBackgroundCheckResultsForFileInProject", filename, fun ctok -> - cancellable { - let! builderOpt, creationErrors, decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) - use _unwind = decrement - match builderOpt with - | None -> - let parseResults = FSharpParseFileResults(creationErrors, None, true, [| |]) - let typedResults = MakeCheckFileResultsEmpty(filename, creationErrors) - return (parseResults, typedResults) - | Some builder -> - let! (parseTreeOpt, _, _, untypedErrors) = builder.GetParseResultsForFile (ctok, filename) - let! tcProj = builder.GetCheckResultsAfterFileInProject (ctok, filename) - let errorOptions = builder.TcConfig.errorSeverityOptions - let untypedErrors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, false, filename, untypedErrors) |] - let tcErrors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, false, filename, tcProj.TcErrors) |] - let parseResults = FSharpParseFileResults(errors = untypedErrors, input = parseTreeOpt, parseHadErrors = false, dependencyFiles = builder.AllDependenciesDeprecated) - let loadClosure = scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.TryGet (ltok, options) ) - let scope = - TypeCheckInfo(tcProj.TcConfig, tcProj.TcGlobals, - Option.get tcProj.LastestCcuSigForFile, - tcProj.TcState.Ccu, tcProj.TcImports, tcProj.TcEnvAtEnd.AccessRights, - options.ProjectFileName, filename, - List.head tcProj.TcResolutionsRev, - List.head tcProj.TcSymbolUsesRev, - tcProj.TcEnvAtEnd.NameEnv, - loadClosure, reactorOps, (fun () -> builder.IsAlive), None, - tcProj.LatestImplementationFile, - List.head tcProj.TcOpenDeclarationsRev) - let typedResults = MakeCheckFileResults(filename, options, builder, scope, Array.ofList tcProj.TcDependencyFiles, creationErrors, parseResults.Errors, tcErrors) - return (parseResults, typedResults) - }) - - - /// Try to get recent approximate type check results for a file. - member bc.TryGetRecentCheckResultsForFile(filename: string, options:FSharpProjectOptions, source, _userOpName: string) = - match source with - | Some sourceText -> - parseCacheLock.AcquireLock (fun ltok -> - match checkFileInProjectCache.TryGet(ltok,(filename,sourceText,options)) with - | Some (a,b,c,_) -> Some (a,b,c) - | None -> parseCacheLock.AcquireLock (fun ltok -> checkFileInProjectCachePossiblyStale.TryGet(ltok,(filename,options)))) - | None -> parseCacheLock.AcquireLock (fun ltok -> checkFileInProjectCachePossiblyStale.TryGet(ltok,(filename,options))) - - /// Parse and typecheck the whole project (the implementation, called recursively as project graph is evaluated) - member private bc.ParseAndCheckProjectImpl(options, ctok, userOpName) : Cancellable = - cancellable { - let! builderOpt,creationErrors,decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) - use _unwind = decrement - match builderOpt with - | None -> - return FSharpCheckProjectResults (options.ProjectFileName, None, keepAssemblyContents, creationErrors, None) - | Some builder -> - let! (tcProj, ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt) = builder.GetCheckResultsAndImplementationsForProject(ctok) - let errorOptions = tcProj.TcConfig.errorSeverityOptions - let fileName = TcGlobals.DummyFileNameForRangesWithoutASpecificLocation - let errors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, true, fileName, tcProj.TcErrors) |] - return FSharpCheckProjectResults (options.ProjectFileName, Some tcProj.TcConfig, keepAssemblyContents, errors, - Some(tcProj.TcGlobals, tcProj.TcImports, tcProj.TcState.Ccu, tcProj.TcState.CcuSig, - tcProj.TcSymbolUses, tcProj.TopAttribs, tcAssemblyDataOpt, ilAssemRef, - tcProj.TcEnvAtEnd.AccessRights, tcAssemblyExprOpt, Array.ofList tcProj.TcDependencyFiles)) - } - - /// Get the timestamp that would be on the output if fully built immediately - member private bc.TryGetLogicalTimeStampForProject(cache, ctok, options, userOpName: string) = - - // NOTE: This creation of the background builder is currently run as uncancellable. Creating background builders is generally - // cheap though the timestamp computations look suspicious for transitive project references. - let builderOpt,_creationErrors,decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName + ".TryGetLogicalTimeStampForProject") |> Cancellable.runWithoutCancellation - use _unwind = decrement - match builderOpt with - | None -> None - | Some builder -> Some (builder.GetLogicalTimeStampForProject(cache, ctok)) - - /// Keep the projet builder alive over a scope - member bc.KeepProjectAlive(options, userOpName) = - reactor.EnqueueAndAwaitOpAsync(userOpName, "KeepProjectAlive", options.ProjectFileName, fun ctok -> - cancellable { - let! _builderOpt,_creationErrors,decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) - return decrement - }) - - /// Parse and typecheck the whole project. - member bc.ParseAndCheckProject(options, userOpName) = - reactor.EnqueueAndAwaitOpAsync(userOpName, "ParseAndCheckProject", options.ProjectFileName, fun ctok -> bc.ParseAndCheckProjectImpl(options, ctok, userOpName)) - - member bc.GetProjectOptionsFromScript(filename, source, loadedTimeStamp, otherFlags, useFsiAuxLib: bool option, assumeDotNetFramework: bool option, extraProjectInfo: obj option, optionsStamp: int64 option, userOpName) = - reactor.EnqueueAndAwaitOpAsync (userOpName, "GetProjectOptionsFromScript", filename, fun ctok -> - cancellable { - use errors = new ErrorScope() - - // Do we add a reference to FSharp.Compiler.Interactive.Settings by default? - let useFsiAuxLib = defaultArg useFsiAuxLib true - - let reduceMemoryUsage = ReduceMemoryFlag.Yes - - // Do we assume .NET Framework references for scripts? - let assumeDotNetFramework = defaultArg assumeDotNetFramework true - let otherFlags = defaultArg otherFlags [| |] - let useSimpleResolution = -#if ENABLE_MONO_SUPPORT - runningOnMono || otherFlags |> Array.exists (fun x -> x = "--simpleresolution") -#else - true -#endif - let loadedTimeStamp = defaultArg loadedTimeStamp DateTime.MaxValue // Not 'now', we don't want to force reloading - let applyCompilerOptions tcConfigB = - let fsiCompilerOptions = CompileOptions.GetCoreFsiCompilerOptions tcConfigB - CompileOptions.ParseCompilerOptions (ignore, fsiCompilerOptions, Array.toList otherFlags) - - let loadClosure = - LoadClosure.ComputeClosureOfScriptText(ctok, legacyReferenceResolver, - defaultFSharpBinariesDir, filename, source, - CodeContext.Editing, useSimpleResolution, useFsiAuxLib, new Lexhelp.LexResourceManager(), - applyCompilerOptions, assumeDotNetFramework, - tryGetMetadataSnapshot=tryGetMetadataSnapshot, - reduceMemoryUsage=reduceMemoryUsage) - - let otherFlags = - [| yield "--noframework"; yield "--warn:3"; - yield! otherFlags - for r in loadClosure.References do yield "-r:" + fst r - for (code,_) in loadClosure.NoWarns do yield "--nowarn:" + code - |] - - let options = - { - ProjectFileName = filename + ".fsproj" // Make a name that is unique in this directory. - ProjectId = None - SourceFiles = loadClosure.SourceFiles |> List.map fst |> List.toArray - OtherOptions = otherFlags - ReferencedProjects= [| |] - IsIncompleteTypeCheckEnvironment = false - UseScriptResolutionRules = true - LoadTime = loadedTimeStamp - UnresolvedReferences = Some (UnresolvedReferencesSet(loadClosure.UnresolvedReferences)) - OriginalLoadReferences = loadClosure.OriginalLoadReferences - ExtraProjectInfo=extraProjectInfo - Stamp = optionsStamp - } - scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.Set(ltok, options, loadClosure)) // Save the full load closure for later correlation. - return options, errors.Diagnostics - }) - - member bc.InvalidateConfiguration(options : FSharpProjectOptions, startBackgroundCompileIfAlreadySeen, userOpName) = - let startBackgroundCompileIfAlreadySeen = defaultArg startBackgroundCompileIfAlreadySeen implicitlyStartBackgroundWork - // This operation can't currently be cancelled nor awaited - reactor.EnqueueOp(userOpName, "InvalidateConfiguration: Stamp(" + (options.Stamp |> Option.defaultValue 0L).ToString() + ")", options.ProjectFileName, fun ctok -> - // If there was a similar entry then re-establish an empty builder . This is a somewhat arbitrary choice - it - // will have the effect of releasing memory associated with the previous builder, but costs some time. - if incrementalBuildersCache.ContainsSimilarKey (ctok, options) then - - // We do not need to decrement here - the onDiscard function is called each time an entry is pushed out of the build cache, - // including by incrementalBuildersCache.Set. - let newBuilderInfo = CreateOneIncrementalBuilder (ctok, options, userOpName) |> Cancellable.runWithoutCancellation - incrementalBuildersCache.Set(ctok, options, newBuilderInfo) - - // Start working on the project. Also a somewhat arbitrary choice - if startBackgroundCompileIfAlreadySeen then - bc.CheckProjectInBackground(options, userOpName + ".StartBackgroundCompile")) - - member bc.NotifyProjectCleaned (options : FSharpProjectOptions, userOpName) = - reactor.EnqueueAndAwaitOpAsync(userOpName, "NotifyProjectCleaned", options.ProjectFileName, fun ctok -> - cancellable { - // If there was a similar entry (as there normally will have been) then re-establish an empty builder . This - // is a somewhat arbitrary choice - it will have the effect of releasing memory associated with the previous - // builder, but costs some time. - if incrementalBuildersCache.ContainsSimilarKey (ctok, options) then - // We do not need to decrement here - the onDiscard function is called each time an entry is pushed out of the build cache, - // including by incrementalBuildersCache.Set. - let! newBuilderInfo = CreateOneIncrementalBuilder (ctok, options, userOpName) - incrementalBuildersCache.Set(ctok, options, newBuilderInfo) - }) - - member bc.CheckProjectInBackground (options, userOpName) = - reactor.SetBackgroundOp (Some (userOpName, "CheckProjectInBackground", options.ProjectFileName, (fun ctok ct -> - // The creation of the background builder can't currently be cancelled - match getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) |> Cancellable.run ct with - | ValueOrCancelled.Cancelled _ -> false - | ValueOrCancelled.Value (builderOpt,_,decrement) -> - use _unwind = decrement - match builderOpt with - | None -> false - | Some builder -> - // The individual steps of the background build - match builder.Step(ctok) |> Cancellable.run ct with - | ValueOrCancelled.Value v -> v - | ValueOrCancelled.Cancelled _ -> false))) - - member bc.StopBackgroundCompile () = - reactor.SetBackgroundOp(None) - - member bc.WaitForBackgroundCompile() = - reactor.WaitForBackgroundOpCompletion() - - member bc.CompleteAllQueuedOps() = - reactor.CompleteAllQueuedOps() - - member bc.Reactor = reactor - member bc.ReactorOps = reactorOps - member bc.BeforeBackgroundFileCheck = beforeFileChecked.Publish - member bc.FileParsed = fileParsed.Publish - member bc.FileChecked = fileChecked.Publish - member bc.ProjectChecked = projectChecked.Publish - - member bc.CurrentQueueLength = reactor.CurrentQueueLength - - member bc.ClearCachesAsync (userOpName) = - reactor.EnqueueAndAwaitOpAsync (userOpName, "ClearCachesAsync", "", fun ctok -> - parseCacheLock.AcquireLock (fun ltok -> - checkFileInProjectCachePossiblyStale.Clear ltok - checkFileInProjectCache.Clear ltok - parseFileCache.Clear(ltok)) - incrementalBuildersCache.Clear ctok - frameworkTcImportsCache.Clear ctok - scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.Clear ltok) - cancellable.Return ()) - - member bc.DownsizeCaches(userOpName) = - reactor.EnqueueAndAwaitOpAsync (userOpName, "DownsizeCaches", "", fun ctok -> - parseCacheLock.AcquireLock (fun ltok -> - checkFileInProjectCachePossiblyStale.Resize(ltok, keepStrongly=1) - checkFileInProjectCache.Resize(ltok, keepStrongly=1) - parseFileCache.Resize(ltok, keepStrongly=1)) - incrementalBuildersCache.Resize(ctok, keepStrongly=1, keepMax=1) - frameworkTcImportsCache.Downsize(ctok) - scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.Resize(ltok,keepStrongly=1, keepMax=1)) - cancellable.Return ()) - - member __.FrameworkImportsCache = frameworkTcImportsCache - member __.ImplicitlyStartBackgroundWork with get() = implicitlyStartBackgroundWork and set v = implicitlyStartBackgroundWork <- v - static member GlobalForegroundParseCountStatistic = foregroundParseCount - static member GlobalForegroundTypeCheckCountStatistic = foregroundTypeCheckCount - - -//---------------------------------------------------------------------------- -// FSharpChecker -// - -[] -[] -// There is typically only one instance of this type in a Visual Studio process. -type FSharpChecker(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) = - - let backgroundCompiler = BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) - - static let globalInstance = lazy FSharpChecker.Create() - - - // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.braceMatchCache. Most recently used cache for brace matching. Accessed on the - // background UI thread, not on the compiler thread. - // - // This cache is safe for concurrent access because there is no onDiscard action for the items in the cache. - let braceMatchCache = MruCache(braceMatchCacheSize, areSimilar = AreSimilarForParsing, areSame = AreSameForParsing) - - let mutable maxMemoryReached = false - let mutable maxMB = maxMBDefault - let maxMemEvent = new Event() - - /// Instantiate an interactive checker. - static member Create(?projectCacheSize, ?keepAssemblyContents, ?keepAllBackgroundResolutions, ?legacyReferenceResolver, ?tryGetMetadataSnapshot) = - - let legacyReferenceResolver = - match legacyReferenceResolver with - | None -> SimulatedMSBuildReferenceResolver.GetBestAvailableResolver() - | Some rr -> rr - - let keepAssemblyContents = defaultArg keepAssemblyContents false - let keepAllBackgroundResolutions = defaultArg keepAllBackgroundResolutions true - let projectCacheSizeReal = defaultArg projectCacheSize projectCacheSizeDefault - let tryGetMetadataSnapshot = defaultArg tryGetMetadataSnapshot (fun _ -> None) - new FSharpChecker(legacyReferenceResolver, projectCacheSizeReal,keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) - - member ic.ReferenceResolver = legacyReferenceResolver - - member ic.MatchBraces(filename, source, options: FSharpParsingOptions, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - async { - match braceMatchCache.TryGet(AssumeAnyCallerThreadWithoutEvidence(), (filename, source, options)) with - | Some res -> return res - | None -> - let res = Parser.matchBraces(source, filename, options, userOpName) - braceMatchCache.Set(AssumeAnyCallerThreadWithoutEvidence(), (filename, source, options), res) - return res - } - - member ic.GetParsingOptionsFromProjectOptions(options): FSharpParsingOptions * _ = - let sourceFiles = List.ofArray options.SourceFiles - let argv = List.ofArray options.OtherOptions - ic.GetParsingOptionsFromCommandLineArgs(sourceFiles, argv, options.UseScriptResolutionRules) - - member ic.MatchBraces(filename, source, options: FSharpProjectOptions, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - let parsingOptions, _ = ic.GetParsingOptionsFromProjectOptions(options) - ic.MatchBraces(filename, source, parsingOptions, userOpName) - - member ic.ParseFile(filename, source, options, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - ic.CheckMaxMemoryReached() - backgroundCompiler.ParseFile(filename, source, options, userOpName) - - - member ic.ParseFileInProject(filename, source, options, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - let parsingOptions, _ = ic.GetParsingOptionsFromProjectOptions(options) - ic.ParseFile(filename, source, parsingOptions, userOpName) - - member ic.GetBackgroundParseResultsForFileInProject (filename,options, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.GetBackgroundParseResultsForFileInProject(filename, options, userOpName) - - member ic.GetBackgroundCheckResultsForFileInProject (filename,options, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.GetBackgroundCheckResultsForFileInProject(filename,options, userOpName) - - /// Try to get recent approximate type check results for a file. - member ic.TryGetRecentCheckResultsForFile(filename: string, options:FSharpProjectOptions, ?source, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.TryGetRecentCheckResultsForFile(filename,options,source, userOpName) - - member ic.Compile(argv: string[], ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync (userOpName, "Compile", "", fun ctok -> - cancellable { - return CompileHelpers.compileFromArgs (ctok, argv, legacyReferenceResolver, None, None) - }) - - member ic.Compile (ast:ParsedInput list, assemblyName:string, outFile:string, dependencies:string list, ?pdbFile:string, ?executable:bool, ?noframework:bool, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync (userOpName, "Compile", assemblyName, fun ctok -> - cancellable { - let noframework = defaultArg noframework false - return CompileHelpers.compileFromAsts (ctok, legacyReferenceResolver, ast, assemblyName, outFile, dependencies, noframework, pdbFile, executable, None, None) - } - ) - - member ic.CompileToDynamicAssembly (otherFlags: string[], execute: (TextWriter * TextWriter) option, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync (userOpName, "CompileToDynamicAssembly", "", fun ctok -> - cancellable { - CompileHelpers.setOutputStreams execute - - // References used to capture the results of compilation - let tcImportsRef = ref (None: TcImports option) - let assemblyBuilderRef = ref None - let tcImportsCapture = Some (fun tcImports -> tcImportsRef := Some tcImports) - - // Function to generate and store the results of compilation - let debugInfo = otherFlags |> Array.exists (fun arg -> arg = "-g" || arg = "--debug:+" || arg = "/debug:+") - let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (ctok, debugInfo, tcImportsRef, execute.IsSome, assemblyBuilderRef)) - - // Perform the compilation, given the above capturing function. - let errorsAndWarnings, result = CompileHelpers.compileFromArgs (ctok, otherFlags, legacyReferenceResolver, tcImportsCapture, dynamicAssemblyCreator) - - // Retrieve and return the results - let assemblyOpt = - match assemblyBuilderRef.Value with - | None -> None - | Some a -> Some (a :> System.Reflection.Assembly) - - return errorsAndWarnings, result, assemblyOpt - } - ) - - member ic.CompileToDynamicAssembly (asts:ParsedInput list, assemblyName:string, dependencies:string list, execute: (TextWriter * TextWriter) option, ?debug:bool, ?noframework:bool, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync (userOpName, "CompileToDynamicAssembly", assemblyName, fun ctok -> - cancellable { - CompileHelpers.setOutputStreams execute - - // References used to capture the results of compilation - let tcImportsRef = ref (None: TcImports option) - let assemblyBuilderRef = ref None - let tcImportsCapture = Some (fun tcImports -> tcImportsRef := Some tcImports) - - let debugInfo = defaultArg debug false - let noframework = defaultArg noframework false - let location = Path.Combine(Path.GetTempPath(),"test"+string(hash assemblyName)) - try Directory.CreateDirectory(location) |> ignore with _ -> () - - let outFile = Path.Combine(location, assemblyName + ".dll") - - // Function to generate and store the results of compilation - let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (ctok, debugInfo, tcImportsRef, execute.IsSome, assemblyBuilderRef)) - - // Perform the compilation, given the above capturing function. - let errorsAndWarnings, result = - CompileHelpers.compileFromAsts (ctok, legacyReferenceResolver, asts, assemblyName, outFile, dependencies, noframework, None, Some execute.IsSome, tcImportsCapture, dynamicAssemblyCreator) - - // Retrieve and return the results - let assemblyOpt = - match assemblyBuilderRef.Value with - | None -> None - | Some a -> Some (a :> System.Reflection.Assembly) - - return errorsAndWarnings, result, assemblyOpt - } - ) - - /// This function is called when the entire environment is known to have changed for reasons not encoded in the ProjectOptions of any project/compilation. - /// For example, the type provider approvals file may have changed. - member ic.InvalidateAll() = - ic.ClearCaches() - - member ic.ClearCachesAsync(?userOpName: string) = - let utok = AssumeAnyCallerThreadWithoutEvidence() - let userOpName = defaultArg userOpName "Unknown" - braceMatchCache.Clear(utok) - backgroundCompiler.ClearCachesAsync(userOpName) - - member ic.ClearCaches(?userOpName) = - ic.ClearCachesAsync(?userOpName=userOpName) |> Async.Start // this cache clearance is not synchronous, it will happen when the background op gets run - - member ic.CheckMaxMemoryReached() = - if not maxMemoryReached && System.GC.GetTotalMemory(false) > int64 maxMB * 1024L * 1024L then - Trace.TraceWarning("!!!!!!!! MAX MEMORY REACHED, DOWNSIZING F# COMPILER CACHES !!!!!!!!!!!!!!!") - // If the maxMB limit is reached, drastic action is taken - // - reduce strong cache sizes to a minimum - let userOpName = "MaxMemoryReached" - backgroundCompiler.CompleteAllQueuedOps() - maxMemoryReached <- true - braceMatchCache.Resize(AssumeAnyCallerThreadWithoutEvidence(), keepStrongly=10) - backgroundCompiler.DownsizeCaches(userOpName) |> Async.RunSynchronously - maxMemEvent.Trigger( () ) - - // This is for unit testing only - member ic.ClearLanguageServiceRootCachesAndCollectAndFinalizeAllTransients() = - backgroundCompiler.CompleteAllQueuedOps() // flush AsyncOp - ic.ClearCachesAsync() |> Async.RunSynchronously - System.GC.Collect() - System.GC.WaitForPendingFinalizers() - backgroundCompiler.CompleteAllQueuedOps() // flush AsyncOp - - /// This function is called when the configuration is known to have changed for reasons not encoded in the ProjectOptions. - /// For example, dependent references may have been deleted or created. - member ic.InvalidateConfiguration(options: FSharpProjectOptions, ?startBackgroundCompile, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.InvalidateConfiguration(options, startBackgroundCompile, userOpName) - - /// This function is called when a project has been cleaned, and thus type providers should be refreshed. - member ic.NotifyProjectCleaned(options: FSharpProjectOptions, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.NotifyProjectCleaned (options, userOpName) - - /// Typecheck a source code file, returning a handle to the results of the - /// parse including the reconstructed types in the file. - member ic.CheckFileInProjectAllowingStaleCachedResults(parseResults:FSharpParseFileResults, filename:string, fileVersion:int, source:string, options:FSharpProjectOptions, ?textSnapshotInfo:obj, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.CheckFileInProjectAllowingStaleCachedResults(parseResults,filename,fileVersion,source,options,textSnapshotInfo, userOpName) - - /// Typecheck a source code file, returning a handle to the results of the - /// parse including the reconstructed types in the file. - member ic.CheckFileInProject(parseResults:FSharpParseFileResults, filename:string, fileVersion:int, source:string, options:FSharpProjectOptions, ?textSnapshotInfo:obj, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - ic.CheckMaxMemoryReached() - backgroundCompiler.CheckFileInProject(parseResults,filename,fileVersion,source,options,textSnapshotInfo, userOpName) - - /// Typecheck a source code file, returning a handle to the results of the - /// parse including the reconstructed types in the file. - member ic.ParseAndCheckFileInProject(filename:string, fileVersion:int, source:string, options:FSharpProjectOptions, ?textSnapshotInfo:obj, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - ic.CheckMaxMemoryReached() - backgroundCompiler.ParseAndCheckFileInProject(filename, fileVersion, source, options, textSnapshotInfo, userOpName) - - member ic.ParseAndCheckProject(options, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - ic.CheckMaxMemoryReached() - backgroundCompiler.ParseAndCheckProject(options, userOpName) - - member ic.KeepProjectAlive(options, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.KeepProjectAlive(options, userOpName) - - /// For a given script file, get the ProjectOptions implied by the #load closure - member ic.GetProjectOptionsFromScript(filename, source, ?loadedTimeStamp, ?otherFlags, ?useFsiAuxLib, ?assumeDotNetFramework, ?extraProjectInfo: obj, ?optionsStamp: int64, ?userOpName: string) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.GetProjectOptionsFromScript(filename, source, loadedTimeStamp, otherFlags, useFsiAuxLib, assumeDotNetFramework, extraProjectInfo, optionsStamp, userOpName) - - member ic.GetProjectOptionsFromCommandLineArgs(projectFileName, argv, ?loadedTimeStamp, ?extraProjectInfo: obj) = - let loadedTimeStamp = defaultArg loadedTimeStamp DateTime.MaxValue // Not 'now', we don't want to force reloading - { ProjectFileName = projectFileName - ProjectId = None - SourceFiles = [| |] // the project file names will be inferred from the ProjectOptions - OtherOptions = argv - ReferencedProjects= [| |] - IsIncompleteTypeCheckEnvironment = false - UseScriptResolutionRules = false - LoadTime = loadedTimeStamp - UnresolvedReferences = None - OriginalLoadReferences=[] - ExtraProjectInfo=extraProjectInfo - Stamp = None } - - member ic.GetParsingOptionsFromCommandLineArgs(initialSourceFiles, argv, ?isInteractive) = - let isInteractive = defaultArg isInteractive false - use errorScope = new ErrorScope() - let tcConfigBuilder = TcConfigBuilder.Initial - - // Apply command-line arguments and collect more source files if they are in the arguments - let sourceFilesNew = ApplyCommandLineArgs(tcConfigBuilder, initialSourceFiles, argv) - FSharpParsingOptions.FromTcConfigBuidler(tcConfigBuilder, Array.ofList sourceFilesNew, isInteractive), errorScope.Diagnostics - - member ic.GetParsingOptionsFromCommandLineArgs(argv, ?isInteractive: bool) = - ic.GetParsingOptionsFromCommandLineArgs([], argv, ?isInteractive=isInteractive) - - /// Begin background parsing the given project. - member ic.StartBackgroundCompile(options, ?userOpName) = - let userOpName = defaultArg userOpName "Unknown" - backgroundCompiler.CheckProjectInBackground(options, userOpName) - - /// Begin background parsing the given project. - member ic.CheckProjectInBackground(options, ?userOpName) = - ic.StartBackgroundCompile(options, ?userOpName=userOpName) - - /// Stop the background compile. - member ic.StopBackgroundCompile() = - backgroundCompiler.StopBackgroundCompile() - - /// Block until the background compile finishes. - // - // This is for unit testing only - member ic.WaitForBackgroundCompile() = backgroundCompiler.WaitForBackgroundCompile() - - // Publish the ReactorOps from the background compiler for internal use - member ic.ReactorOps = backgroundCompiler.ReactorOps - member ic.CurrentQueueLength = backgroundCompiler.CurrentQueueLength - - - member ic.BeforeBackgroundFileCheck = backgroundCompiler.BeforeBackgroundFileCheck - member ic.FileParsed = backgroundCompiler.FileParsed - member ic.FileChecked = backgroundCompiler.FileChecked - member ic.ProjectChecked = backgroundCompiler.ProjectChecked - member ic.ImplicitlyStartBackgroundWork with get() = backgroundCompiler.ImplicitlyStartBackgroundWork and set v = backgroundCompiler.ImplicitlyStartBackgroundWork <- v - member ic.PauseBeforeBackgroundWork with get() = Reactor.Singleton.PauseBeforeBackgroundWork and set v = Reactor.Singleton.PauseBeforeBackgroundWork <- v - - static member GlobalForegroundParseCountStatistic = BackgroundCompiler.GlobalForegroundParseCountStatistic - static member GlobalForegroundTypeCheckCountStatistic = BackgroundCompiler.GlobalForegroundTypeCheckCountStatistic - - member ic.MaxMemoryReached = maxMemEvent.Publish - member ic.MaxMemory with get() = maxMB and set v = maxMB <- v - - static member Instance with get() = globalInstance.Force() - member internal __.FrameworkImportsCache = backgroundCompiler.FrameworkImportsCache - - /// Tokenize a single line, returning token information and a tokenization state represented by an integer - member x.TokenizeLine (line: string, state: FSharpTokenizerLexState) = - let tokenizer = FSharpSourceTokenizer([], None) - let lineTokenizer = tokenizer.CreateLineTokenizer line - let mutable state = (None, state) - let tokens = - [| while (state <- lineTokenizer.ScanToken (snd state); (fst state).IsSome) do - yield (fst state).Value |] - tokens, snd state - - /// Tokenize an entire file, line by line - member x.TokenizeFile (source: string) : FSharpTokenInfo[][] = - let lines = source.Split('\n') - let tokens = - [| let mutable state = FSharpTokenizerLexState.Initial - for line in lines do - let tokens, n = x.TokenizeLine(line, state) - state <- n - yield tokens |] - tokens - - -type FsiInteractiveChecker(legacyReferenceResolver, reactorOps: IReactorOperations, tcConfig: TcConfig, tcGlobals, tcImports, tcState) = - let keepAssemblyContents = false - - member __.ParseAndCheckInteraction (ctok, source, ?userOpName: string) = - async { - let userOpName = defaultArg userOpName "Unknown" - let filename = Path.Combine(tcConfig.implicitIncludeDir, "stdin.fsx") - // Note: projectSourceFiles is only used to compute isLastCompiland, and is ignored if Build.IsScript(mainInputFileName) is true (which it is in this case). - let parsingOptions = FSharpParsingOptions.FromTcConfig(tcConfig, [| filename |], true) - let parseErrors, parseTreeOpt, anyErrors = Parser.parseFile (source, filename, parsingOptions, userOpName) - let dependencyFiles = [| |] // interactions have no dependencies - let parseResults = FSharpParseFileResults(parseErrors, parseTreeOpt, parseHadErrors = anyErrors, dependencyFiles = dependencyFiles) - - let backgroundDiagnostics = [| |] - let reduceMemoryUsage = ReduceMemoryFlag.Yes - let assumeDotNetFramework = true - - let applyCompilerOptions tcConfigB = - let fsiCompilerOptions = CompileOptions.GetCoreFsiCompilerOptions tcConfigB - CompileOptions.ParseCompilerOptions (ignore, fsiCompilerOptions, [ ]) - - let loadClosure = LoadClosure.ComputeClosureOfScriptText(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename, source, CodeContext.Editing, tcConfig.useSimpleResolution, tcConfig.useFsiAuxLib, new Lexhelp.LexResourceManager(), applyCompilerOptions, assumeDotNetFramework, tryGetMetadataSnapshot=(fun _ -> None), reduceMemoryUsage=reduceMemoryUsage) - let! tcErrors, tcFileResult = Parser.CheckOneFile(parseResults, source, filename, "project", tcConfig, tcGlobals, tcImports, tcState, Map.empty, Some loadClosure, backgroundDiagnostics, reactorOps, (fun () -> true), None, userOpName) - - return - match tcFileResult with - | Parser.TypeCheckAborted.No tcFileInfo -> - let errors = [| yield! parseErrors; yield! tcErrors |] - let typeCheckResults = FSharpCheckFileResults (filename, errors, Some tcFileInfo, dependencyFiles, None, reactorOps, false) - let projectResults = - FSharpCheckProjectResults (filename, Some tcConfig, keepAssemblyContents, errors, - Some(tcGlobals, tcImports, tcFileInfo.ThisCcu, tcFileInfo.CcuSigForFile, - [tcFileInfo.ScopeSymbolUses], None, None, mkSimpleAssemblyRef "stdin", - tcState.TcEnvFromImpls.AccessRights, None, dependencyFiles)) - parseResults, typeCheckResults, projectResults - | _ -> - failwith "unexpected aborted" - } - -//---------------------------------------------------------------------------- -// CompilerEnvironment, DebuggerEnvironment -// - -type CompilerEnvironment = - static member BinFolderOfDefaultFSharpCompiler(?probePoint) = - FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(probePoint) - -/// Information about the compilation environment -[] -module CompilerEnvironment = - /// These are the names of assemblies that should be referenced for .fs, .ml, .fsi, .mli files that - /// are not associated with a project - let DefaultReferencesForOrphanSources(assumeDotNetFramework) = DefaultReferencesForScriptsAndOutOfProjectSources(assumeDotNetFramework) - - /// Publish compiler-flags parsing logic. Must be fast because its used by the colorizer. - let GetCompilationDefinesForEditing (parsingOptions: FSharpParsingOptions) = - SourceFileImpl.AdditionalDefinesForUseInEditor(parsingOptions.IsInteractive) @ - parsingOptions.ConditionalCompilationDefines - - /// Return true if this is a subcategory of error or warning message that the language service can emit - let IsCheckerSupportedSubcategory(subcategory:string) = - // Beware: This code logic is duplicated in DocumentTask.cs in the language service - PhasedDiagnostic.IsSubcategoryOfCompile(subcategory) - -/// Information about the debugging environment -module DebuggerEnvironment = - /// Return the language ID, which is the expression evaluator id that the - /// debugger will use. - let GetLanguageID() = - System.Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy) - -module PrettyNaming = - let IsIdentifierPartCharacter x = Microsoft.FSharp.Compiler.PrettyNaming.IsIdentifierPartCharacter x - let IsLongIdentifierPartCharacter x = Microsoft.FSharp.Compiler.PrettyNaming.IsLongIdentifierPartCharacter x - let IsOperatorName x = Microsoft.FSharp.Compiler.PrettyNaming.IsOperatorName x - let GetLongNameFromString x = Microsoft.FSharp.Compiler.PrettyNaming.SplitNamesForILPath x - let FormatAndOtherOverloadsString remainingOverloads = FSComp.SR.typeInfoOtherOverloads(remainingOverloads) - let QuoteIdentifierIfNeeded id = Lexhelp.Keywords.QuoteIdentifierIfNeeded id - let KeywordNames = Lexhelp.Keywords.keywordNames - + if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then + let symbol = FSharpSymbol.Create(cenv, symbolUse.Item) + yield FSharpSymbolUse(scope.TcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range) |]) + |> async.Return + + member info.GetUsesOfSymbolInFile(symbol:FSharpSymbol) = + threadSafeOp + (fun () -> [| |]) + (fun scope -> + [| for symbolUse in scope.ScopeSymbolUses.GetUsesOfSymbol(symbol.Item) |> Seq.distinctBy (fun symbolUse -> symbolUse.ItemOccurence, symbolUse.Range) do + if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then + yield FSharpSymbolUse(scope.TcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range) |]) + |> async.Return + + member info.GetVisibleNamespacesAndModulesAtPoint(pos: pos) = + threadSafeOp + (fun () -> [| |]) + (fun scope -> scope.GetVisibleNamespacesAndModulesAtPosition(pos) |> List.toArray) + |> async.Return + + member info.IsRelativeNameResolvable(pos: pos, plid: string list, item: Item, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + reactorOp userOpName "IsRelativeNameResolvable" true (fun ctok scope -> + RequireCompilationThread ctok + scope.IsRelativeNameResolvable(pos, plid, item)) + + member info.IsRelativeNameResolvableFromSymbol(pos: pos, plid: string list, symbol: FSharpSymbol, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + reactorOp userOpName "IsRelativeNameResolvableFromSymbol" true (fun ctok scope -> + RequireCompilationThread ctok + scope.IsRelativeNameResolvableFromSymbol(pos, plid, symbol)) + + member info.GetDisplayEnvForPos(pos: pos) : Async = + let userOpName = "CodeLens" + reactorOp userOpName "GetDisplayContextAtPos" None (fun ctok scope -> + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + let (nenv, _), _ = scope.GetBestDisplayEnvForPos pos + Some nenv.DisplayEnv) + + member info.ImplementationFile = + if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to true on the FSharpChecker in order to access the checked contents of assemblies" + scopeOptX + |> Option.map (fun scope -> + let cenv = SymbolEnv(scope.TcGlobals, scope.ThisCcu, Some scope.CcuSigForFile, scope.TcImports) + scope.ImplementationFile |> Option.map (fun implFile -> FSharpImplementationFileContents(cenv, implFile))) + |> Option.defaultValue None + + member info.OpenDeclarations = + scopeOptX + |> Option.map (fun scope -> + let cenv = scope.SymbolEnv + scope.OpenDeclarations |> Array.map (fun x -> FSharpOpenDeclaration(x.LongId, x.Range, (x.Modules |> List.map (fun x -> FSharpEntity(cenv, x))), x.AppliedScope, x.IsOwnNamespace))) + |> Option.defaultValue [| |] + + override info.ToString() = "FSharpCheckFileResults(" + filename + ")" + +#if !FABLE_COMPILER + +//---------------------------------------------------------------------------- +// BackgroundCompiler +// + +[] +type FSharpCheckFileAnswer = + | Aborted + | Succeeded of FSharpCheckFileResults + + +/// Callback that indicates whether a requested result has become obsolete. +[] +type IsResultObsolete = + | IsResultObsolete of (unit->bool) + + +[] +module Helpers = + + // Look for DLLs in the location of the service DLL first. + let defaultFSharpBinariesDir = FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(Some(typeof.Assembly.Location)).Value + + /// Determine whether two (fileName,options) keys are identical w.r.t. affect on checking + let AreSameForChecking2((fileName1: string, options1: FSharpProjectOptions), (fileName2, options2)) = + (fileName1 = fileName2) + && FSharpProjectOptions.AreSameForChecking(options1,options2) + + /// Determine whether two (fileName,options) keys should be identical w.r.t. resource usage + let AreSubsumable2((fileName1:string,o1:FSharpProjectOptions),(fileName2:string,o2:FSharpProjectOptions)) = + (fileName1 = fileName2) + && FSharpProjectOptions.UseSameProject(o1,o2) + + /// Determine whether two (fileName,sourceText,options) keys should be identical w.r.t. parsing + let AreSameForParsing((fileName1: string, source1: string, options1), (fileName2, source2, options2)) = + fileName1 = fileName2 && options1 = options2 && source1 = source2 + + let AreSimilarForParsing((fileName1, _, _), (fileName2, _, _)) = + fileName1 = fileName2 + + /// Determine whether two (fileName,sourceText,options) keys should be identical w.r.t. checking + let AreSameForChecking3((fileName1: string, source1: string, options1: FSharpProjectOptions), (fileName2, source2, options2)) = + (fileName1 = fileName2) + && FSharpProjectOptions.AreSameForChecking(options1,options2) + && (source1 = source2) + + /// Determine whether two (fileName,sourceText,options) keys should be identical w.r.t. resource usage + let AreSubsumable3((fileName1:string,_,o1:FSharpProjectOptions),(fileName2:string,_,o2:FSharpProjectOptions)) = + (fileName1 = fileName2) + && FSharpProjectOptions.UseSameProject(o1,o2) + +module CompileHelpers = + let mkCompilationErorHandlers() = + let errors = ResizeArray<_>() + + let errorSink isError exn = + let mainError, relatedErrors = SplitRelatedDiagnostics exn + let oneError e = errors.Add(FSharpErrorInfo.CreateFromException (e, isError, Range.range0)) + oneError mainError + List.iter oneError relatedErrors + + let errorLogger = + { new ErrorLogger("CompileAPI") with + member x.DiagnosticSink(exn, isError) = errorSink isError exn + member x.ErrorCount = errors |> Seq.filter (fun e -> e.Severity = FSharpErrorSeverity.Error) |> Seq.length } + + let loggerProvider = + { new ErrorLoggerProvider() with + member x.CreateErrorLoggerUpToMaxErrors(_tcConfigBuilder, _exiter) = errorLogger } + errors, errorLogger, loggerProvider + + let tryCompile errorLogger f = + use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + use unwindEL_2 = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger) + let exiter = { new Exiter with member x.Exit n = raise StopProcessing } + try + f exiter + 0 + with e -> + stopProcessingRecovery e Range.range0 + 1 + + /// Compile using the given flags. Source files names are resolved via the FileSystem API. The output file must be given by a -o flag. + let compileFromArgs (ctok, argv: string[], legacyReferenceResolver, tcImportsCapture, dynamicAssemblyCreator) = + + let errors, errorLogger, loggerProvider = mkCompilationErorHandlers() + let result = + tryCompile errorLogger (fun exiter -> + mainCompile (ctok, argv, legacyReferenceResolver, (*bannerAlreadyPrinted*)true, ReduceMemoryFlag.Yes, CopyFSharpCoreFlag.No, exiter, loggerProvider, tcImportsCapture, dynamicAssemblyCreator) ) + + errors.ToArray(), result + + let compileFromAsts (ctok, legacyReferenceResolver, asts, assemblyName, outFile, dependencies, noframework, pdbFile, executable, tcImportsCapture, dynamicAssemblyCreator) = + + let errors, errorLogger, loggerProvider = mkCompilationErorHandlers() + + let executable = defaultArg executable true + let target = if executable then CompilerTarget.ConsoleExe else CompilerTarget.Dll + + let result = + tryCompile errorLogger (fun exiter -> + compileOfAst (ctok, legacyReferenceResolver, ReduceMemoryFlag.Yes, assemblyName, target, outFile, pdbFile, dependencies, noframework, exiter, loggerProvider, asts, tcImportsCapture, dynamicAssemblyCreator)) + + errors.ToArray(), result + + let createDynamicAssembly (ctok, debugInfo: bool, tcImportsRef: TcImports option ref, execute: bool, assemblyBuilderRef: _ option ref) (tcGlobals:TcGlobals, outfile, ilxMainModule) = + + // Create an assembly builder + let assemblyName = System.Reflection.AssemblyName(System.IO.Path.GetFileNameWithoutExtension outfile) + let flags = System.Reflection.Emit.AssemblyBuilderAccess.Run +#if FX_NO_APP_DOMAINS + let assemblyBuilder = System.Reflection.Emit.AssemblyBuilder.DefineDynamicAssembly(assemblyName, flags) + let moduleBuilder = assemblyBuilder.DefineDynamicModule("IncrementalModule") +#else + let assemblyBuilder = AppDomain.CurrentDomain.DefineDynamicAssembly(assemblyName, flags) + let moduleBuilder = assemblyBuilder.DefineDynamicModule("IncrementalModule", debugInfo) +#endif + // Omit resources in dynamic assemblies, because the module builder is constructed without a filename the module + // is tagged as transient and as such DefineManifestResource will throw an invalid operation if resources are present. + // + // Also, the dynamic assembly creator can't currently handle types called "" from statically linked assemblies. + let ilxMainModule = + { ilxMainModule with + TypeDefs = ilxMainModule.TypeDefs.AsList |> List.filter (fun td -> not (isTypeNameForGlobalFunctions td.Name)) |> mkILTypeDefs + Resources=mkILResources [] } + + // The function used to resolve typees while emitting the code + let assemblyResolver s = + match tcImportsRef.Value.Value.TryFindExistingFullyQualifiedPathByExactAssemblyRef (ctok, s) with + | Some res -> Some (Choice1Of2 res) + | None -> None + + // Emit the code + let _emEnv,execs = ILRuntimeWriter.emitModuleFragment(tcGlobals.ilg, ILRuntimeWriter.emEnv0, assemblyBuilder, moduleBuilder, ilxMainModule, debugInfo, assemblyResolver, tcGlobals.TryFindSysILTypeRef) + + // Execute the top-level initialization, if requested + if execute then + for exec in execs do + match exec() with + | None -> () + | Some exn -> + PreserveStackTrace(exn) + raise exn + + // Register the reflected definitions for the dynamically generated assembly + for resource in ilxMainModule.Resources.AsList do + if IsReflectedDefinitionsResource resource then + Quotations.Expr.RegisterReflectedDefinitions(assemblyBuilder, moduleBuilder.Name, resource.GetBytes()) + + // Save the result + assemblyBuilderRef := Some assemblyBuilder + + let setOutputStreams execute = + // Set the output streams, if requested + match execute with + | Some (writer,error) -> + System.Console.SetOut writer + System.Console.SetError error + | None -> () + + +type FileName = string +type Source = string +type FilePath = string +type ProjectPath = string +type FileVersion = int + +type ParseCacheLockToken() = interface LockToken +type ScriptClosureCacheToken() = interface LockToken + + +// There is only one instance of this type, held in FSharpChecker +type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) as self = + // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.reactor: The one and only Reactor + let reactor = Reactor.Singleton + let beforeFileChecked = Event() + let fileParsed = Event() + let fileChecked = Event() + let projectChecked = Event() + + + let mutable implicitlyStartBackgroundWork = true + let reactorOps = + { new IReactorOperations with + member __.EnqueueAndAwaitOpAsync (userOpName, opName, opArg, op) = reactor.EnqueueAndAwaitOpAsync (userOpName, opName, opArg, op) + member __.EnqueueOp (userOpName, opName, opArg, op) = reactor.EnqueueOp (userOpName, opName, opArg, op) } + + // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.scriptClosureCache + /// Information about the derived script closure. + let scriptClosureCache = + MruCache(projectCacheSize, + areSame=FSharpProjectOptions.AreSameForChecking, + areSimilar=FSharpProjectOptions.UseSameProject) + + let scriptClosureCacheLock = Lock() + let frameworkTcImportsCache = FrameworkImportsCache(frameworkTcImportsCacheStrongSize) + + /// CreateOneIncrementalBuilder (for background type checking). Note that fsc.fs also + /// creates an incremental builder used by the command line compiler. + let CreateOneIncrementalBuilder (ctok, options:FSharpProjectOptions, userOpName) = + cancellable { + Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "CreateOneIncrementalBuilder", options.ProjectFileName) + let projectReferences = + [ for (nm,opts) in options.ReferencedProjects do + + // Don't use cross-project references for FSharp.Core, since various bits of code require a concrete FSharp.Core to exist on-disk. + // The only solutions that have these cross-project references to FSharp.Core are VisualFSharp.sln and FSharp.sln. The only ramification + // of this is that you need to build FSharp.Core to get intellisense in those projects. + + if (try Path.GetFileNameWithoutExtension(nm) with _ -> "") <> GetFSharpCoreLibraryName() then + + yield + { new IProjectReference with + member x.EvaluateRawContents(ctok) = + cancellable { + Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "ParseAndCheckProjectImpl", nm) + let! r = self.ParseAndCheckProjectImpl(opts, ctok, userOpName + ".CheckReferencedProject("+nm+")") + return r.RawFSharpAssemblyData + } + member x.TryGetLogicalTimeStamp(cache, ctok) = + self.TryGetLogicalTimeStampForProject(cache, ctok, opts, userOpName + ".TimeStampReferencedProject("+nm+")") + member x.FileName = nm } ] + + let loadClosure = scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.TryGet (ltok, options)) + let! builderOpt, diagnostics = + IncrementalBuilder.TryCreateBackgroundBuilderForProjectOptions + (ctok, legacyReferenceResolver, defaultFSharpBinariesDir, frameworkTcImportsCache, loadClosure, Array.toList options.SourceFiles, + Array.toList options.OtherOptions, projectReferences, options.ProjectDirectory, + options.UseScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds, + tryGetMetadataSnapshot) + + // We're putting the builder in the cache, so increment its count. + let decrement = IncrementalBuilder.KeepBuilderAlive builderOpt + + match builderOpt with + | None -> () + | Some builder -> + + // Register the behaviour that responds to CCUs being invalidated because of type + // provider Invalidate events. This invalidates the configuration in the build. + builder.ImportedCcusInvalidated.Add (fun _ -> + self.InvalidateConfiguration(options, None, userOpName)) + + // Register the callback called just before a file is typechecked by the background builder (without recording + // errors or intellisense information). + // + // This indicates to the UI that the file type check state is dirty. If the file is open and visible then + // the UI will sooner or later request a typecheck of the file, recording errors and intellisense information. + builder.BeforeFileChecked.Add (fun file -> beforeFileChecked.Trigger(file, options.ExtraProjectInfo)) + builder.FileParsed.Add (fun file -> fileParsed.Trigger(file, options.ExtraProjectInfo)) + builder.FileChecked.Add (fun file -> fileChecked.Trigger(file, options.ExtraProjectInfo)) + builder.ProjectChecked.Add (fun () -> projectChecked.Trigger (options.ProjectFileName, options.ExtraProjectInfo)) + + return (builderOpt, diagnostics, decrement) + } + + // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.incrementalBuildersCache. This root typically holds more + // live information than anything else in the F# Language Service, since it holds up to 3 (projectCacheStrongSize) background project builds + // strongly. + // + /// Cache of builds keyed by options. + let incrementalBuildersCache = + MruCache + (keepStrongly=projectCacheSize, keepMax=projectCacheSize, + areSame = FSharpProjectOptions.AreSameForChecking, + areSimilar = FSharpProjectOptions.UseSameProject, + requiredToKeep=(fun (builderOpt,_,_) -> match builderOpt with None -> false | Some (b:IncrementalBuilder) -> b.IsBeingKeptAliveApartFromCacheEntry), + onDiscard = (fun (_, _, decrement:IDisposable) -> decrement.Dispose())) + + let getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) = + cancellable { + RequireCompilationThread ctok + match incrementalBuildersCache.TryGet (ctok, options) with + | Some (builderOpt,creationErrors,_) -> + Logger.Log LogCompilerFunctionId.Service_IncrementalBuildersCache_BuildingNewCache + let decrement = IncrementalBuilder.KeepBuilderAlive builderOpt + return builderOpt,creationErrors, decrement + | None -> + Logger.Log LogCompilerFunctionId.Service_IncrementalBuildersCache_GettingCache + let! (builderOpt,creationErrors,_) as info = CreateOneIncrementalBuilder (ctok, options, userOpName) + incrementalBuildersCache.Set (ctok, options, info) + let decrement = IncrementalBuilder.KeepBuilderAlive builderOpt + return builderOpt, creationErrors, decrement + } + + let parseCacheLock = Lock() + + + // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.parseFileInProjectCache. Most recently used cache for parsing files. + let parseFileCache = MruCache(parseFileCacheSize, areSimilar = AreSimilarForParsing, areSame = AreSameForParsing) + + // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.checkFileInProjectCachePossiblyStale + // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.checkFileInProjectCache + // + /// Cache which holds recently seen type-checks. + /// This cache may hold out-of-date entries, in two senses + /// - there may be a more recent antecedent state available because the background build has made it available + /// - the source for the file may have changed + + let checkFileInProjectCachePossiblyStale = + MruCache + (keepStrongly=checkFileInProjectCacheSize, + areSame=AreSameForChecking2, + areSimilar=AreSubsumable2) + + // Also keyed on source. This can only be out of date if the antecedent is out of date + let checkFileInProjectCache = + MruCache + (keepStrongly=checkFileInProjectCacheSize, + areSame=AreSameForChecking3, + areSimilar=AreSubsumable3) + + /// Holds keys for files being currently checked. It's used to prevent checking same file in parallel (interleaving chunck queued to Reactor). + let beingCheckedFileTable = + ConcurrentDictionary + (HashIdentity.FromFunctions + hash + (fun (f1, o1, v1) (f2, o2, v2) -> f1 = f2 && v1 = v2 && FSharpProjectOptions.AreSameForChecking(o1, o2))) + + static let mutable foregroundParseCount = 0 + static let mutable foregroundTypeCheckCount = 0 + + let MakeCheckFileResultsEmpty(filename, creationErrors) = + FSharpCheckFileResults (filename, creationErrors, None, [| |], None, reactorOps, keepAssemblyContents) + + let MakeCheckFileResults(filename, options:FSharpProjectOptions, builder, scope, dependencyFiles, creationErrors, parseErrors, tcErrors) = + let errors = + [| yield! creationErrors + yield! parseErrors + if options.IsIncompleteTypeCheckEnvironment then + yield! Seq.truncate maxTypeCheckErrorsOutOfProjectContext tcErrors + else + yield! tcErrors |] + + FSharpCheckFileResults (filename, errors, Some scope, dependencyFiles, Some builder, reactorOps, keepAssemblyContents) + + let MakeCheckFileAnswer(filename, tcFileResult, options:FSharpProjectOptions, builder, dependencyFiles, creationErrors, parseErrors, tcErrors) = + match tcFileResult with + | Parser.TypeCheckAborted.Yes -> FSharpCheckFileAnswer.Aborted + | Parser.TypeCheckAborted.No scope -> FSharpCheckFileAnswer.Succeeded(MakeCheckFileResults(filename, options, builder, scope, dependencyFiles, creationErrors, parseErrors, tcErrors)) + + member bc.RecordTypeCheckFileInProjectResults(filename,options,parsingOptions,parseResults,fileVersion,priorTimeStamp,checkAnswer,source) = + match checkAnswer with + | None + | Some FSharpCheckFileAnswer.Aborted -> () + | Some (FSharpCheckFileAnswer.Succeeded typedResults) -> + foregroundTypeCheckCount <- foregroundTypeCheckCount + 1 + parseCacheLock.AcquireLock (fun ltok -> + checkFileInProjectCachePossiblyStale.Set(ltok, (filename,options),(parseResults,typedResults,fileVersion)) + checkFileInProjectCache.Set(ltok, (filename,source,options),(parseResults,typedResults,fileVersion,priorTimeStamp)) + parseFileCache.Set(ltok, (filename, source, parsingOptions), parseResults)) + + member bc.ImplicitlyStartCheckProjectInBackground(options, userOpName) = + if implicitlyStartBackgroundWork then + bc.CheckProjectInBackground(options, userOpName + ".ImplicitlyStartCheckProjectInBackground") + + member bc.ParseFile(filename: string, source: string, options: FSharpParsingOptions, userOpName: string) = + async { + match parseCacheLock.AcquireLock(fun ltok -> parseFileCache.TryGet(ltok, (filename, source, options))) with + | Some res -> return res + | None -> + foregroundParseCount <- foregroundParseCount + 1 + let parseErrors, parseTreeOpt, anyErrors = Parser.parseFile(source, filename, options, userOpName) + let res = FSharpParseFileResults(parseErrors, parseTreeOpt, anyErrors, options.SourceFiles) + parseCacheLock.AcquireLock(fun ltok -> parseFileCache.Set(ltok, (filename, source, options), res)) + return res + } + + /// Fetch the parse information from the background compiler (which checks w.r.t. the FileSystem API) + member bc.GetBackgroundParseResultsForFileInProject(filename, options, userOpName) = + reactor.EnqueueAndAwaitOpAsync(userOpName, "GetBackgroundParseResultsForFileInProject ", filename, fun ctok -> + cancellable { + let! builderOpt, creationErrors, decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) + use _unwind = decrement + match builderOpt with + | None -> return FSharpParseFileResults(creationErrors, None, true, [| |]) + | Some builder -> + let! parseTreeOpt,_,_,parseErrors = builder.GetParseResultsForFile (ctok, filename) + let errors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (builder.TcConfig.errorSeverityOptions, false, filename, parseErrors) |] + return FSharpParseFileResults(errors = errors, input = parseTreeOpt, parseHadErrors = false, dependencyFiles = builder.AllDependenciesDeprecated) + } + ) + + member bc.GetCachedCheckFileResult(builder: IncrementalBuilder,filename,source,options) = + // Check the cache. We can only use cached results when there is no work to do to bring the background builder up-to-date + let cachedResults = parseCacheLock.AcquireLock (fun ltok -> checkFileInProjectCache.TryGet(ltok, (filename,source,options))) + + match cachedResults with +// | Some (parseResults, checkResults, _, _) when builder.AreCheckResultsBeforeFileInProjectReady(filename) -> + | Some (parseResults, checkResults,_,priorTimeStamp) + when + (match builder.GetCheckResultsBeforeFileInProjectEvenIfStale filename with + | None -> false + | Some(tcPrior) -> + tcPrior.TimeStamp = priorTimeStamp && + builder.AreCheckResultsBeforeFileInProjectReady(filename)) -> + Some (parseResults,checkResults) + | _ -> None + + /// 1. Repeatedly try to get cached file check results or get file "lock". + /// + /// 2. If it've got cached results, returns them. + /// + /// 3. If it've not got the lock for 1 minute, returns `FSharpCheckFileAnswer.Aborted`. + /// + /// 4. Type checks the file. + /// + /// 5. Records results in `BackgroundCompiler` caches. + /// + /// 6. Starts whole project background compilation. + /// + /// 7. Releases the file "lock". + member private bc.CheckOneFileImpl + (parseResults: FSharpParseFileResults, + source: string, + fileName: string, + options: FSharpProjectOptions, + textSnapshotInfo: obj option, + fileVersion: int, + builder: IncrementalBuilder, + tcPrior: PartialCheckResults, + creationErrors: FSharpErrorInfo[], + userOpName: string) = + + async { + let beingCheckedFileKey = fileName, options, fileVersion + let stopwatch = Stopwatch.StartNew() + let rec loop() = + async { + // results may appear while we were waiting for the lock, let's recheck if it's the case + let cachedResults = bc.GetCachedCheckFileResult(builder, fileName, source, options) + + match cachedResults with + | Some (_, checkResults) -> return FSharpCheckFileAnswer.Succeeded checkResults + | None -> + if beingCheckedFileTable.TryAdd(beingCheckedFileKey, ()) then + try + // Get additional script #load closure information if applicable. + // For scripts, this will have been recorded by GetProjectOptionsFromScript. + let loadClosure = scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.TryGet (ltok, options)) + let! tcErrors, tcFileResult = + Parser.CheckOneFile(parseResults, source, fileName, options.ProjectFileName, tcPrior.TcConfig, tcPrior.TcGlobals, tcPrior.TcImports, + tcPrior.TcState, tcPrior.ModuleNamesDict, loadClosure, tcPrior.TcErrors, reactorOps, (fun () -> builder.IsAlive), textSnapshotInfo, userOpName) + let parsingOptions = FSharpParsingOptions.FromTcConfig(tcPrior.TcConfig, Array.ofList builder.SourceFiles, options.UseScriptResolutionRules) + let checkAnswer = MakeCheckFileAnswer(fileName, tcFileResult, options, builder, Array.ofList tcPrior.TcDependencyFiles, creationErrors, parseResults.Errors, tcErrors) + bc.RecordTypeCheckFileInProjectResults(fileName, options, parsingOptions, parseResults, fileVersion, tcPrior.TimeStamp, Some checkAnswer, source) + return checkAnswer + finally + let dummy = ref () + beingCheckedFileTable.TryRemove(beingCheckedFileKey, dummy) |> ignore + else + do! Async.Sleep 100 + if stopwatch.Elapsed > TimeSpan.FromMinutes 1. then + return FSharpCheckFileAnswer.Aborted + else + return! loop() + } + return! loop() + } + + /// Type-check the result obtained by parsing, but only if the antecedent type checking context is available. + member bc.CheckFileInProjectAllowingStaleCachedResults(parseResults: FSharpParseFileResults, filename, fileVersion, source, options, textSnapshotInfo: obj option, userOpName) = + let execWithReactorAsync action = reactor.EnqueueAndAwaitOpAsync(userOpName, "CheckFileInProjectAllowingStaleCachedResults ", filename, action) + async { + try + if implicitlyStartBackgroundWork then + reactor.CancelBackgroundOp() // cancel the background work, since we will start new work after we're done + + let! cachedResults = + execWithReactorAsync <| fun ctok -> + cancellable { + let! _builderOpt,_creationErrors,decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) + use _unwind = decrement + + match incrementalBuildersCache.TryGetAny (ctok, options) with + | Some (Some builder, creationErrors, _) -> + match bc.GetCachedCheckFileResult(builder, filename, source, options) with + | Some (_, checkResults) -> return Some (builder, creationErrors, Some (FSharpCheckFileAnswer.Succeeded checkResults)) + | _ -> return Some (builder, creationErrors, None) + | _ -> return None // the builder wasn't ready + } + + match cachedResults with + | None -> return None + | Some (_, _, Some x) -> return Some x + | Some (builder, creationErrors, None) -> + Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "CheckFileInProjectAllowingStaleCachedResults.CacheMiss", filename) + let! tcPrior = + execWithReactorAsync <| fun ctok -> + cancellable { + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + return builder.GetCheckResultsBeforeFileInProjectEvenIfStale filename + } + + match tcPrior with + | Some tcPrior -> + let! checkResults = bc.CheckOneFileImpl(parseResults, source, filename, options, textSnapshotInfo, fileVersion, builder, tcPrior, creationErrors, userOpName) + return Some checkResults + | None -> return None // the incremental builder was not up to date + finally + bc.ImplicitlyStartCheckProjectInBackground(options, userOpName) + } + + /// Type-check the result obtained by parsing. Force the evaluation of the antecedent type checking context if needed. + member bc.CheckFileInProject(parseResults: FSharpParseFileResults, filename, fileVersion, source, options, textSnapshotInfo, userOpName) = + let execWithReactorAsync action = reactor.EnqueueAndAwaitOpAsync(userOpName, "CheckFileInProject", filename, action) + async { + try + if implicitlyStartBackgroundWork then + reactor.CancelBackgroundOp() // cancel the background work, since we will start new work after we're done + let! builderOpt,creationErrors, decrement = execWithReactorAsync (fun ctok -> getOrCreateBuilderAndKeepAlive (ctok, options, userOpName)) + use _unwind = decrement + match builderOpt with + | None -> return FSharpCheckFileAnswer.Succeeded (MakeCheckFileResultsEmpty(filename, creationErrors)) + | Some builder -> + // Check the cache. We can only use cached results when there is no work to do to bring the background builder up-to-date + let cachedResults = bc.GetCachedCheckFileResult(builder, filename, source, options) + + match cachedResults with + | Some (_, checkResults) -> return FSharpCheckFileAnswer.Succeeded checkResults + | _ -> + Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "CheckFileInProject.CacheMiss", filename) + let! tcPrior = execWithReactorAsync <| fun ctok -> builder.GetCheckResultsBeforeFileInProject (ctok, filename) + let! checkAnswer = bc.CheckOneFileImpl(parseResults, source, filename, options, textSnapshotInfo, fileVersion, builder, tcPrior, creationErrors, userOpName) + return checkAnswer + finally + bc.ImplicitlyStartCheckProjectInBackground(options, userOpName) + } + + /// Parses and checks the source file and returns untyped AST and check results. + member bc.ParseAndCheckFileInProject (filename:string, fileVersion, source, options:FSharpProjectOptions, textSnapshotInfo, userOpName) = + let execWithReactorAsync action = reactor.EnqueueAndAwaitOpAsync(userOpName, "ParseAndCheckFileInProject", filename, action) + async { + try + let strGuid = "_ProjectId=" + (options.ProjectId |> Option.defaultValue "null") + Logger.LogBlockMessageStart (filename + strGuid) LogCompilerFunctionId.Service_ParseAndCheckFileInProject + + if implicitlyStartBackgroundWork then + Logger.LogMessage (filename + strGuid + "-Cancelling background work") LogCompilerFunctionId.Service_ParseAndCheckFileInProject + reactor.CancelBackgroundOp() // cancel the background work, since we will start new work after we're done + + let! builderOpt,creationErrors,decrement = execWithReactorAsync (fun ctok -> getOrCreateBuilderAndKeepAlive (ctok, options, userOpName)) + use _unwind = decrement + match builderOpt with + | None -> + Logger.LogBlockMessageStop (filename + strGuid + "-Failed_Aborted") LogCompilerFunctionId.Service_ParseAndCheckFileInProject + + let parseResults = FSharpParseFileResults(creationErrors, None, true, [| |]) + return (parseResults, FSharpCheckFileAnswer.Aborted) + + | Some builder -> + let cachedResults = bc.GetCachedCheckFileResult(builder, filename, source, options) + + match cachedResults with + | Some (parseResults, checkResults) -> + Logger.LogBlockMessageStop (filename + strGuid + "-Successful_Cached") LogCompilerFunctionId.Service_ParseAndCheckFileInProject + + return parseResults, FSharpCheckFileAnswer.Succeeded checkResults + | _ -> + // todo this blocks the Reactor queue until all files up to the current are type checked. It's OK while editing the file, + // but results with non cooperative blocking when a firts file from a project opened. + let! tcPrior = execWithReactorAsync <| fun ctok -> builder.GetCheckResultsBeforeFileInProject (ctok, filename) + + // Do the parsing. + let parsingOptions = FSharpParsingOptions.FromTcConfig(builder.TcConfig, Array.ofList (builder.SourceFiles), options.UseScriptResolutionRules) + let parseErrors, parseTreeOpt, anyErrors = Parser.parseFile (source, filename, parsingOptions, userOpName) + let parseResults = FSharpParseFileResults(parseErrors, parseTreeOpt, anyErrors, builder.AllDependenciesDeprecated) + let! checkResults = bc.CheckOneFileImpl(parseResults, source, filename, options, textSnapshotInfo, fileVersion, builder, tcPrior, creationErrors, userOpName) + + Logger.LogBlockMessageStop (filename + strGuid + "-Successful") LogCompilerFunctionId.Service_ParseAndCheckFileInProject + + return parseResults, checkResults + finally + bc.ImplicitlyStartCheckProjectInBackground(options, userOpName) + } + + /// Fetch the check information from the background compiler (which checks w.r.t. the FileSystem API) + member bc.GetBackgroundCheckResultsForFileInProject(filename, options, userOpName) = + reactor.EnqueueAndAwaitOpAsync(userOpName, "GetBackgroundCheckResultsForFileInProject", filename, fun ctok -> + cancellable { + let! builderOpt, creationErrors, decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) + use _unwind = decrement + match builderOpt with + | None -> + let parseResults = FSharpParseFileResults(creationErrors, None, true, [| |]) + let typedResults = MakeCheckFileResultsEmpty(filename, creationErrors) + return (parseResults, typedResults) + | Some builder -> + let! (parseTreeOpt, _, _, untypedErrors) = builder.GetParseResultsForFile (ctok, filename) + let! tcProj = builder.GetCheckResultsAfterFileInProject (ctok, filename) + let errorOptions = builder.TcConfig.errorSeverityOptions + let untypedErrors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, false, filename, untypedErrors) |] + let tcErrors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, false, filename, tcProj.TcErrors) |] + let parseResults = FSharpParseFileResults(errors = untypedErrors, input = parseTreeOpt, parseHadErrors = false, dependencyFiles = builder.AllDependenciesDeprecated) + let loadClosure = scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.TryGet (ltok, options) ) + let scope = + TypeCheckInfo(tcProj.TcConfig, tcProj.TcGlobals, + Option.get tcProj.LastestCcuSigForFile, + tcProj.TcState.Ccu, tcProj.TcImports, tcProj.TcEnvAtEnd.AccessRights, + options.ProjectFileName, filename, + List.head tcProj.TcResolutionsRev, + List.head tcProj.TcSymbolUsesRev, + tcProj.TcEnvAtEnd.NameEnv, + loadClosure, reactorOps, (fun () -> builder.IsAlive), None, + tcProj.LatestImplementationFile, + List.head tcProj.TcOpenDeclarationsRev) + let typedResults = MakeCheckFileResults(filename, options, builder, scope, Array.ofList tcProj.TcDependencyFiles, creationErrors, parseResults.Errors, tcErrors) + return (parseResults, typedResults) + }) + + + /// Try to get recent approximate type check results for a file. + member bc.TryGetRecentCheckResultsForFile(filename: string, options:FSharpProjectOptions, source, _userOpName: string) = + match source with + | Some sourceText -> + parseCacheLock.AcquireLock (fun ltok -> + match checkFileInProjectCache.TryGet(ltok,(filename,sourceText,options)) with + | Some (a,b,c,_) -> Some (a,b,c) + | None -> parseCacheLock.AcquireLock (fun ltok -> checkFileInProjectCachePossiblyStale.TryGet(ltok,(filename,options)))) + | None -> parseCacheLock.AcquireLock (fun ltok -> checkFileInProjectCachePossiblyStale.TryGet(ltok,(filename,options))) + + /// Parse and typecheck the whole project (the implementation, called recursively as project graph is evaluated) + member private bc.ParseAndCheckProjectImpl(options, ctok, userOpName) : Cancellable = + cancellable { + let! builderOpt,creationErrors,decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) + use _unwind = decrement + match builderOpt with + | None -> + return FSharpCheckProjectResults (options.ProjectFileName, None, keepAssemblyContents, creationErrors, None) + | Some builder -> + let! (tcProj, ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt) = builder.GetCheckResultsAndImplementationsForProject(ctok) + let errorOptions = tcProj.TcConfig.errorSeverityOptions + let fileName = TcGlobals.DummyFileNameForRangesWithoutASpecificLocation + let errors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, true, fileName, tcProj.TcErrors) |] + return FSharpCheckProjectResults (options.ProjectFileName, Some tcProj.TcConfig, keepAssemblyContents, errors, + Some(tcProj.TcGlobals, tcProj.TcImports, tcProj.TcState.Ccu, tcProj.TcState.CcuSig, + tcProj.TcSymbolUses, tcProj.TopAttribs, tcAssemblyDataOpt, ilAssemRef, + tcProj.TcEnvAtEnd.AccessRights, tcAssemblyExprOpt, Array.ofList tcProj.TcDependencyFiles)) + } + + /// Get the timestamp that would be on the output if fully built immediately + member private bc.TryGetLogicalTimeStampForProject(cache, ctok, options, userOpName: string) = + + // NOTE: This creation of the background builder is currently run as uncancellable. Creating background builders is generally + // cheap though the timestamp computations look suspicious for transitive project references. + let builderOpt,_creationErrors,decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName + ".TryGetLogicalTimeStampForProject") |> Cancellable.runWithoutCancellation + use _unwind = decrement + match builderOpt with + | None -> None + | Some builder -> Some (builder.GetLogicalTimeStampForProject(cache, ctok)) + + /// Keep the projet builder alive over a scope + member bc.KeepProjectAlive(options, userOpName) = + reactor.EnqueueAndAwaitOpAsync(userOpName, "KeepProjectAlive", options.ProjectFileName, fun ctok -> + cancellable { + let! _builderOpt,_creationErrors,decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) + return decrement + }) + + /// Parse and typecheck the whole project. + member bc.ParseAndCheckProject(options, userOpName) = + reactor.EnqueueAndAwaitOpAsync(userOpName, "ParseAndCheckProject", options.ProjectFileName, fun ctok -> bc.ParseAndCheckProjectImpl(options, ctok, userOpName)) + + member bc.GetProjectOptionsFromScript(filename, source, loadedTimeStamp, otherFlags, useFsiAuxLib: bool option, assumeDotNetFramework: bool option, extraProjectInfo: obj option, optionsStamp: int64 option, userOpName) = + reactor.EnqueueAndAwaitOpAsync (userOpName, "GetProjectOptionsFromScript", filename, fun ctok -> + cancellable { + use errors = new ErrorScope() + + // Do we add a reference to FSharp.Compiler.Interactive.Settings by default? + let useFsiAuxLib = defaultArg useFsiAuxLib true + + let reduceMemoryUsage = ReduceMemoryFlag.Yes + + // Do we assume .NET Framework references for scripts? + let assumeDotNetFramework = defaultArg assumeDotNetFramework true + let otherFlags = defaultArg otherFlags [| |] + let useSimpleResolution = +#if ENABLE_MONO_SUPPORT + runningOnMono || otherFlags |> Array.exists (fun x -> x = "--simpleresolution") +#else + true +#endif + let loadedTimeStamp = defaultArg loadedTimeStamp DateTime.MaxValue // Not 'now', we don't want to force reloading + let applyCompilerOptions tcConfigB = + let fsiCompilerOptions = CompileOptions.GetCoreFsiCompilerOptions tcConfigB + CompileOptions.ParseCompilerOptions (ignore, fsiCompilerOptions, Array.toList otherFlags) + + let loadClosure = + LoadClosure.ComputeClosureOfScriptText(ctok, legacyReferenceResolver, + defaultFSharpBinariesDir, filename, source, + CodeContext.Editing, useSimpleResolution, useFsiAuxLib, new Lexhelp.LexResourceManager(), + applyCompilerOptions, assumeDotNetFramework, + tryGetMetadataSnapshot=tryGetMetadataSnapshot, + reduceMemoryUsage=reduceMemoryUsage) + + let otherFlags = + [| yield "--noframework"; yield "--warn:3"; + yield! otherFlags + for r in loadClosure.References do yield "-r:" + fst r + for (code,_) in loadClosure.NoWarns do yield "--nowarn:" + code + |] + + let options = + { + ProjectFileName = filename + ".fsproj" // Make a name that is unique in this directory. + ProjectId = None + SourceFiles = loadClosure.SourceFiles |> List.map fst |> List.toArray + OtherOptions = otherFlags + ReferencedProjects= [| |] + IsIncompleteTypeCheckEnvironment = false + UseScriptResolutionRules = true + LoadTime = loadedTimeStamp + UnresolvedReferences = Some (UnresolvedReferencesSet(loadClosure.UnresolvedReferences)) + OriginalLoadReferences = loadClosure.OriginalLoadReferences + ExtraProjectInfo=extraProjectInfo + Stamp = optionsStamp + } + scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.Set(ltok, options, loadClosure)) // Save the full load closure for later correlation. + return options, errors.Diagnostics + }) + + member bc.InvalidateConfiguration(options : FSharpProjectOptions, startBackgroundCompileIfAlreadySeen, userOpName) = + let startBackgroundCompileIfAlreadySeen = defaultArg startBackgroundCompileIfAlreadySeen implicitlyStartBackgroundWork + // This operation can't currently be cancelled nor awaited + reactor.EnqueueOp(userOpName, "InvalidateConfiguration: Stamp(" + (options.Stamp |> Option.defaultValue 0L).ToString() + ")", options.ProjectFileName, fun ctok -> + // If there was a similar entry then re-establish an empty builder . This is a somewhat arbitrary choice - it + // will have the effect of releasing memory associated with the previous builder, but costs some time. + if incrementalBuildersCache.ContainsSimilarKey (ctok, options) then + + // We do not need to decrement here - the onDiscard function is called each time an entry is pushed out of the build cache, + // including by incrementalBuildersCache.Set. + let newBuilderInfo = CreateOneIncrementalBuilder (ctok, options, userOpName) |> Cancellable.runWithoutCancellation + incrementalBuildersCache.Set(ctok, options, newBuilderInfo) + + // Start working on the project. Also a somewhat arbitrary choice + if startBackgroundCompileIfAlreadySeen then + bc.CheckProjectInBackground(options, userOpName + ".StartBackgroundCompile")) + + member bc.NotifyProjectCleaned (options : FSharpProjectOptions, userOpName) = + reactor.EnqueueAndAwaitOpAsync(userOpName, "NotifyProjectCleaned", options.ProjectFileName, fun ctok -> + cancellable { + // If there was a similar entry (as there normally will have been) then re-establish an empty builder . This + // is a somewhat arbitrary choice - it will have the effect of releasing memory associated with the previous + // builder, but costs some time. + if incrementalBuildersCache.ContainsSimilarKey (ctok, options) then + // We do not need to decrement here - the onDiscard function is called each time an entry is pushed out of the build cache, + // including by incrementalBuildersCache.Set. + let! newBuilderInfo = CreateOneIncrementalBuilder (ctok, options, userOpName) + incrementalBuildersCache.Set(ctok, options, newBuilderInfo) + }) + + member bc.CheckProjectInBackground (options, userOpName) = + reactor.SetBackgroundOp (Some (userOpName, "CheckProjectInBackground", options.ProjectFileName, (fun ctok ct -> + // The creation of the background builder can't currently be cancelled + match getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) |> Cancellable.run ct with + | ValueOrCancelled.Cancelled _ -> false + | ValueOrCancelled.Value (builderOpt,_,decrement) -> + use _unwind = decrement + match builderOpt with + | None -> false + | Some builder -> + // The individual steps of the background build + match builder.Step(ctok) |> Cancellable.run ct with + | ValueOrCancelled.Value v -> v + | ValueOrCancelled.Cancelled _ -> false))) + + member bc.StopBackgroundCompile () = + reactor.SetBackgroundOp(None) + + member bc.WaitForBackgroundCompile() = + reactor.WaitForBackgroundOpCompletion() + + member bc.CompleteAllQueuedOps() = + reactor.CompleteAllQueuedOps() + + member bc.Reactor = reactor + member bc.ReactorOps = reactorOps + member bc.BeforeBackgroundFileCheck = beforeFileChecked.Publish + member bc.FileParsed = fileParsed.Publish + member bc.FileChecked = fileChecked.Publish + member bc.ProjectChecked = projectChecked.Publish + + member bc.CurrentQueueLength = reactor.CurrentQueueLength + + member bc.ClearCachesAsync (userOpName) = + reactor.EnqueueAndAwaitOpAsync (userOpName, "ClearCachesAsync", "", fun ctok -> + parseCacheLock.AcquireLock (fun ltok -> + checkFileInProjectCachePossiblyStale.Clear ltok + checkFileInProjectCache.Clear ltok + parseFileCache.Clear(ltok)) + incrementalBuildersCache.Clear ctok + frameworkTcImportsCache.Clear ctok + scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.Clear ltok) + cancellable.Return ()) + + member bc.DownsizeCaches(userOpName) = + reactor.EnqueueAndAwaitOpAsync (userOpName, "DownsizeCaches", "", fun ctok -> + parseCacheLock.AcquireLock (fun ltok -> + checkFileInProjectCachePossiblyStale.Resize(ltok, keepStrongly=1) + checkFileInProjectCache.Resize(ltok, keepStrongly=1) + parseFileCache.Resize(ltok, keepStrongly=1)) + incrementalBuildersCache.Resize(ctok, keepStrongly=1, keepMax=1) + frameworkTcImportsCache.Downsize(ctok) + scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.Resize(ltok,keepStrongly=1, keepMax=1)) + cancellable.Return ()) + + member __.FrameworkImportsCache = frameworkTcImportsCache + member __.ImplicitlyStartBackgroundWork with get() = implicitlyStartBackgroundWork and set v = implicitlyStartBackgroundWork <- v + static member GlobalForegroundParseCountStatistic = foregroundParseCount + static member GlobalForegroundTypeCheckCountStatistic = foregroundTypeCheckCount + + +//---------------------------------------------------------------------------- +// FSharpChecker +// + +[] +[] +// There is typically only one instance of this type in a Visual Studio process. +type FSharpChecker(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) = + + let backgroundCompiler = BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) + + static let globalInstance = lazy FSharpChecker.Create() + + + // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.braceMatchCache. Most recently used cache for brace matching. Accessed on the + // background UI thread, not on the compiler thread. + // + // This cache is safe for concurrent access because there is no onDiscard action for the items in the cache. + let braceMatchCache = MruCache(braceMatchCacheSize, areSimilar = AreSimilarForParsing, areSame = AreSameForParsing) + + let mutable maxMemoryReached = false + let mutable maxMB = maxMBDefault + let maxMemEvent = new Event() + + /// Instantiate an interactive checker. + static member Create(?projectCacheSize, ?keepAssemblyContents, ?keepAllBackgroundResolutions, ?legacyReferenceResolver, ?tryGetMetadataSnapshot) = + + let legacyReferenceResolver = + match legacyReferenceResolver with + | None -> SimulatedMSBuildReferenceResolver.GetBestAvailableResolver() + | Some rr -> rr + + let keepAssemblyContents = defaultArg keepAssemblyContents false + let keepAllBackgroundResolutions = defaultArg keepAllBackgroundResolutions true + let projectCacheSizeReal = defaultArg projectCacheSize projectCacheSizeDefault + let tryGetMetadataSnapshot = defaultArg tryGetMetadataSnapshot (fun _ -> None) + new FSharpChecker(legacyReferenceResolver, projectCacheSizeReal,keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) + + member ic.ReferenceResolver = legacyReferenceResolver + + member ic.MatchBraces(filename, source, options: FSharpParsingOptions, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + async { + match braceMatchCache.TryGet(AssumeAnyCallerThreadWithoutEvidence(), (filename, source, options)) with + | Some res -> return res + | None -> + let res = Parser.matchBraces(source, filename, options, userOpName) + braceMatchCache.Set(AssumeAnyCallerThreadWithoutEvidence(), (filename, source, options), res) + return res + } + + member ic.GetParsingOptionsFromProjectOptions(options): FSharpParsingOptions * _ = + let sourceFiles = List.ofArray options.SourceFiles + let argv = List.ofArray options.OtherOptions + ic.GetParsingOptionsFromCommandLineArgs(sourceFiles, argv, options.UseScriptResolutionRules) + + member ic.MatchBraces(filename, source, options: FSharpProjectOptions, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + let parsingOptions, _ = ic.GetParsingOptionsFromProjectOptions(options) + ic.MatchBraces(filename, source, parsingOptions, userOpName) + + member ic.ParseFile(filename, source, options, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + ic.CheckMaxMemoryReached() + backgroundCompiler.ParseFile(filename, source, options, userOpName) + + + member ic.ParseFileInProject(filename, source, options, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + let parsingOptions, _ = ic.GetParsingOptionsFromProjectOptions(options) + ic.ParseFile(filename, source, parsingOptions, userOpName) + + member ic.GetBackgroundParseResultsForFileInProject (filename,options, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.GetBackgroundParseResultsForFileInProject(filename, options, userOpName) + + member ic.GetBackgroundCheckResultsForFileInProject (filename,options, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.GetBackgroundCheckResultsForFileInProject(filename,options, userOpName) + + /// Try to get recent approximate type check results for a file. + member ic.TryGetRecentCheckResultsForFile(filename: string, options:FSharpProjectOptions, ?source, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.TryGetRecentCheckResultsForFile(filename,options,source, userOpName) + + member ic.Compile(argv: string[], ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync (userOpName, "Compile", "", fun ctok -> + cancellable { + return CompileHelpers.compileFromArgs (ctok, argv, legacyReferenceResolver, None, None) + }) + + member ic.Compile (ast:ParsedInput list, assemblyName:string, outFile:string, dependencies:string list, ?pdbFile:string, ?executable:bool, ?noframework:bool, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync (userOpName, "Compile", assemblyName, fun ctok -> + cancellable { + let noframework = defaultArg noframework false + return CompileHelpers.compileFromAsts (ctok, legacyReferenceResolver, ast, assemblyName, outFile, dependencies, noframework, pdbFile, executable, None, None) + } + ) + + member ic.CompileToDynamicAssembly (otherFlags: string[], execute: (TextWriter * TextWriter) option, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync (userOpName, "CompileToDynamicAssembly", "", fun ctok -> + cancellable { + CompileHelpers.setOutputStreams execute + + // References used to capture the results of compilation + let tcImportsRef = ref (None: TcImports option) + let assemblyBuilderRef = ref None + let tcImportsCapture = Some (fun tcImports -> tcImportsRef := Some tcImports) + + // Function to generate and store the results of compilation + let debugInfo = otherFlags |> Array.exists (fun arg -> arg = "-g" || arg = "--debug:+" || arg = "/debug:+") + let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (ctok, debugInfo, tcImportsRef, execute.IsSome, assemblyBuilderRef)) + + // Perform the compilation, given the above capturing function. + let errorsAndWarnings, result = CompileHelpers.compileFromArgs (ctok, otherFlags, legacyReferenceResolver, tcImportsCapture, dynamicAssemblyCreator) + + // Retrieve and return the results + let assemblyOpt = + match assemblyBuilderRef.Value with + | None -> None + | Some a -> Some (a :> System.Reflection.Assembly) + + return errorsAndWarnings, result, assemblyOpt + } + ) + + member ic.CompileToDynamicAssembly (asts:ParsedInput list, assemblyName:string, dependencies:string list, execute: (TextWriter * TextWriter) option, ?debug:bool, ?noframework:bool, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync (userOpName, "CompileToDynamicAssembly", assemblyName, fun ctok -> + cancellable { + CompileHelpers.setOutputStreams execute + + // References used to capture the results of compilation + let tcImportsRef = ref (None: TcImports option) + let assemblyBuilderRef = ref None + let tcImportsCapture = Some (fun tcImports -> tcImportsRef := Some tcImports) + + let debugInfo = defaultArg debug false + let noframework = defaultArg noframework false + let location = Path.Combine(Path.GetTempPath(),"test"+string(hash assemblyName)) + try Directory.CreateDirectory(location) |> ignore with _ -> () + + let outFile = Path.Combine(location, assemblyName + ".dll") + + // Function to generate and store the results of compilation + let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (ctok, debugInfo, tcImportsRef, execute.IsSome, assemblyBuilderRef)) + + // Perform the compilation, given the above capturing function. + let errorsAndWarnings, result = + CompileHelpers.compileFromAsts (ctok, legacyReferenceResolver, asts, assemblyName, outFile, dependencies, noframework, None, Some execute.IsSome, tcImportsCapture, dynamicAssemblyCreator) + + // Retrieve and return the results + let assemblyOpt = + match assemblyBuilderRef.Value with + | None -> None + | Some a -> Some (a :> System.Reflection.Assembly) + + return errorsAndWarnings, result, assemblyOpt + } + ) + + /// This function is called when the entire environment is known to have changed for reasons not encoded in the ProjectOptions of any project/compilation. + /// For example, the type provider approvals file may have changed. + member ic.InvalidateAll() = + ic.ClearCaches() + + member ic.ClearCachesAsync(?userOpName: string) = + let utok = AssumeAnyCallerThreadWithoutEvidence() + let userOpName = defaultArg userOpName "Unknown" + braceMatchCache.Clear(utok) + backgroundCompiler.ClearCachesAsync(userOpName) + + member ic.ClearCaches(?userOpName) = + ic.ClearCachesAsync(?userOpName=userOpName) |> Async.Start // this cache clearance is not synchronous, it will happen when the background op gets run + + member ic.CheckMaxMemoryReached() = + if not maxMemoryReached && System.GC.GetTotalMemory(false) > int64 maxMB * 1024L * 1024L then + Trace.TraceWarning("!!!!!!!! MAX MEMORY REACHED, DOWNSIZING F# COMPILER CACHES !!!!!!!!!!!!!!!") + // If the maxMB limit is reached, drastic action is taken + // - reduce strong cache sizes to a minimum + let userOpName = "MaxMemoryReached" + backgroundCompiler.CompleteAllQueuedOps() + maxMemoryReached <- true + braceMatchCache.Resize(AssumeAnyCallerThreadWithoutEvidence(), keepStrongly=10) + backgroundCompiler.DownsizeCaches(userOpName) |> Async.RunSynchronously + maxMemEvent.Trigger( () ) + + // This is for unit testing only + member ic.ClearLanguageServiceRootCachesAndCollectAndFinalizeAllTransients() = + backgroundCompiler.CompleteAllQueuedOps() // flush AsyncOp + ic.ClearCachesAsync() |> Async.RunSynchronously + System.GC.Collect() + System.GC.WaitForPendingFinalizers() + backgroundCompiler.CompleteAllQueuedOps() // flush AsyncOp + + /// This function is called when the configuration is known to have changed for reasons not encoded in the ProjectOptions. + /// For example, dependent references may have been deleted or created. + member ic.InvalidateConfiguration(options: FSharpProjectOptions, ?startBackgroundCompile, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.InvalidateConfiguration(options, startBackgroundCompile, userOpName) + + /// This function is called when a project has been cleaned, and thus type providers should be refreshed. + member ic.NotifyProjectCleaned(options: FSharpProjectOptions, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.NotifyProjectCleaned (options, userOpName) + + /// Typecheck a source code file, returning a handle to the results of the + /// parse including the reconstructed types in the file. + member ic.CheckFileInProjectAllowingStaleCachedResults(parseResults:FSharpParseFileResults, filename:string, fileVersion:int, source:string, options:FSharpProjectOptions, ?textSnapshotInfo:obj, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.CheckFileInProjectAllowingStaleCachedResults(parseResults,filename,fileVersion,source,options,textSnapshotInfo, userOpName) + + /// Typecheck a source code file, returning a handle to the results of the + /// parse including the reconstructed types in the file. + member ic.CheckFileInProject(parseResults:FSharpParseFileResults, filename:string, fileVersion:int, source:string, options:FSharpProjectOptions, ?textSnapshotInfo:obj, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + ic.CheckMaxMemoryReached() + backgroundCompiler.CheckFileInProject(parseResults,filename,fileVersion,source,options,textSnapshotInfo, userOpName) + + /// Typecheck a source code file, returning a handle to the results of the + /// parse including the reconstructed types in the file. + member ic.ParseAndCheckFileInProject(filename:string, fileVersion:int, source:string, options:FSharpProjectOptions, ?textSnapshotInfo:obj, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + ic.CheckMaxMemoryReached() + backgroundCompiler.ParseAndCheckFileInProject(filename, fileVersion, source, options, textSnapshotInfo, userOpName) + + member ic.ParseAndCheckProject(options, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + ic.CheckMaxMemoryReached() + backgroundCompiler.ParseAndCheckProject(options, userOpName) + + member ic.KeepProjectAlive(options, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.KeepProjectAlive(options, userOpName) + + /// For a given script file, get the ProjectOptions implied by the #load closure + member ic.GetProjectOptionsFromScript(filename, source, ?loadedTimeStamp, ?otherFlags, ?useFsiAuxLib, ?assumeDotNetFramework, ?extraProjectInfo: obj, ?optionsStamp: int64, ?userOpName: string) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.GetProjectOptionsFromScript(filename, source, loadedTimeStamp, otherFlags, useFsiAuxLib, assumeDotNetFramework, extraProjectInfo, optionsStamp, userOpName) + + member ic.GetProjectOptionsFromCommandLineArgs(projectFileName, argv, ?loadedTimeStamp, ?extraProjectInfo: obj) = + let loadedTimeStamp = defaultArg loadedTimeStamp DateTime.MaxValue // Not 'now', we don't want to force reloading + { ProjectFileName = projectFileName + ProjectId = None + SourceFiles = [| |] // the project file names will be inferred from the ProjectOptions + OtherOptions = argv + ReferencedProjects= [| |] + IsIncompleteTypeCheckEnvironment = false + UseScriptResolutionRules = false + LoadTime = loadedTimeStamp + UnresolvedReferences = None + OriginalLoadReferences=[] + ExtraProjectInfo=extraProjectInfo + Stamp = None } + + member ic.GetParsingOptionsFromCommandLineArgs(initialSourceFiles, argv, ?isInteractive) = + let isInteractive = defaultArg isInteractive false + use errorScope = new ErrorScope() + let tcConfigBuilder = TcConfigBuilder.Initial + + // Apply command-line arguments and collect more source files if they are in the arguments + let sourceFilesNew = ApplyCommandLineArgs(tcConfigBuilder, initialSourceFiles, argv) + FSharpParsingOptions.FromTcConfigBuidler(tcConfigBuilder, Array.ofList sourceFilesNew, isInteractive), errorScope.Diagnostics + + member ic.GetParsingOptionsFromCommandLineArgs(argv, ?isInteractive: bool) = + ic.GetParsingOptionsFromCommandLineArgs([], argv, ?isInteractive=isInteractive) + + /// Begin background parsing the given project. + member ic.StartBackgroundCompile(options, ?userOpName) = + let userOpName = defaultArg userOpName "Unknown" + backgroundCompiler.CheckProjectInBackground(options, userOpName) + + /// Begin background parsing the given project. + member ic.CheckProjectInBackground(options, ?userOpName) = + ic.StartBackgroundCompile(options, ?userOpName=userOpName) + + /// Stop the background compile. + member ic.StopBackgroundCompile() = + backgroundCompiler.StopBackgroundCompile() + + /// Block until the background compile finishes. + // + // This is for unit testing only + member ic.WaitForBackgroundCompile() = backgroundCompiler.WaitForBackgroundCompile() + + // Publish the ReactorOps from the background compiler for internal use + member ic.ReactorOps = backgroundCompiler.ReactorOps + member ic.CurrentQueueLength = backgroundCompiler.CurrentQueueLength + + + member ic.BeforeBackgroundFileCheck = backgroundCompiler.BeforeBackgroundFileCheck + member ic.FileParsed = backgroundCompiler.FileParsed + member ic.FileChecked = backgroundCompiler.FileChecked + member ic.ProjectChecked = backgroundCompiler.ProjectChecked + member ic.ImplicitlyStartBackgroundWork with get() = backgroundCompiler.ImplicitlyStartBackgroundWork and set v = backgroundCompiler.ImplicitlyStartBackgroundWork <- v + member ic.PauseBeforeBackgroundWork with get() = Reactor.Singleton.PauseBeforeBackgroundWork and set v = Reactor.Singleton.PauseBeforeBackgroundWork <- v + + static member GlobalForegroundParseCountStatistic = BackgroundCompiler.GlobalForegroundParseCountStatistic + static member GlobalForegroundTypeCheckCountStatistic = BackgroundCompiler.GlobalForegroundTypeCheckCountStatistic + + member ic.MaxMemoryReached = maxMemEvent.Publish + member ic.MaxMemory with get() = maxMB and set v = maxMB <- v + + static member Instance with get() = globalInstance.Force() + member internal __.FrameworkImportsCache = backgroundCompiler.FrameworkImportsCache + + /// Tokenize a single line, returning token information and a tokenization state represented by an integer + member x.TokenizeLine (line: string, state: FSharpTokenizerLexState) = + let tokenizer = FSharpSourceTokenizer([], None) + let lineTokenizer = tokenizer.CreateLineTokenizer line + let mutable state = (None, state) + let tokens = + [| while (state <- lineTokenizer.ScanToken (snd state); (fst state).IsSome) do + yield (fst state).Value |] + tokens, snd state + + /// Tokenize an entire file, line by line + member x.TokenizeFile (source: string) : FSharpTokenInfo[][] = + let lines = source.Split('\n') + let tokens = + [| let mutable state = FSharpTokenizerLexState.Initial + for line in lines do + let tokens, n = x.TokenizeLine(line, state) + state <- n + yield tokens |] + tokens + + +type FsiInteractiveChecker(legacyReferenceResolver, reactorOps: IReactorOperations, tcConfig: TcConfig, tcGlobals, tcImports, tcState) = + let keepAssemblyContents = false + + member __.ParseAndCheckInteraction (ctok, source, ?userOpName: string) = + async { + let userOpName = defaultArg userOpName "Unknown" + let filename = Path.Combine(tcConfig.implicitIncludeDir, "stdin.fsx") + // Note: projectSourceFiles is only used to compute isLastCompiland, and is ignored if Build.IsScript(mainInputFileName) is true (which it is in this case). + let parsingOptions = FSharpParsingOptions.FromTcConfig(tcConfig, [| filename |], true) + let parseErrors, parseTreeOpt, anyErrors = Parser.parseFile (source, filename, parsingOptions, userOpName) + let dependencyFiles = [| |] // interactions have no dependencies + let parseResults = FSharpParseFileResults(parseErrors, parseTreeOpt, parseHadErrors = anyErrors, dependencyFiles = dependencyFiles) + + let backgroundDiagnostics = [| |] + let reduceMemoryUsage = ReduceMemoryFlag.Yes + let assumeDotNetFramework = true + + let applyCompilerOptions tcConfigB = + let fsiCompilerOptions = CompileOptions.GetCoreFsiCompilerOptions tcConfigB + CompileOptions.ParseCompilerOptions (ignore, fsiCompilerOptions, [ ]) + + let loadClosure = LoadClosure.ComputeClosureOfScriptText(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename, source, CodeContext.Editing, tcConfig.useSimpleResolution, tcConfig.useFsiAuxLib, new Lexhelp.LexResourceManager(), applyCompilerOptions, assumeDotNetFramework, tryGetMetadataSnapshot=(fun _ -> None), reduceMemoryUsage=reduceMemoryUsage) + let! tcErrors, tcFileResult = Parser.CheckOneFile(parseResults, source, filename, "project", tcConfig, tcGlobals, tcImports, tcState, Map.empty, Some loadClosure, backgroundDiagnostics, reactorOps, (fun () -> true), None, userOpName) + + return + match tcFileResult with + | Parser.TypeCheckAborted.No tcFileInfo -> + let errors = [| yield! parseErrors; yield! tcErrors |] + let typeCheckResults = FSharpCheckFileResults (filename, errors, Some tcFileInfo, dependencyFiles, None, reactorOps, false) + let projectResults = + FSharpCheckProjectResults (filename, Some tcConfig, keepAssemblyContents, errors, + Some(tcGlobals, tcImports, tcFileInfo.ThisCcu, tcFileInfo.CcuSigForFile, + [tcFileInfo.ScopeSymbolUses], None, None, mkSimpleAssemblyRef "stdin", + tcState.TcEnvFromImpls.AccessRights, None, dependencyFiles)) + parseResults, typeCheckResults, projectResults + | _ -> + failwith "unexpected aborted" + } + +//---------------------------------------------------------------------------- +// CompilerEnvironment, DebuggerEnvironment +// + +type CompilerEnvironment = + static member BinFolderOfDefaultFSharpCompiler(?probePoint) = + FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(probePoint) + +/// Information about the compilation environment +[] +module CompilerEnvironment = + /// These are the names of assemblies that should be referenced for .fs, .ml, .fsi, .mli files that + /// are not associated with a project + let DefaultReferencesForOrphanSources(assumeDotNetFramework) = DefaultReferencesForScriptsAndOutOfProjectSources(assumeDotNetFramework) + + /// Publish compiler-flags parsing logic. Must be fast because its used by the colorizer. + let GetCompilationDefinesForEditing (parsingOptions: FSharpParsingOptions) = + SourceFileImpl.AdditionalDefinesForUseInEditor(parsingOptions.IsInteractive) @ + parsingOptions.ConditionalCompilationDefines + + /// Return true if this is a subcategory of error or warning message that the language service can emit + let IsCheckerSupportedSubcategory(subcategory:string) = + // Beware: This code logic is duplicated in DocumentTask.cs in the language service + PhasedDiagnostic.IsSubcategoryOfCompile(subcategory) + +/// Information about the debugging environment +module DebuggerEnvironment = + /// Return the language ID, which is the expression evaluator id that the + /// debugger will use. + let GetLanguageID() = + System.Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy) + +module PrettyNaming = + let IsIdentifierPartCharacter x = Microsoft.FSharp.Compiler.PrettyNaming.IsIdentifierPartCharacter x + let IsLongIdentifierPartCharacter x = Microsoft.FSharp.Compiler.PrettyNaming.IsLongIdentifierPartCharacter x + let IsOperatorName x = Microsoft.FSharp.Compiler.PrettyNaming.IsOperatorName x + let GetLongNameFromString x = Microsoft.FSharp.Compiler.PrettyNaming.SplitNamesForILPath x + let FormatAndOtherOverloadsString remainingOverloads = FSComp.SR.typeInfoOtherOverloads(remainingOverloads) + let QuoteIdentifierIfNeeded id = Lexhelp.Keywords.QuoteIdentifierIfNeeded id + let KeywordNames = Lexhelp.Keywords.keywordNames + + +#endif //!FABLE_COMPILER \ No newline at end of file diff --git a/src/fsharp/service/service.fsi b/src/fsharp/service/service.fsi index 2d07c23561..bc3887c6e3 100755 --- a/src/fsharp/service/service.fsi +++ b/src/fsharp/service/service.fsi @@ -15,8 +15,11 @@ open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast +#if !FABLE_COMPILER open Microsoft.FSharp.Compiler.Driver +#endif open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.TcGlobals @@ -81,9 +84,44 @@ type public SemanticClassificationType = | Operator | Disposable +#if FABLE_COMPILER +[] +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 * + checkAlive : (unit -> bool) * + 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 +#endif + /// A handle to the results of CheckFileInProject. [] type public FSharpCheckFileResults = + +#if FABLE_COMPILER + internal new : filename: string * errors: FSharpErrorInfo[] * scopeOptX: TypeCheckInfo option * dependencyFiles: string[] * builderX: IncrementalBuilder option * reactorOpsX:IReactorOperations * keepAssemblyContents: bool -> FSharpCheckFileResults +#endif /// The errors returned by parsing a source file. member Errors : FSharpErrorInfo[] @@ -261,6 +299,9 @@ type public FSharpCheckFileResults = [] type public FSharpCheckProjectResults = +#if FABLE_COMPILER + internal new : projectFileName:string * tcConfigOption: TcConfig option * keepAssemblyContents: bool * errors: FSharpErrorInfo[] * details:(TcGlobals*TcImports*Tast.CcuThunk*Tast.ModuleOrNamespaceType*TcSymbolUses list*TypeChecker.TopAttribs option*CompileOps.IRawFSharpAssemblyData option * ILAssemblyRef * AccessibilityLogic.AccessorDomain * Tast.TypedImplFile list option * string[]) option -> FSharpCheckProjectResults +#endif /// The errors returned by processing the project member Errors: FSharpErrorInfo[] @@ -305,6 +346,9 @@ type public FSharpParsingOptions = IsExe: bool } static member Default: FSharpParsingOptions +#if FABLE_COMPILER + static member internal FromTcConfig: tcConfig: TcConfig * sourceFiles: string[] * isInteractive: bool -> FSharpParsingOptions +#endif /// A set of information describing a project or script build configuration. type public FSharpProjectOptions = @@ -353,6 +397,14 @@ type public FSharpProjectOptions = Stamp: int64 option } +#if FABLE_COMPILER +module internal Parser = + type TypeCheckAborted = Yes | No of TypeCheckInfo + val internal parseFile: source: string * filename: string * options: FSharpParsingOptions * userOpName: string -> FSharpErrorInfo [] * ParsedInput option * bool + val internal CheckOneFile : parseResults:FSharpParseFileResults * source:string * mainInputFileName:string * projectFileName:string * tcConfig:TcConfig * tcGlobals:TcGlobals * tcImports:TcImports * tcState:TcState * moduleNamesDict: ModuleNamesDict * loadClosure:LoadClosure option * backgroundDiagnostics:(PhasedDiagnostic * FSharpErrorSeverity)[] * reactorOps:IReactorOperations * checkAlive:(unit -> bool) * textSnapshotInfo:obj option * userOpName: string -> FSharpErrorInfo [] * TypeCheckAborted + +#else //!FABLE_COMPILER + /// The result of calling TypeCheckResult including the possibility of abort and background compiler not caught up. [] type public FSharpCheckFileAnswer = @@ -765,3 +817,4 @@ module public PrettyNaming = /// All the keywords in the F# language val KeywordNames : string list +#endif //!FABLE_COMPILER diff --git a/src/fsharp/symbols/Exprs.fs b/src/fsharp/symbols/Exprs.fs index 4da520daed..eec3b4df8c 100644 --- a/src/fsharp/symbols/Exprs.fs +++ b/src/fsharp/symbols/Exprs.fs @@ -1129,8 +1129,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 c9049b33c1..6e1a6548f5 100644 --- a/src/fsharp/symbols/Exprs.fsi +++ b/src/fsharp/symbols/Exprs.fsi @@ -12,6 +12,9 @@ open Microsoft.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 f4fb7c0238..7260560bd6 100644 --- a/src/fsharp/symbols/SymbolHelpers.fs +++ b/src/fsharp/symbols/SymbolHelpers.fs @@ -7,6 +7,9 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices +#if FABLE_COMPILER +open Internal.Utilities +#endif open System open System.Collections.Generic open System.IO @@ -433,9 +436,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 +451,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 @@ -780,7 +788,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 @@ -1457,7 +1469,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])) @@ -1474,7 +1486,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 eb12229f7c..3be5b37e3e 100644 --- a/src/fsharp/symbols/SymbolPatterns.fs +++ b/src/fsharp/symbols/SymbolPatterns.fs @@ -2,6 +2,10 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices +#if FABLE_COMPILER +open Internal.Utilities +#endif + /// Patterns over FSharpSymbol and derivatives. [] module Symbol = @@ -41,9 +45,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 fa3fcccfc8..cec2cf6ad1 100755 --- 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) @@ -393,7 +397,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 @@ -410,7 +414,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 @@ -449,6 +453,7 @@ and FSharpEntity(cenv: SymbolEnv, entity:EntityRef) = member __.ArrayRank = checkIsResolved() rankOfArrayTyconRef cenv.g entity + #if !NO_EXTENSIONTYPING member __.IsProvided = isResolved() && @@ -466,6 +471,7 @@ and FSharpEntity(cenv: SymbolEnv, entity:EntityRef) = isResolved() && entity.IsProvidedGeneratedTycon #endif + member __.IsClass = isResolved() && match metadataOfTycon entity.Deref with @@ -919,7 +925,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 = @@ -1063,10 +1073,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] @@ -1350,10 +1360,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)) @@ -1406,7 +1416,7 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = checkIsResolved() match d with | M m -> - match item with + match item2 with | Item.MethodGroup (_name, methodInfos, _) -> let methods = if matchParameterNumber then @@ -1414,7 +1424,7 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = |> List.filter (fun methodInfo -> not (methodInfo.NumArgs = m.NumArgs) ) else methodInfos methods - |> List.map (fun mi -> FSharpMemberOrFunctionOrValue(cenv, M mi, item)) + |> List.map (fun mi -> FSharpMemberOrFunctionOrValue(cenv, M mi, item2)) |> makeReadOnlyCollection |> Some | _ -> None @@ -1980,7 +1990,9 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = member x.IsValCompiledAsMethod = match d with +#if !FABLE_COMPILER | V valRef -> IlxGen.IsValCompiledAsMethod cenv.g valRef.Deref +#endif | _ -> false member x.IsValue = @@ -2209,7 +2221,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) = @@ -2217,7 +2229,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 @@ -2228,14 +2240,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) @@ -2326,7 +2338,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/symbols/Symbols.fsi b/src/fsharp/symbols/Symbols.fsi index 3f3a3f0e0e..9f4d95de06 100644 --- a/src/fsharp/symbols/Symbols.fsi +++ b/src/fsharp/symbols/Symbols.fsi @@ -8,6 +8,7 @@ open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.CompileOps open Microsoft.FSharp.Compiler.Import open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.Tast @@ -16,8 +17,8 @@ open Microsoft.FSharp.Compiler.NameResolution // Implementation details used by other code in the compiler type internal SymbolEnv = + internal new: TcGlobals * thisCcu:CcuThunk * thisCcuTyp: ModuleOrNamespaceType option * tcImports: TcImports * amap: ImportMap * infoReader: InfoReader -> SymbolEnv new: TcGlobals * thisCcu:CcuThunk * thisCcuTyp: ModuleOrNamespaceType option * tcImports: TcImports -> SymbolEnv - new: TcGlobals * thisCcu:CcuThunk * thisCcuTyp: ModuleOrNamespaceType option * tcImports: TcImports * amap: ImportMap * infoReader: InfoReader -> SymbolEnv member amap: ImportMap member g: TcGlobals @@ -420,8 +421,8 @@ and [] public FSharpAnonRecordTypeDetails = and [] public FSharpField = inherit FSharpSymbol - internal new : SymbolEnv * RecdFieldRef -> FSharpField internal new : SymbolEnv * UnionCaseRef * int -> FSharpField + internal new : SymbolEnv * RecdFieldRef -> FSharpField /// Get the declaring entity of this field, if any. Fields from anonymous types do not have a declaring entity member DeclaringEntity: FSharpEntity option @@ -659,6 +660,13 @@ and [] public FSharpInlineAnnotation = /// Indicates the value is aggressively inlined by the .NET runtime | AggressiveInline +and [] internal FSharpMemberOrValData = + | E of EventInfo + | P of PropInfo + | M of MethInfo + | C of MethInfo + | V of ValRef + /// A subtype of F# symbol that represents an F# method, property, event, function or value, including extension members. and [] public FSharpMemberOrFunctionOrValue = @@ -923,9 +931,10 @@ and [] public FSharpActivePatternGroup = and [] public FSharpType = /// Internal use only. Create a ground type. - internal new : g:TcGlobals * thisCcu: CcuThunk * thisCcuTyp: ModuleOrNamespaceType * tcImports: TcImports * ty:TType -> FSharpType internal new : SymbolEnv * ty:TType -> FSharpType + internal new : g:TcGlobals * thisCcu: CcuThunk * thisCcuTyp: ModuleOrNamespaceType * tcImports: TcImports * ty:TType -> FSharpType + /// Indicates this is a named type in an unresolved assembly member IsUnresolved : bool diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 63e7412d90..1592d0f8d5 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -26,6 +26,9 @@ open Microsoft.FSharp.Compiler.PrettyNaming open Microsoft.FSharp.Compiler.QuotationPickler open Microsoft.FSharp.Core.Printf open Microsoft.FSharp.Compiler.Rational +#if FABLE_COMPILER +open Microsoft.FSharp.Core.Operators +#endif #if !NO_EXTENSIONTYPING open Microsoft.FSharp.Compiler.ExtensionTyping @@ -36,13 +39,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 /// A global generator of compiler generated names // ++GLOBAL MUTABLE STATE (concurrency safe by locking inside NiceNameGenerator) @@ -464,7 +475,7 @@ type EntityFlags(flags:int64) = member x.PickledBits = (flags &&& ~~~0b000001111000100L) -#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 92476961fe..112bf9c960 100755 --- a/src/ilx/EraseClosures.fs +++ b/src/ilx/EraseClosures.fs @@ -478,7 +478,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 = [], @@ -575,7 +575,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 b6fb95c4bd..90d092a9f1 100755 --- a/src/ilx/EraseUnions.fs +++ b/src/ilx/EraseUnions.fs @@ -587,8 +587,7 @@ let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = for (i,case) in cases do dict.[i] <- case let failLab = cg.GenerateDelayMark () let emitCase i _ = - let mutable res = Unchecked.defaultof<_> - let ok = dict.TryGetValue(i, &res) + let ok, res = dict.TryGetValue(i) if ok then res else cg.CodeLabel failLab let dests = Array.mapi emitCase cuspec.AlternativesArray @@ -614,7 +613,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 +697,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 +725,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 +826,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 +1038,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 +1065,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 693c500566..c3c9690e56 100755 --- a/src/utils/HashMultiMap.fs +++ b/src/utils/HashMultiMap.fs @@ -14,21 +14,20 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) let firstEntries = Dictionary<_,_>(n,hasheq) 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) = - let mutable res = [] - let ok = rest.TryGetValue(k,&res) + let ok, res = rest.TryGetValue(k) if ok then res else [] member x.Add(y,z) = - let mutable res = Unchecked.defaultof<'Value> - let ok = firstEntries.TryGetValue(y,&res) + let ok, res = firstEntries.TryGetValue(y) if ok then rest.[y] <- res :: x.GetRest(y) firstEntries.[y] <- z @@ -42,7 +41,7 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member x.Rest = rest member x.Copy() = - let res = HashMultiMap<'Key,'Value>(firstEntries.Count,firstEntries.Comparer) + let res = HashMultiMap<'Key,'Value>(firstEntries.Count, hasheq) for kvp in firstEntries do res.FirstEntries.Add(kvp.Key,kvp.Value) @@ -52,15 +51,13 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member x.Item with get(y : 'Key) = - let mutable res = Unchecked.defaultof<'Value> - let ok = firstEntries.TryGetValue(y,&res) + let ok, res = firstEntries.TryGetValue(y) if ok then res else raise (KeyNotFoundException("The item was not found in collection")) and set (y:'Key) (z:'Value) = x.Replace(y,z) member x.FindAll(y) = - let mutable res = Unchecked.defaultof<'Value> - let ok = firstEntries.TryGetValue(y,&res) + let ok, res = firstEntries.TryGetValue(y) if ok then res :: x.GetRest(y) else [] member x.Fold f acc = @@ -88,13 +85,11 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member x.ContainsKey(y) = firstEntries.ContainsKey(y) member x.Remove(y) = - let mutable res = Unchecked.defaultof<'Value> - let ok = firstEntries.TryGetValue(y,&res) + let ok, _ = firstEntries.TryGetValue(y) // NOTE: If not ok then nothing to remove - nop if ok then // We drop the FirstEntry. Here we compute the new FirstEntry and residue MoreEntries - let mutable res = [] - let ok = rest.TryGetValue(y,&res) + let ok, res = rest.TryGetValue(y) if ok then match res with | [h] -> @@ -112,12 +107,25 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) firstEntries.[y] <- z member x.TryFind(y) = - let mutable res = Unchecked.defaultof<'Value> - let ok = firstEntries.TryGetValue(y,&res) + let ok, res = firstEntries.TryGetValue(y) if ok then Some(res) else None 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 interface IEnumerable> with member s.GetEnumerator() = @@ -151,6 +159,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 bd05cfc1d7..0632dbe5b6 100755 --- a/src/utils/HashMultiMap.fsi +++ b/src/utils/HashMultiMap.fsi @@ -10,16 +10,17 @@ open System.Collections.Generic /// The table may map a single key to multiple bindings. [] type internal HashMultiMap<'Key,'Value> = - /// Create a new empty mutable HashMultiMap with the given key hash/equality functions. - new : comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> - /// 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 + /// Create a new empty mutable HashMultiMap with the given key hash/equality functions. + new : comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> /// 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 +59,9 @@ type internal HashMultiMap<'Key,'Value> = /// Apply the given function to each binding in the hash table. member Iterate : ('Key -> 'Value -> unit) -> unit - interface IDictionary<'Key, 'Value> +#if !FABLE_COMPILER + interface IDictionary<'Key, 'Value> +#endif interface ICollection> interface IEnumerable> interface System.Collections.IEnumerable diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs index 232d3b7505..515890bea0 100755 --- a/src/utils/TaggedCollections.fs +++ b/src/utils/TaggedCollections.fs @@ -6,13 +6,13 @@ namespace Internal.Utilities.Collections.Tagged #nowarn "69" // interface implementations in augmentations #nowarn "60" // override implementations in augmentations + open Internal.Utilities + open Internal.Utilities.Collections open Microsoft.FSharp.Core open Microsoft.FSharp.Core.Operators open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open System open System.Collections.Generic - open Internal.Utilities - open Internal.Utilities.Collections [] @@ -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/filename.fs b/src/utils/filename.fs index 35d6d5a769..07665cb1bb 100755 --- a/src/utils/filename.fs +++ b/src/utils/filename.fs @@ -2,6 +2,9 @@ module internal Internal.Utilities.Filename +#if FABLE_COMPILER +open Internal.Utilities +#endif open System.IO open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -35,9 +38,9 @@ let directoryName (s:string) = checkPathForIllegalChars s if s = "" then "." else - match Path.GetDirectoryName(s) with - | null -> if FileSystem.IsPathRootedShim(s) then s else "." - | res -> if res = "" then "." else res + match Path.GetDirectoryName(s) with + | null -> if FileSystem.IsPathRootedShim(s) then s else "." + | res -> if res = "" then "." else res let fileNameOfPath s = checkPathForIllegalChars s diff --git a/src/utils/prim-lexing.fs b/src/utils/prim-lexing.fs index c74d4ef46a..f125d61674 100755 --- a/src/utils/prim-lexing.fs +++ b/src/utils/prim-lexing.fs @@ -6,6 +6,9 @@ namespace Internal.Utilities.Text.Lexing +#if FABLE_COMPILER + open Internal.Utilities +#endif open Microsoft.FSharp.Core open Microsoft.FSharp.Collections open System.Collections.Generic @@ -190,7 +193,7 @@ namespace Internal.Utilities.Text.Lexing module GenericImplFragments = - let startInterpret(lexBuffer:LexBuffer)= + let startInterpret(lexBuffer:LexBuffer) = lexBuffer.BufferScanStart <- lexBuffer.BufferScanStart + lexBuffer.LexemeLength; lexBuffer.BufferMaxScanLength <- lexBuffer.BufferMaxScanLength - lexBuffer.LexemeLength; lexBuffer.BufferScanLength <- 0; diff --git a/src/utils/prim-parsing.fs b/src/utils/prim-parsing.fs index 644aa6b03c..12b4e38567 100755 --- 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 @@ -364,8 +366,8 @@ module internal Implementation = for i = 0 to n - 1 do if valueStack.IsEmpty then failwith "empty symbol stack" let topVal = valueStack.Peep() - valueStack.Pop() - stateStack.Pop() + valueStack.Pop() |> ignore + stateStack.Pop() |> ignore ruleValues.[(n-i)-1] <- topVal.value ruleStartPoss.[(n-i)-1] <- topVal.startPos ruleEndPoss.[(n-i)-1] <- topVal.endPos diff --git a/src/utils/prim-parsing.fsi b/src/utils/prim-parsing.fsi index 762c90796a..196468174d 100755 --- 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 7620a2c411..a64d6e2f13 100755 --- 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: @@ -311,6 +311,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 = @@ -1320,3 +1322,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 afdd931f90..0fe001bac7 100755 --- 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. @@ -365,3 +367,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