diff --git a/.fantomasignore b/.fantomasignore index 0bec7ed1481..d2f57d7fc7f 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -40,31 +40,10 @@ src/Compiler/Checking/TypeHierarchy.fs src/Compiler/Checking/TypeRelations.fs # Incorrectly formatted: https://github.com/dotnet/fsharp/pull/14645/commits/49443a67ea8a17670c8a7c80c8bdf91f82231e91 or https://github.com/fsprojects/fantomas/issues/2733 +# This CompilerImports.fs behavior is not fixed yet, following up in https://github.com/fsprojects/fantomas/issues/2733 src/Compiler/Driver/CompilerImports.fs - -src/Compiler/DependencyManager/AssemblyResolveHandler.fs -src/Compiler/DependencyManager/DependencyProvider.fs -src/Compiler/DependencyManager/NativeDllResolveHandler.fs - -src/Compiler/Facilities/BuildGraph.fs -src/Compiler/Facilities/CompilerLocation.fs -src/Compiler/Facilities/DiagnosticOptions.fs -src/Compiler/Facilities/DiagnosticResolutionHints.fs -src/Compiler/Facilities/DiagnosticsLogger.fs -src/Compiler/Facilities/LanguageFeatures.fs -src/Compiler/Facilities/Logger.fs -src/Compiler/Facilities/prim-lexing.fs -src/Compiler/Facilities/prim-parsing.fs -src/Compiler/Facilities/ReferenceResolver.fs -src/Compiler/Facilities/SimulatedMSBuildReferenceResolver.fs -src/Compiler/Facilities/TextLayoutRender.fs - -src/Compiler/Interactive/ControlledExecution.fs -src/Compiler/Interactive/fsi.fs - -src/Compiler/Legacy/LegacyHostedCompilerForTesting.fs -src/Compiler/Legacy/LegacyMSBuildReferenceResolver.fs - +# The following files were formatted, but the "format, --check" loop is not stable. +# Fantomas formats them, but still thinks they need formatting src/Compiler/Optimize/DetupleArgs.fs src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs src/Compiler/Optimize/LowerCalls.fs @@ -89,7 +68,6 @@ src/Compiler/TypedTree/TypedTreeBasics.fs src/Compiler/TypedTree/TypedTreeOps.fs src/Compiler/TypedTree/TypedTreePickle.fs src/Compiler/TypedTree/TypeProviders.fs - # Explicitly unformatted file that needs more care to get it to format well src/Compiler/SyntaxTree/LexFilter.fs diff --git a/src/Compiler/DependencyManager/AssemblyResolveHandler.fs b/src/Compiler/DependencyManager/AssemblyResolveHandler.fs index 327eb063201..c7f56c903f7 100644 --- a/src/Compiler/DependencyManager/AssemblyResolveHandler.fs +++ b/src/Compiler/DependencyManager/AssemblyResolveHandler.fs @@ -106,12 +106,12 @@ type AssemblyResolveHandlerDeskTop(assemblyProbingPaths: AssemblyResolutionProbe type AssemblyResolveHandler internal (assemblyProbingPaths: AssemblyResolutionProbe option) = let handler = - assemblyProbingPaths |> Option.map (fun _ -> + assemblyProbingPaths + |> Option.map (fun _ -> if isRunningOnCoreClr then new AssemblyResolveHandlerCoreclr(assemblyProbingPaths) :> IDisposable else - new AssemblyResolveHandlerDeskTop(assemblyProbingPaths) :> IDisposable - ) + new AssemblyResolveHandlerDeskTop(assemblyProbingPaths) :> IDisposable) new(assemblyProbingPaths: AssemblyResolutionProbe) = new AssemblyResolveHandler(Option.ofObj assemblyProbingPaths) diff --git a/src/Compiler/DependencyManager/DependencyProvider.fs b/src/Compiler/DependencyManager/DependencyProvider.fs index 257d2869937..f80969b3880 100644 --- a/src/Compiler/DependencyManager/DependencyProvider.fs +++ b/src/Compiler/DependencyManager/DependencyProvider.fs @@ -130,6 +130,7 @@ type IDependencyManagerProvider = abstract Key: string abstract HelpMessages: string[] abstract ClearResultsCache: unit -> unit + abstract ResolveDependencies: scriptDir: string * mainScriptName: string * @@ -141,7 +142,7 @@ type IDependencyManagerProvider = timeout: int -> IResolveDependenciesResult - type ReflectionDependencyManagerProvider +type ReflectionDependencyManagerProvider ( theType: Type, nameProperty: PropertyInfo, @@ -154,10 +155,10 @@ type IDependencyManagerProvider = clearResultCache: MethodInfo option, outputDir: string option, useResultsCache: bool - ) = + ) = let instance = - if not(isNull (theType.GetConstructor([|typeof; typeof|]))) then + if not (isNull (theType.GetConstructor([| typeof; typeof |]))) then Activator.CreateInstance(theType, [| outputDir :> obj; useResultsCache :> obj |]) else Activator.CreateInstance(theType, [| outputDir :> obj |]) @@ -173,11 +174,12 @@ type IDependencyManagerProvider = | None -> fun _ -> [||] static member InstanceMaker(theType: Type, outputDir: string option, useResultsCache: bool) = - match getAttributeNamed theType dependencyManagerAttributeName, - getInstanceProperty theType namePropertyName, - getInstanceProperty theType keyPropertyName, - getInstanceProperty theType helpMessagesPropertyName - with + match + getAttributeNamed theType dependencyManagerAttributeName, + getInstanceProperty theType namePropertyName, + getInstanceProperty theType keyPropertyName, + getInstanceProperty theType helpMessagesPropertyName + with | None, _, _, _ | _, None, _, _ | _, _, None, _ -> None @@ -232,9 +234,7 @@ type IDependencyManagerProvider = resolveDependenciesMethodName let clearResultsCacheMethod = - getInstanceMethod - theType [||] - clearResultsCacheMethodName + getInstanceMethod theType [||] clearResultsCacheMethodName Some(fun () -> ReflectionDependencyManagerProvider( @@ -303,9 +303,7 @@ type IDependencyManagerProvider = resolveDependenciesMethodName let clearResultsCacheMethod = - getInstanceMethod - theType [||] - clearResultsCacheMethodName + getInstanceMethod theType [||] clearResultsCacheMethodName Some(fun () -> ReflectionDependencyManagerProvider( @@ -400,10 +398,9 @@ type IDependencyManagerProvider = member _.Key = instance |> keyProperty /// Clear the dependency manager caches - member _.ClearResultsCache () = + member _.ClearResultsCache() = match clearResultCache with - | Some clearResultsCache -> - clearResultsCache.Invoke(instance, [||]) |> ignore + | Some clearResultsCache -> clearResultsCache.Invoke(instance, [||]) |> ignore | None -> () /// Key of dependency Manager: used for #help @@ -483,7 +480,13 @@ type IDependencyManagerProvider = /// Provides DependencyManagement functions. /// Class is IDisposable -type DependencyProvider internal (assemblyProbingPaths: AssemblyResolutionProbe option, nativeProbingRoots: NativeResolutionProbe option, useResultsCache: bool) = +type DependencyProvider + internal + ( + assemblyProbingPaths: AssemblyResolutionProbe option, + nativeProbingRoots: NativeResolutionProbe option, + useResultsCache: bool + ) = // Note: creating a NativeDllResolveHandler currently installs process-wide handlers let dllResolveHandler = new NativeDllResolveHandler(nativeProbingRoots) @@ -557,11 +560,9 @@ type DependencyProvider internal (assemblyProbingPaths: AssemblyResolutionProbe new(assemblyProbingPaths: AssemblyResolutionProbe, nativeProbingRoots: NativeResolutionProbe, useResultsCache) = new DependencyProvider(Some assemblyProbingPaths, Some nativeProbingRoots, useResultsCache) - new(nativeProbingRoots: NativeResolutionProbe, useResultsCache) = - new DependencyProvider(None, Some nativeProbingRoots, useResultsCache) + new(nativeProbingRoots: NativeResolutionProbe, useResultsCache) = new DependencyProvider(None, Some nativeProbingRoots, useResultsCache) - new(nativeProbingRoots: NativeResolutionProbe) = - new DependencyProvider(None, Some nativeProbingRoots, true) + new(nativeProbingRoots: NativeResolutionProbe) = new DependencyProvider(None, Some nativeProbingRoots, true) new() = new DependencyProvider(None, None, true) diff --git a/src/Compiler/DependencyManager/NativeDllResolveHandler.fs b/src/Compiler/DependencyManager/NativeDllResolveHandler.fs index 47d821bb33b..f11d46499aa 100644 --- a/src/Compiler/DependencyManager/NativeDllResolveHandler.fs +++ b/src/Compiler/DependencyManager/NativeDllResolveHandler.fs @@ -11,12 +11,11 @@ open Internal.Utilities open Internal.Utilities.FSharpEnvironment open FSharp.Compiler.IO - type internal ProbingPathsStore() = let addedPaths = ConcurrentBag() - static member AppendPathSeparator (p: string) = + static member AppendPathSeparator(p: string) = let separator = string Path.PathSeparator if not (p.EndsWith(separator, StringComparison.OrdinalIgnoreCase)) then @@ -27,14 +26,18 @@ type internal ProbingPathsStore() = static member RemoveProbeFromProcessPath probePath = if not (String.IsNullOrWhiteSpace(probePath)) then let probe = ProbingPathsStore.AppendPathSeparator probePath - let path = ProbingPathsStore.AppendPathSeparator (Environment.GetEnvironmentVariable("PATH")) + + let path = + ProbingPathsStore.AppendPathSeparator(Environment.GetEnvironmentVariable("PATH")) if path.Contains(probe) then Environment.SetEnvironmentVariable("PATH", path.Replace(probe, "")) member _.AddProbeToProcessPath probePath = let probe = ProbingPathsStore.AppendPathSeparator probePath - let path = ProbingPathsStore.AppendPathSeparator (Environment.GetEnvironmentVariable("PATH")) + + let path = + ProbingPathsStore.AppendPathSeparator(Environment.GetEnvironmentVariable("PATH")) if not (path.Contains(probe)) then Environment.SetEnvironmentVariable("PATH", path + probe) @@ -46,12 +49,14 @@ type internal ProbingPathsStore() = member this.Dispose() = let mutable probe: string = Unchecked.defaultof + while (addedPaths.TryTake(&probe)) do ProbingPathsStore.RemoveProbeFromProcessPath(probe) interface IDisposable with member _.Dispose() = let mutable probe: string = Unchecked.defaultof + while (addedPaths.TryTake(&probe)) do ProbingPathsStore.RemoveProbeFromProcessPath(probe) @@ -176,7 +181,7 @@ type NativeDllResolveHandler(nativeProbingRoots: NativeResolutionProbe option) = let handler: NativeDllResolveHandlerCoreClr option = nativeProbingRoots - |> Option.filter(fun _ -> isRunningOnCoreClr) + |> Option.filter (fun _ -> isRunningOnCoreClr) |> Option.map (fun _ -> new NativeDllResolveHandlerCoreClr(nativeProbingRoots)) new(nativeProbingRoots: NativeResolutionProbe) = new NativeDllResolveHandler(Option.ofObj nativeProbingRoots) diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index b8ca157ad60..d182a8d8ebf 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -142,9 +142,12 @@ let WriteSignatureData (tcConfig: TcConfig, tcGlobals, exportRemapping, ccu: Ccu tcConfig.outputFile |> Option.iter (fun outputFile -> let outputFile = FileSystem.GetFullPathShim(outputFile) - let signatureDataFile = FileSystem.ChangeExtensionShim(outputFile, ".signature-data.json") + + let signatureDataFile = + FileSystem.ChangeExtensionShim(outputFile, ".signature-data.json") + serializeEntity signatureDataFile mspec) - + // For historical reasons, we use a different resource name for FSharp.Core, so older F# compilers // don't complain when they see the resource. let rName, compress = @@ -1103,7 +1106,7 @@ and [] TcImports initialResolutions: TcAssemblyResolutions, importsBase: TcImports option, dependencyProviderOpt: DependencyProvider option - ) + ) #if !NO_TYPEPROVIDERS as this #endif @@ -1183,10 +1186,11 @@ and [] TcImports if publicOnly then match e.TypeReprInfo with | TILObjectRepr data -> - let (TILObjectReprData(_, _, tyDef)) = data + let (TILObjectReprData (_, _, tyDef)) = data tyDef.Access = ILTypeDefAccess.Public | _ -> false - else true + else + true | None -> false | None -> false diff --git a/src/Compiler/Facilities/BuildGraph.fs b/src/Compiler/Facilities/BuildGraph.fs index f1c2b626be0..33b06b5212e 100644 --- a/src/Compiler/Facilities/BuildGraph.fs +++ b/src/Compiler/Facilities/BuildGraph.fs @@ -105,7 +105,7 @@ type NodeCodeBuilder() = (value :> IDisposable).Dispose() } ) - + [] member _.Using(value: IDisposable, binder: IDisposable -> NodeCode<'U>) = Node( @@ -114,7 +114,6 @@ type NodeCodeBuilder() = return! binder value |> Async.AwaitNodeCode } ) - let node = NodeCodeBuilder() @@ -192,12 +191,9 @@ type NodeCode private () = return results.ToArray() } - - static member Parallel (computations: NodeCode<'T> seq) = - computations - |> Seq.map (fun (Node x) -> x) - |> Async.Parallel - |> Node + + static member Parallel(computations: NodeCode<'T> seq) = + computations |> Seq.map (fun (Node x) -> x) |> Async.Parallel |> Node [] module GraphNode = @@ -238,6 +234,7 @@ type GraphNode<'T> private (computation: NodeCode<'T>, cachedResult: ValueOption else node { Interlocked.Increment(&requestCount) |> ignore + try let! ct = NodeCode.CancellationToken @@ -255,8 +252,8 @@ type GraphNode<'T> private (computation: NodeCode<'T>, cachedResult: ValueOption .ContinueWith( (fun _ -> taken <- true), (TaskContinuationOptions.NotOnCanceled - ||| TaskContinuationOptions.NotOnFaulted - ||| TaskContinuationOptions.ExecuteSynchronously) + ||| TaskContinuationOptions.NotOnFaulted + ||| TaskContinuationOptions.ExecuteSynchronously) ) |> NodeCode.AwaitTask @@ -283,7 +280,8 @@ type GraphNode<'T> private (computation: NodeCode<'T>, cachedResult: ValueOption return! tcs.Task |> NodeCode.AwaitTask finally - if taken then semaphore.Release() |> ignore + if taken then + semaphore.Release() |> ignore finally Interlocked.Decrement(&requestCount) |> ignore } diff --git a/src/Compiler/Facilities/CompilerLocation.fs b/src/Compiler/Facilities/CompilerLocation.fs index 9531acb2cae..8c59a95d0c2 100644 --- a/src/Compiler/Facilities/CompilerLocation.fs +++ b/src/Compiler/Facilities/CompilerLocation.fs @@ -56,7 +56,6 @@ module internal FSharpEnvironment = else None - // The default location of FSharp.Core.dll and fsc.exe based on the version of fsc.exe that is running // Used for // - location of design-time copies of FSharp.Core.dll and FSharp.Compiler.Interactive.Settings.dll for the default assumed environment for scripts @@ -187,7 +186,9 @@ module internal FSharpEnvironment = for p in searchToolPaths path compilerToolPaths do let fileName = Path.Combine(p, assemblyName) - if File.Exists fileName then yield fileName + + if File.Exists fileName then + yield fileName } let loadFromParentDirRelativeToRuntimeAssemblyLocation designTimeAssemblyName = diff --git a/src/Compiler/Facilities/DiagnosticResolutionHints.fs b/src/Compiler/Facilities/DiagnosticResolutionHints.fs index 27ff2059914..e605ace0b5c 100644 --- a/src/Compiler/Facilities/DiagnosticResolutionHints.fs +++ b/src/Compiler/Facilities/DiagnosticResolutionHints.fs @@ -76,7 +76,9 @@ type SuggestionBuffer(idText: string) = data[i] <- data[i + 1] data[pos - 1] <- KeyValuePair(k, v) - if tail > 0 then tail <- tail - 1 + + if tail > 0 then + tail <- tail - 1 member _.Add(suggestion: string) = if not disableSuggestions then @@ -95,10 +97,12 @@ type SuggestionBuffer(idText: string) = let suggestedText = suggestion.ToUpperInvariant() let similarity = EditDistance.JaroWinklerDistance uppercaseText suggestedText - if similarity >= highConfidenceThreshold - || suggestion.EndsWithOrdinal dotIdText - || (similarity >= minThresholdForSuggestions - && IsInEditDistanceProximity uppercaseText suggestedText) then + if + similarity >= highConfidenceThreshold + || suggestion.EndsWithOrdinal dotIdText + || (similarity >= minThresholdForSuggestions + && IsInEditDistanceProximity uppercaseText suggestedText) + then insert (similarity, suggestion) member _.Disabled = disableSuggestions diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index 4f94d6b4fbb..8fb5876b463 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -130,7 +130,7 @@ let ErrorWithSuggestions ((n, message), m, id, suggestions) = DiagnosticWithSuggestions(n, message, m, id, suggestions) let ErrorEnabledWithLanguageFeature ((n, message), m, enabledByLangFeature) = - DiagnosticEnabledWithLanguageFeature (n, message, m, enabledByLangFeature) + DiagnosticEnabledWithLanguageFeature(n, message, m, enabledByLangFeature) let inline protectAssemblyExploration dflt f = try @@ -186,7 +186,7 @@ type StopProcessingExiter() = member val ExitCode = 0 with get, set interface Exiter with - member exiter.Exit n = + member exiter.Exit n = exiter.ExitCode <- n raise StopProcessing @@ -518,7 +518,7 @@ let UseTransformedDiagnosticsLogger (transformer: DiagnosticsLogger -> #Diagnost } let UseDiagnosticsLogger newLogger = - UseTransformedDiagnosticsLogger (fun _ -> newLogger) + UseTransformedDiagnosticsLogger(fun _ -> newLogger) let SetThreadBuildPhaseNoUnwind (phase: BuildPhase) = DiagnosticsThreadStatics.BuildPhase <- phase diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index fa0acceb0df..3e4b2465fc3 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -66,7 +66,7 @@ type LanguageFeature = | StaticMembersInInterfaces | NonInlineLiteralsAsPrintfFormat | NestedCopyAndUpdate - + /// LanguageVersion management type LanguageVersion(versionText) = @@ -84,7 +84,14 @@ type LanguageVersion(versionText) = static let validOptions = [| "preview"; "default"; "latest"; "latestmajor" |] static let languageVersions = - set [| languageVersion46; languageVersion47; languageVersion50; languageVersion60; languageVersion70 |] + set + [| + languageVersion46 + languageVersion47 + languageVersion50 + languageVersion60 + languageVersion70 + |] static let features = dict @@ -256,14 +263,16 @@ type LanguageVersion(versionText) = | LanguageFeature.InterfacesWithAbstractStaticMembers -> FSComp.SR.featureInterfacesWithAbstractStaticMembers () | LanguageFeature.SelfTypeConstraints -> FSComp.SR.featureSelfTypeConstraints () | LanguageFeature.MatchNotAllowedForUnionCaseWithNoData -> FSComp.SR.featureMatchNotAllowedForUnionCaseWithNoData () - | LanguageFeature.CSharpExtensionAttributeNotRequired -> FSComp.SR.featureCSharpExtensionAttributeNotRequired () - | LanguageFeature.ErrorForNonVirtualMembersOverrides -> FSComp.SR.featureErrorForNonVirtualMembersOverrides () - | LanguageFeature.WarningWhenInliningMethodImplNoInlineMarkedFunction -> FSComp.SR.featureWarningWhenInliningMethodImplNoInlineMarkedFunction () + | LanguageFeature.CSharpExtensionAttributeNotRequired -> FSComp.SR.featureCSharpExtensionAttributeNotRequired () + | LanguageFeature.ErrorForNonVirtualMembersOverrides -> FSComp.SR.featureErrorForNonVirtualMembersOverrides () + | LanguageFeature.WarningWhenInliningMethodImplNoInlineMarkedFunction -> + FSComp.SR.featureWarningWhenInliningMethodImplNoInlineMarkedFunction () | LanguageFeature.EscapeDotnetFormattableStrings -> FSComp.SR.featureEscapeBracesInFormattableString () | LanguageFeature.ArithmeticInLiterals -> FSComp.SR.featureArithmeticInLiterals () | LanguageFeature.ErrorReportingOnStaticClasses -> FSComp.SR.featureErrorReportingOnStaticClasses () | LanguageFeature.TryWithInSeqExpression -> FSComp.SR.featureTryWithInSeqExpressions () - | LanguageFeature.WarningWhenCopyAndUpdateRecordChangesAllFields -> FSComp.SR.featureWarningWhenCopyAndUpdateRecordChangesAllFields () + | LanguageFeature.WarningWhenCopyAndUpdateRecordChangesAllFields -> + FSComp.SR.featureWarningWhenCopyAndUpdateRecordChangesAllFields () | LanguageFeature.StaticMembersInInterfaces -> FSComp.SR.featureStaticMembersInInterfaces () | LanguageFeature.NonInlineLiteralsAsPrintfFormat -> FSComp.SR.featureNonInlineLiteralsAsPrintfFormat () | LanguageFeature.NestedCopyAndUpdate -> FSComp.SR.featureNestedCopyAndUpdate () diff --git a/src/Compiler/Facilities/SimulatedMSBuildReferenceResolver.fs b/src/Compiler/Facilities/SimulatedMSBuildReferenceResolver.fs index b3492cb81ac..017cdfaacea 100644 --- a/src/Compiler/Facilities/SimulatedMSBuildReferenceResolver.fs +++ b/src/Compiler/Facilities/SimulatedMSBuildReferenceResolver.fs @@ -2,318 +2,324 @@ module internal FSharp.Compiler.CodeAnalysis.SimulatedMSBuildReferenceResolver - open System - open System.IO - open System.Reflection - open Internal.Utilities.Library - open FSharp.Compiler.IO +open System +open System.IO +open System.Reflection +open Internal.Utilities.Library +open FSharp.Compiler.IO - // ATTENTION!: the following code needs to be updated every time we are switching to the new MSBuild version because new .NET framework version was released - // 1. List of frameworks - // 2. DeriveTargetFrameworkDirectoriesFor45Plus - // 3. HighestInstalledRefAssembliesOrDotNETFramework - // 4. GetPathToDotNetFrameworkImlpementationAssemblies - [] - let private Net45 = "v4.5" +// ATTENTION!: the following code needs to be updated every time we are switching to the new MSBuild version because new .NET framework version was released +// 1. List of frameworks +// 2. DeriveTargetFrameworkDirectoriesFor45Plus +// 3. HighestInstalledRefAssembliesOrDotNETFramework +// 4. GetPathToDotNetFrameworkImlpementationAssemblies +[] +let private Net45 = "v4.5" - [] - let private Net451 = "v4.5.1" +[] +let private Net451 = "v4.5.1" - [] - let private Net452 = "v4.5.2" // not available in Dev15 MSBuild version +[] +let private Net452 = "v4.5.2" // not available in Dev15 MSBuild version - [] - let private Net46 = "v4.6" +[] +let private Net46 = "v4.6" - [] - let private Net461 = "v4.6.1" +[] +let private Net461 = "v4.6.1" - [] - let private Net462 = "v4.6.2" +[] +let private Net462 = "v4.6.2" - [] - let private Net47 = "v4.7" +[] +let private Net47 = "v4.7" - [] - let private Net471 = "v4.7.1" +[] +let private Net471 = "v4.7.1" - [] - let private Net472 = "v4.7.2" +[] +let private Net472 = "v4.7.2" - [] - let private Net48 = "v4.8" +[] +let private Net48 = "v4.8" - let SupportedDesktopFrameworkVersions = - [ Net48; Net472; Net471; Net47; Net462; Net461; Net46; Net452; Net451; Net45 ] +let SupportedDesktopFrameworkVersions = + [ Net48; Net472; Net471; Net47; Net462; Net461; Net46; Net452; Net451; Net45 ] - let private SimulatedMSBuildResolver = +let private SimulatedMSBuildResolver = - /// Get the path to the .NET Framework implementation assemblies by using ToolLocationHelper.GetPathToDotNetFramework - /// This is only used to specify the "last resort" path for assembly resolution. - let GetPathToDotNetFrameworkImlpementationAssemblies _ = - let isDesktop = typeof.Assembly.GetName().Name = "mscorlib" - if isDesktop then - match System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() with - | null -> [] - | x -> [ x ] - else - [] - - let GetPathToDotNetFrameworkReferenceAssemblies version = - ignore version - let r: string list = [] - r - - { new ILegacyReferenceResolver with - member x.HighestInstalledNetFrameworkVersion() = - - let root = x.DotNetFrameworkReferenceAssembliesRootDirectory - - let fwOpt = - SupportedDesktopFrameworkVersions - |> Seq.tryFind (fun fw -> FileSystem.DirectoryExistsShim(Path.Combine(root, fw))) - - match fwOpt with - | Some fw -> fw - | None -> Net45 - - - member _.DotNetFrameworkReferenceAssembliesRootDirectory = - if Environment.OSVersion.Platform = PlatformID.Win32NT then - let PF = - match Environment.GetEnvironmentVariable("ProgramFiles(x86)") with - | null -> Environment.GetEnvironmentVariable("ProgramFiles") // if PFx86 is null, then we are 32-bit and just get PF - | s -> s - - PF + @"\Reference Assemblies\Microsoft\Framework\.NETFramework" - else - "" - - member _.Resolve - ( - resolutionEnvironment, - references, - targetFrameworkVersion, - targetFrameworkDirectories, - targetProcessorArchitecture, - fsharpCoreDir, - explicitIncludeDirs, - implicitIncludeDir, - logMessage, - logWarningOrError - ) = - - - let results = ResizeArray() - - let searchPaths = - [ - yield! targetFrameworkDirectories - yield! explicitIncludeDirs - yield fsharpCoreDir - yield implicitIncludeDir - yield! GetPathToDotNetFrameworkReferenceAssemblies targetFrameworkVersion - yield! GetPathToDotNetFrameworkImlpementationAssemblies targetFrameworkVersion - ] - - for r, baggage in references do - //printfn "resolving %s" r - let mutable found = false - - let success path = - if not found then - //printfn "resolved %s --> %s" r path - found <- true - - results.Add - { - itemSpec = path - prepareToolTip = snd - baggage = baggage - } - - try - if not found && FileSystem.IsPathRootedShim r then - if FileSystem.FileExistsShim r then success r - with e -> - logWarningOrError false "SR001" (e.ToString()) + /// Get the path to the .NET Framework implementation assemblies by using ToolLocationHelper.GetPathToDotNetFramework + /// This is only used to specify the "last resort" path for assembly resolution. + let GetPathToDotNetFrameworkImlpementationAssemblies _ = + let isDesktop = typeof.Assembly.GetName().Name = "mscorlib" - // For this one we need to get the version search exactly right, without doing a load - try - if not found - && r.StartsWithOrdinal("FSharp.Core, Version=") - && Environment.OSVersion.Platform = PlatformID.Win32NT then - let n = AssemblyName r + if isDesktop then + match System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() with + | null -> [] + | x -> [ x ] + else + [] - let fscoreDir0 = - let PF = - match Environment.GetEnvironmentVariable("ProgramFiles(x86)") with - | null -> Environment.GetEnvironmentVariable("ProgramFiles") - | s -> s + let GetPathToDotNetFrameworkReferenceAssemblies version = + ignore version + let r: string list = [] + r - PF - + @"\Reference Assemblies\Microsoft\FSharp\.NETFramework\v4.0\" - + n.Version.ToString() + { new ILegacyReferenceResolver with + member x.HighestInstalledNetFrameworkVersion() = - let trialPath = Path.Combine(fscoreDir0, n.Name + ".dll") + let root = x.DotNetFrameworkReferenceAssembliesRootDirectory - if FileSystem.FileExistsShim trialPath then - success trialPath - with e -> - logWarningOrError false "SR001" (e.ToString()) + let fwOpt = + SupportedDesktopFrameworkVersions + |> Seq.tryFind (fun fw -> FileSystem.DirectoryExistsShim(Path.Combine(root, fw))) - let isFileName = - r.EndsWith("dll", StringComparison.OrdinalIgnoreCase) - || r.EndsWith("exe", StringComparison.OrdinalIgnoreCase) + match fwOpt with + | Some fw -> fw + | None -> Net45 - let qual = - if isFileName then - r - else - try - AssemblyName(r).Name + ".dll" - with _ -> - r + ".dll" + member _.DotNetFrameworkReferenceAssembliesRootDirectory = + if Environment.OSVersion.Platform = PlatformID.Win32NT then + let PF = + match Environment.GetEnvironmentVariable("ProgramFiles(x86)") with + | null -> Environment.GetEnvironmentVariable("ProgramFiles") // if PFx86 is null, then we are 32-bit and just get PF + | s -> s - for searchPath in searchPaths do + PF + @"\Reference Assemblies\Microsoft\Framework\.NETFramework" + else + "" + + member _.Resolve + ( + resolutionEnvironment, + references, + targetFrameworkVersion, + targetFrameworkDirectories, + targetProcessorArchitecture, + fsharpCoreDir, + explicitIncludeDirs, + implicitIncludeDir, + logMessage, + logWarningOrError + ) = + + let results = ResizeArray() + + let searchPaths = + [ + yield! targetFrameworkDirectories + yield! explicitIncludeDirs + yield fsharpCoreDir + yield implicitIncludeDir + yield! GetPathToDotNetFrameworkReferenceAssemblies targetFrameworkVersion + yield! GetPathToDotNetFrameworkImlpementationAssemblies targetFrameworkVersion + ] + + for r, baggage in references do + //printfn "resolving %s" r + let mutable found = false + + let success path = + if not found then + //printfn "resolved %s --> %s" r path + found <- true + + results.Add + { + itemSpec = path + prepareToolTip = snd + baggage = baggage + } + + try + if not found && FileSystem.IsPathRootedShim r then + if FileSystem.FileExistsShim r then + success r + with e -> + logWarningOrError false "SR001" (e.ToString()) + + // For this one we need to get the version search exactly right, without doing a load + try + if + not found + && r.StartsWithOrdinal("FSharp.Core, Version=") + && Environment.OSVersion.Platform = PlatformID.Win32NT + then + let n = AssemblyName r + + let fscoreDir0 = + let PF = + match Environment.GetEnvironmentVariable("ProgramFiles(x86)") with + | null -> Environment.GetEnvironmentVariable("ProgramFiles") + | s -> s + + PF + + @"\Reference Assemblies\Microsoft\FSharp\.NETFramework\v4.0\" + + n.Version.ToString() + + let trialPath = Path.Combine(fscoreDir0, n.Name + ".dll") + + if FileSystem.FileExistsShim trialPath then + success trialPath + with e -> + logWarningOrError false "SR001" (e.ToString()) + + let isFileName = + r.EndsWith("dll", StringComparison.OrdinalIgnoreCase) + || r.EndsWith("exe", StringComparison.OrdinalIgnoreCase) + + let qual = + if isFileName then + r + else try - if not found then - let trialPath = Path.Combine(searchPath, qual) - - if FileSystem.FileExistsShim trialPath then - success trialPath - with e -> - logWarningOrError false "SR001" (e.ToString()) + AssemblyName(r).Name + ".dll" + with _ -> + r + ".dll" + for searchPath in searchPaths do try - // Search the GAC on Windows - if not found - && not isFileName - && Environment.OSVersion.Platform = PlatformID.Win32NT then - let n = AssemblyName r - let netFx = System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() - - let gac = - Path.Combine(Path.GetDirectoryName(Path.GetDirectoryName(netFx.TrimEnd('\\'))), "assembly") - - match n.Version, n.GetPublicKeyToken() with - | null, _ - | _, null -> - let options = - [ - if FileSystem.DirectoryExistsShim gac then - for gacDir in FileSystem.EnumerateDirectoriesShim gac do - let assemblyDir = Path.Combine(gacDir, n.Name) - - if FileSystem.DirectoryExistsShim assemblyDir then - for tdir in FileSystem.EnumerateDirectoriesShim assemblyDir do - let trialPath = Path.Combine(tdir, qual) - if FileSystem.FileExistsShim trialPath then yield trialPath - ] - //printfn "sorting GAC paths: %A" options - options - |> List.sort // puts latest version last - |> List.tryLast - |> function - | None -> () - | Some p -> success p - - | v, tok -> - if FileSystem.DirectoryExistsShim gac then - for gacDir in Directory.EnumerateDirectories gac do - //printfn "searching GAC directory: %s" gacDir - let assemblyDir = Path.Combine(gacDir, n.Name) - - if FileSystem.DirectoryExistsShim assemblyDir then - //printfn "searching GAC directory: %s" assemblyDir - - let tokText = String.concat "" [| for b in tok -> sprintf "%02x" b |] - let verDir = Path.Combine(assemblyDir, "v4.0_" + v.ToString() + "__" + tokText) - //printfn "searching GAC directory: %s" verDir - - if FileSystem.DirectoryExistsShim verDir then - let trialPath = Path.Combine(verDir, qual) - //printfn "searching GAC: %s" trialPath - if FileSystem.FileExistsShim trialPath then - success trialPath + if not found then + let trialPath = Path.Combine(searchPath, qual) + + if FileSystem.FileExistsShim trialPath then + success trialPath with e -> logWarningOrError false "SR001" (e.ToString()) - results.ToArray() - } - |> LegacyReferenceResolver - - let internal getResolver () = SimulatedMSBuildResolver - - #if INTERACTIVE - // Some manual testing - SimulatedMSBuildResolver.DotNetFrameworkReferenceAssembliesRootDirectory - SimulatedMSBuildResolver.HighestInstalledNetFrameworkVersion() - - let fscoreDir = - if System.Environment.OSVersion.Platform = System.PlatformID.Win32NT then // file references only valid on Windows - let PF = - match Environment.GetEnvironmentVariable("ProgramFiles(x86)") with - | null -> Environment.GetEnvironmentVariable("ProgramFiles") // if PFx86 is null, then we are 32-bit and just get PF - | s -> s - - PF + @"\Reference Assemblies\Microsoft\FSharp\.NETFramework\v4.0\4.4.0.0" - else - System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() - - let resolve s = - SimulatedMSBuildResolver.Resolve( - ResolutionEnvironment.EditingOrCompilation, - [| for a in s -> (a, "") |], - "v4.5.1", - [ - SimulatedMSBuildResolver.DotNetFrameworkReferenceAssembliesRootDirectory - + @"\v4.5.1" - ], - "", - "", - fscoreDir, - [], - __SOURCE_DIRECTORY__, - ignore, - (fun _ _ -> ()), - (fun _ _ -> ()) - ) - - // Resolve partial name to something on search path - resolve [ "FSharp.Core" ] - - // Resolve DLL name to something on search path - resolve [ "FSharp.Core.dll" ] - - // Resolve from reference assemblies - resolve [ "System"; "mscorlib"; "mscorlib.dll" ] - - // Resolve from Registry AssemblyFolders - resolve [ "Microsoft.SqlServer.Dmf.dll"; "Microsoft.SqlServer.Dmf" ] - - // Resolve exact version of FSharp.Core - resolve - [ - "FSharp.Core, Version=4.4.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" - ] - - // Resolve from GAC: - resolve - [ - "EventViewer, Version=6.3.0.0, Culture=neutral, PublicKeyToken=31bf3856ad364e35" - ] - - // Resolve from GAC: - resolve [ "EventViewer" ] - - resolve - [ - "Microsoft.SharePoint.Client, Version=15.0.0.0, Culture=neutral, PublicKeyToken=71e9bce111e9429c" - ] - - resolve + try + // Search the GAC on Windows + if + not found + && not isFileName + && Environment.OSVersion.Platform = PlatformID.Win32NT + then + let n = AssemblyName r + let netFx = System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() + + let gac = + Path.Combine(Path.GetDirectoryName(Path.GetDirectoryName(netFx.TrimEnd('\\'))), "assembly") + + match n.Version, n.GetPublicKeyToken() with + | null, _ + | _, null -> + let options = + [ + if FileSystem.DirectoryExistsShim gac then + for gacDir in FileSystem.EnumerateDirectoriesShim gac do + let assemblyDir = Path.Combine(gacDir, n.Name) + + if FileSystem.DirectoryExistsShim assemblyDir then + for tdir in FileSystem.EnumerateDirectoriesShim assemblyDir do + let trialPath = Path.Combine(tdir, qual) + + if FileSystem.FileExistsShim trialPath then + yield trialPath + ] + //printfn "sorting GAC paths: %A" options + options + |> List.sort // puts latest version last + |> List.tryLast + |> function + | None -> () + | Some p -> success p + + | v, tok -> + if FileSystem.DirectoryExistsShim gac then + for gacDir in Directory.EnumerateDirectories gac do + //printfn "searching GAC directory: %s" gacDir + let assemblyDir = Path.Combine(gacDir, n.Name) + + if FileSystem.DirectoryExistsShim assemblyDir then + //printfn "searching GAC directory: %s" assemblyDir + + let tokText = String.concat "" [| for b in tok -> sprintf "%02x" b |] + let verDir = Path.Combine(assemblyDir, "v4.0_" + v.ToString() + "__" + tokText) + //printfn "searching GAC directory: %s" verDir + + if FileSystem.DirectoryExistsShim verDir then + let trialPath = Path.Combine(verDir, qual) + //printfn "searching GAC: %s" trialPath + if FileSystem.FileExistsShim trialPath then + success trialPath + with e -> + logWarningOrError false "SR001" (e.ToString()) + + results.ToArray() + } + |> LegacyReferenceResolver + +let internal getResolver () = SimulatedMSBuildResolver + +#if INTERACTIVE +// Some manual testing +SimulatedMSBuildResolver.DotNetFrameworkReferenceAssembliesRootDirectory +SimulatedMSBuildResolver.HighestInstalledNetFrameworkVersion() + +let fscoreDir = + if System.Environment.OSVersion.Platform = System.PlatformID.Win32NT then // file references only valid on Windows + let PF = + match Environment.GetEnvironmentVariable("ProgramFiles(x86)") with + | null -> Environment.GetEnvironmentVariable("ProgramFiles") // if PFx86 is null, then we are 32-bit and just get PF + | s -> s + + PF + @"\Reference Assemblies\Microsoft\FSharp\.NETFramework\v4.0\4.4.0.0" + else + System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() + +let resolve s = + SimulatedMSBuildResolver.Resolve( + ResolutionEnvironment.EditingOrCompilation, + [| for a in s -> (a, "") |], + "v4.5.1", [ - "Microsoft.SharePoint.Client, Version=16.0.0.0, Culture=neutral, PublicKeyToken=71e9bce111e9429c" - ] - #endif + SimulatedMSBuildResolver.DotNetFrameworkReferenceAssembliesRootDirectory + + @"\v4.5.1" + ], + "", + "", + fscoreDir, + [], + __SOURCE_DIRECTORY__, + ignore, + (fun _ _ -> ()), + (fun _ _ -> ()) + ) + +// Resolve partial name to something on search path +resolve [ "FSharp.Core" ] + +// Resolve DLL name to something on search path +resolve [ "FSharp.Core.dll" ] + +// Resolve from reference assemblies +resolve [ "System"; "mscorlib"; "mscorlib.dll" ] + +// Resolve from Registry AssemblyFolders +resolve [ "Microsoft.SqlServer.Dmf.dll"; "Microsoft.SqlServer.Dmf" ] + +// Resolve exact version of FSharp.Core +resolve + [ + "FSharp.Core, Version=4.4.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" + ] + +// Resolve from GAC: +resolve + [ + "EventViewer, Version=6.3.0.0, Culture=neutral, PublicKeyToken=31bf3856ad364e35" + ] + +// Resolve from GAC: +resolve [ "EventViewer" ] + +resolve + [ + "Microsoft.SharePoint.Client, Version=15.0.0.0, Culture=neutral, PublicKeyToken=71e9bce111e9429c" + ] + +resolve + [ + "Microsoft.SharePoint.Client, Version=16.0.0.0, Culture=neutral, PublicKeyToken=71e9bce111e9429c" + ] +#endif diff --git a/src/Compiler/Facilities/prim-lexing.fs b/src/Compiler/Facilities/prim-lexing.fs index dee03bb5f7e..ac0566ab01a 100644 --- a/src/Compiler/Facilities/prim-lexing.fs +++ b/src/Compiler/Facilities/prim-lexing.fs @@ -185,7 +185,8 @@ and [] internal LexBuffer<'Char>(filler: LexBufferFiller<'Char>, reportL member lexbuf.EndOfScan() : int = //Printf.eprintf "endOfScan, lexBuffer.lexemeLength = %d\n" lexBuffer.lexemeLength; - if bufferAcceptAction < 0 then failwith "unrecognized input" + if bufferAcceptAction < 0 then + failwith "unrecognized input" //printf "endOfScan %d state %d on unconsumed input '%c' (%d)\n" a s (Char.chr inp) inp; //Printf.eprintf "accept, lexeme = %s\n" (lexeme lexBuffer); @@ -387,7 +388,9 @@ type internal UnicodeTables(trans: uint16[] array, accept: uint16[]) = let rec scanUntilSentinel lexBuffer state = // Return an endOfScan after consuming the input let a = int accept[state] - if a <> sentinel then onAccept (lexBuffer, a) + + if a <> sentinel then + onAccept (lexBuffer, a) if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then lexBuffer.DiscardInput() diff --git a/src/Compiler/Facilities/prim-parsing.fs b/src/Compiler/Facilities/prim-parsing.fs index 91b00ba592f..26e14cacc05 100644 --- a/src/Compiler/Facilities/prim-parsing.fs +++ b/src/Compiler/Facilities/prim-parsing.fs @@ -332,12 +332,14 @@ module internal Implementation = let action = actionTable.Read(currState, tables.tagOfErrorTerminal) - if actionKind action = shiftFlag - && (match tokenOpt with - | None -> true - | Some (token) -> - let nextState = actionValue action - actionKind (actionTable.Read(nextState, tables.tagOfToken (token))) = shiftFlag) then + if + actionKind action = shiftFlag + && (match tokenOpt with + | None -> true + | Some (token) -> + let nextState = actionValue action + actionKind (actionTable.Read(nextState, tables.tagOfToken (token))) = shiftFlag) + then if Flags.debug then Console.WriteLine("shifting error, continuing with error recovery") @@ -348,7 +350,8 @@ module internal Implementation = valueStack.Push(ValueInfo(box (), lexbuf.StartPos, lexbuf.EndPos)) stateStack.Push(nextState) else - if valueStack.IsEmpty then failwith "parse error" + if valueStack.IsEmpty then + failwith "parse error" if Flags.debug then Console.WriteLine("popping stack during error recovery") @@ -410,7 +413,10 @@ module internal Implementation = Console.WriteLine("shifting, reduced errorRecoveryLevel to {0}\n", errorSuppressionCountDown) let nextState = actionValue action - if not haveLookahead then failwith "shift on end of input!" + + if not haveLookahead then + failwith "shift on end of input!" + let data = tables.dataOfToken lookaheadToken valueStack.Push(ValueInfo(data, lookaheadStartPos, lookaheadEndPos)) stateStack.Push(nextState) @@ -430,7 +436,9 @@ module internal Implementation = Console.Write("reduce popping {0} values/states, lookahead {1}", n, report haveLookahead lookaheadToken) // For every range to reduce merge it for i = 0 to n - 1 do - if valueStack.IsEmpty then failwith "empty symbol stack" + if valueStack.IsEmpty then + failwith "empty symbol stack" + let topVal = valueStack.Peep() // Grab topVal valueStack.Pop() stateStack.Pop() @@ -444,8 +452,10 @@ module internal Implementation = // Initial range lhsPos[0] <- topVal.startPos lhsPos[1] <- topVal.endPos - elif topVal.startPos.FileIndex = lhsPos[1].FileIndex - && topVal.startPos.Line <= lhsPos[1].Line then + elif + topVal.startPos.FileIndex = lhsPos[1].FileIndex + && topVal.startPos.Line <= lhsPos[1].Line + then // Reduce range if same file as the initial end point lhsPos[0] <- topVal.startPos @@ -484,7 +494,8 @@ module internal Implementation = // User code raised a Parse_error. Don't report errors again until three tokens have been shifted errorSuppressionCountDown <- 3 elif kind = errorFlag then - (if Flags.debug then Console.Write("ErrorFlag... ") + (if Flags.debug then + Console.Write("ErrorFlag... ") // Silently discard inputs and don't report errors // until three tokens in a row have been shifted if Flags.debug then @@ -520,10 +531,12 @@ module internal Implementation = let shiftableTokens = [ for tag, action in actions do - if (actionKind action) = shiftFlag then yield tag + if (actionKind action) = shiftFlag then + yield tag if actionKind defaultAction = shiftFlag then for tag in 0 .. tables.numTerminals - 1 do - if not (explicit.Contains(tag)) then yield tag + if not (explicit.Contains(tag)) then + yield tag ] let stateStack = stateStack.Top(12) @@ -537,10 +550,12 @@ module internal Implementation = let reduceTokens = [ for tag, action in actions do - if actionKind (action) = reduceFlag then yield tag + if actionKind (action) = reduceFlag then + yield tag if actionKind (defaultAction) = reduceFlag then for tag in 0 .. tables.numTerminals - 1 do - if not (explicit.Contains(tag)) then yield tag + if not (explicit.Contains(tag)) then + yield tag ] //let activeRules = stateStack |> List.iter (fun state -> let errorContext = diff --git a/src/Compiler/Interactive/ControlledExecution.fs b/src/Compiler/Interactive/ControlledExecution.fs index 81faf21576a..bbcd0b74088 100644 --- a/src/Compiler/Interactive/ControlledExecution.fs +++ b/src/Compiler/Interactive/ControlledExecution.fs @@ -16,7 +16,7 @@ open Internal.Utilities.FSharpEnvironment open Unchecked -type internal ControlledExecution () = +type internal ControlledExecution() = let mutable cts: CancellationTokenSource voption = ValueNone let mutable thread: Thread voption = ValueNone @@ -24,32 +24,42 @@ type internal ControlledExecution () = static let ceType: Type option = Option.ofObj (Type.GetType("System.Runtime.ControlledExecution, System.Private.CoreLib", false)) - static let threadType: Type option = - Option.ofObj (typeof) + static let threadType: Type option = Option.ofObj (typeof) static let ceRun: MethodInfo option = match ceType with | None -> None - | Some t -> Option.ofObj (t.GetMethod("Run", BindingFlags.Static ||| BindingFlags.Public, defaultof, [|typeof; typeof|], [||] )) + | Some t -> + Option.ofObj ( + t.GetMethod( + "Run", + BindingFlags.Static ||| BindingFlags.Public, + defaultof, + [| typeof; typeof |], + [||] + ) + ) static let threadResetAbort: MethodInfo option = match isRunningOnCoreClr, threadType with | false, Some t -> Option.ofObj (t.GetMethod("ResetAbort", [||])) | _ -> None - member _.Run (action: Action) = + member _.Run(action: Action) = match ceRun with | Some run -> - cts <- ValueSome (new CancellationTokenSource()) - run.Invoke(null, [|action; cts.Value.Token|]) |> ignore + cts <- ValueSome(new CancellationTokenSource()) + run.Invoke(null, [| action; cts.Value.Token |]) |> ignore | _ -> - thread <- ValueSome (Thread.CurrentThread) + thread <- ValueSome(Thread.CurrentThread) action.Invoke() - member _.TryAbort(): unit = + member _.TryAbort() : unit = match isRunningOnCoreClr, cts, thread with - | true, ValueSome cts, _ -> cts.Cancel() - | false, _, ValueSome thread -> thread.Abort(); () + | true, ValueSome cts, _ -> cts.Cancel() + | false, _, ValueSome thread -> + thread.Abort() + () | _ -> () member _.ResetAbort() = @@ -58,7 +68,7 @@ type internal ControlledExecution () = | _ -> () static member StripTargetInvocationException(exn: Exception) = - match exn with - | :? TargetInvocationException as e when not(isNull e.InnerException) -> + match exn with + | :? TargetInvocationException as e when not (isNull e.InnerException) -> ControlledExecution.StripTargetInvocationException(e.InnerException) - | _ -> exn \ No newline at end of file + | _ -> exn diff --git a/src/Compiler/Interactive/fsi.fs b/src/Compiler/Interactive/fsi.fs index d4086d2822f..f6c3b1b00cf 100644 --- a/src/Compiler/Interactive/fsi.fs +++ b/src/Compiler/Interactive/fsi.fs @@ -9,7 +9,7 @@ module FSharp.Compiler.Interactive.Shell [] [] -do() +do () open System open System.Collections.Generic @@ -75,7 +75,7 @@ open FSharp.Compiler.BuildGraph // For the FSI as a service methods... //---------------------------------------------------------------------------- -type FsiValue(reflectionValue:obj, reflectionType:Type, fsharpType:FSharpType) = +type FsiValue(reflectionValue: obj, reflectionType: Type, fsharpType: FSharpType) = member _.ReflectionValue = reflectionValue member _.ReflectionType = reflectionType @@ -91,22 +91,39 @@ type FsiBoundValue(name: string, value: FsiValue) = [] module internal Utilities = type IAnyToLayoutCall = - abstract AnyToLayout : FormatOptions * obj * Type -> Layout - abstract FsiAnyToLayout : FormatOptions * obj * Type -> Layout + abstract AnyToLayout: FormatOptions * obj * Type -> Layout + abstract FsiAnyToLayout: FormatOptions * obj * Type -> Layout type private AnyToLayoutSpecialization<'T>() = interface IAnyToLayoutCall with - member _.AnyToLayout(options, o : obj, ty : Type) = Display.any_to_layout options ((Unchecked.unbox o : 'T), ty) - member _.FsiAnyToLayout(options, o : obj, ty : Type) = Display.fsi_any_to_layout options ((Unchecked.unbox o : 'T), ty) + member _.AnyToLayout(options, o: obj, ty: Type) = + Display.any_to_layout options ((Unchecked.unbox o: 'T), ty) + + member _.FsiAnyToLayout(options, o: obj, ty: Type) = + Display.fsi_any_to_layout options ((Unchecked.unbox o: 'T), ty) let getAnyToLayoutCall ty = let specialized = typedefof>.MakeGenericType [| ty |] Activator.CreateInstance(specialized) :?> IAnyToLayoutCall - let callStaticMethod (ty:Type) name args = - ty.InvokeMember(name, (BindingFlags.InvokeMethod ||| BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic), null, null, Array.ofList args,CultureInfo.InvariantCulture) + let callStaticMethod (ty: Type) name args = + ty.InvokeMember( + name, + (BindingFlags.InvokeMethod + ||| BindingFlags.Static + ||| BindingFlags.Public + ||| BindingFlags.NonPublic), + null, + null, + Array.ofList args, + CultureInfo.InvariantCulture + ) - let ignoreAllErrors f = try f() with _ -> () + let ignoreAllErrors f = + try + f () + with _ -> + () let getMember (name: string) (memberType: MemberTypes) (attr: BindingFlags) (declaringType: Type) = let memberType = @@ -114,42 +131,65 @@ module internal Utilities = memberType ||| MemberTypes.TypeInfo else memberType - declaringType.GetMembers(attr) |> Array.filter(fun m -> 0 <> (int(m.MemberType &&& memberType)) && m.Name = name) + + declaringType.GetMembers(attr) + |> Array.filter (fun m -> 0 <> (int (m.MemberType &&& memberType)) && m.Name = name) let rec tryFindMember (name: string) (memberType: MemberTypes) (declaringType: Type) = - let bindingFlags = BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic + let bindingFlags = + BindingFlags.Instance ||| BindingFlags.Public ||| BindingFlags.NonPublic + match declaringType |> getMember name memberType bindingFlags with | [||] -> declaringType.GetInterfaces() |> Array.tryPick (tryFindMember name memberType) - | [|m|] -> Some m + | [| m |] -> Some m | _ -> raise <| AmbiguousMatchException(sprintf "Ambiguous match for member '%s'" name) - let getInstanceProperty (obj:obj) (nm:string) = - let p = (tryFindMember nm MemberTypes.Property <| obj.GetType()).Value :?> PropertyInfo + let getInstanceProperty (obj: obj) (nm: string) = + let p = + (tryFindMember nm MemberTypes.Property <| obj.GetType()).Value :?> PropertyInfo + p.GetValue(obj, [||]) |> unbox - let setInstanceProperty (obj:obj) (nm:string) (v:obj) = - let p = (tryFindMember nm MemberTypes.Property <| obj.GetType()).Value :?> PropertyInfo + let setInstanceProperty (obj: obj) (nm: string) (v: obj) = + let p = + (tryFindMember nm MemberTypes.Property <| obj.GetType()).Value :?> PropertyInfo + p.SetValue(obj, v, [||]) |> unbox - let callInstanceMethod0 (obj:obj) (typeArgs : Type []) (nm:string) = + let callInstanceMethod0 (obj: obj) (typeArgs: Type[]) (nm: string) = let m = (tryFindMember nm MemberTypes.Method <| obj.GetType()).Value :?> MethodInfo - let m = match typeArgs with [||] -> m | _ -> m.MakeGenericMethod(typeArgs) + + let m = + match typeArgs with + | [||] -> m + | _ -> m.MakeGenericMethod(typeArgs) + m.Invoke(obj, [||]) |> unbox - let callInstanceMethod1 (obj:obj) (typeArgs : Type []) (nm:string) (v:obj) = + let callInstanceMethod1 (obj: obj) (typeArgs: Type[]) (nm: string) (v: obj) = let m = (tryFindMember nm MemberTypes.Method <| obj.GetType()).Value :?> MethodInfo - let m = match typeArgs with [||] -> m | _ -> m.MakeGenericMethod(typeArgs) - m.Invoke(obj, [|v|]) |> unbox - let callInstanceMethod3 (obj:obj) (typeArgs : Type []) (nm:string) (v1:obj) (v2:obj) (v3:obj) = + let m = + match typeArgs with + | [||] -> m + | _ -> m.MakeGenericMethod(typeArgs) + + m.Invoke(obj, [| v |]) |> unbox + + let callInstanceMethod3 (obj: obj) (typeArgs: Type[]) (nm: string) (v1: obj) (v2: obj) (v3: obj) = let m = (tryFindMember nm MemberTypes.Method <| obj.GetType()).Value :?> MethodInfo - let m = match typeArgs with [||] -> m | _ -> m.MakeGenericMethod(typeArgs) - m.Invoke(obj, [|v1;v2;v3|]) |> unbox - let colorPrintL (outWriter : TextWriter) opts layout = + let m = + match typeArgs with + | [||] -> m + | _ -> m.MakeGenericMethod(typeArgs) + + m.Invoke(obj, [| v1; v2; v3 |]) |> unbox + + let colorPrintL (outWriter: TextWriter) opts layout = let renderer = - { new LayoutRenderer with - member r.Start () = NoState + { new LayoutRenderer with + member r.Start() = NoState member r.AddText z s = let color = @@ -176,32 +216,32 @@ module internal Utilities = member r.AddBreak z n = outWriter.WriteLine() - outWriter.Write (String.replicate n " ") + outWriter.Write(String.replicate n " ") z - member r.AddTag z (tag,attrs,start) = z + member r.AddTag z (tag, attrs, start) = z member r.Finish z = outWriter.WriteLine() NoResult } - layout - |> Display.squash_layout opts - |> LayoutRender.renderL renderer - |> ignore + layout |> Display.squash_layout opts |> LayoutRender.renderL renderer |> ignore outWriter.WriteLine() let reportError m = let report errorType err msg = let error = err, msg + match errorType with - | ErrorReportType.Warning -> warning(Error(error, m)) - | ErrorReportType.Error -> errorR(Error(error, m)) + | ErrorReportType.Warning -> warning (Error(error, m)) + | ErrorReportType.Error -> errorR (Error(error, m)) + ResolvingErrorReport report - let getOutputDir (tcConfigB: TcConfigBuilder) = tcConfigB.outputDir |> Option.defaultValue "" + let getOutputDir (tcConfigB: TcConfigBuilder) = + tcConfigB.outputDir |> Option.defaultValue "" /// Timing support [] @@ -209,24 +249,37 @@ type internal FsiTimeReporter(outWriter: TextWriter) = let stopwatch = Stopwatch() let ptime = Process.GetCurrentProcess() let numGC = GC.MaxGeneration + member tr.TimeOp(f) = let startTotal = ptime.TotalProcessorTime - let startGC = [| for i in 0 .. numGC -> GC.CollectionCount(i) |] + let startGC = [| for i in 0..numGC -> GC.CollectionCount(i) |] stopwatch.Reset() stopwatch.Start() let res = f () stopwatch.Stop() let total = ptime.TotalProcessorTime - startTotal - let spanGC = [ for i in 0 .. numGC-> GC.CollectionCount(i) - startGC[i] ] + let spanGC = [ for i in 0..numGC -> GC.CollectionCount(i) - startGC[i] ] let elapsed = stopwatch.Elapsed - fprintfn outWriter "%s" (FSIstrings.SR.fsiTimeInfoMainString((sprintf "%02d:%02d:%02d.%03d" (int elapsed.TotalHours) elapsed.Minutes elapsed.Seconds elapsed.Milliseconds),(sprintf "%02d:%02d:%02d.%03d" (int total.TotalHours) total.Minutes total.Seconds total.Milliseconds),(String.concat ", " (List.mapi (sprintf "%s%d: %d" (FSIstrings.SR.fsiTimeInfoGCGenerationLabelSomeShorthandForTheWordGeneration())) spanGC)))) + + fprintfn + outWriter + "%s" + (FSIstrings.SR.fsiTimeInfoMainString ( + (sprintf "%02d:%02d:%02d.%03d" (int elapsed.TotalHours) elapsed.Minutes elapsed.Seconds elapsed.Milliseconds), + (sprintf "%02d:%02d:%02d.%03d" (int total.TotalHours) total.Minutes total.Seconds total.Milliseconds), + (String.concat + ", " + (List.mapi (sprintf "%s%d: %d" (FSIstrings.SR.fsiTimeInfoGCGenerationLabelSomeShorthandForTheWordGeneration ())) spanGC)) + )) + res member tr.TimeOpIf flag f = if flag then tr.TimeOp f else f () /// Manages the emit of one logical assembly into multiple assemblies. Gives warnings /// on cross-fragment internal access. -type ILMultiInMemoryAssemblyEmitEnv( +type ILMultiInMemoryAssemblyEmitEnv + ( ilg: ILGlobals, resolveAssemblyRef: ILAssemblyRef -> Choice option, dynamicCcuName: string @@ -237,20 +290,22 @@ type ILMultiInMemoryAssemblyEmitEnv( let internalTypes = HashSet(HashIdentity.Structural) let internalMethods = HashSet(HashIdentity.Structural) let internalFields = HashSet(HashIdentity.Structural) - let dynamicCcuScopeRef = ILScopeRef.Assembly (IL.mkSimpleAssemblyRef dynamicCcuName) + let dynamicCcuScopeRef = ILScopeRef.Assembly(IL.mkSimpleAssemblyRef dynamicCcuName) /// Convert an ILAssemblyRef to a dynamic System.Type given the dynamic emit context let convAssemblyRef (aref: ILAssemblyRef) = let asmName = AssemblyName() asmName.Name <- aref.Name + match aref.PublicKey with | None -> () | Some (PublicKey bytes) -> asmName.SetPublicKey bytes | Some (PublicKeyToken bytes) -> asmName.SetPublicKeyToken bytes - match aref.Version with + + match aref.Version with | None -> () - | Some version -> - asmName.Version <- Version (int32 version.Major, int32 version.Minor, int32 version.Build, int32 version.Revision) + | Some version -> asmName.Version <- Version(int32 version.Major, int32 version.Minor, int32 version.Build, int32 version.Revision) + asmName.CultureInfo <- System.Globalization.CultureInfo.InvariantCulture asmName @@ -263,34 +318,36 @@ type ILMultiInMemoryAssemblyEmitEnv( let asmName = AssemblyName.GetAssemblyName(path) asmName.CodeBase <- path FileSystem.AssemblyLoader.AssemblyLoad asmName - | Some (Choice2Of2 assembly) -> - assembly + | Some (Choice2Of2 assembly) -> assembly | None -> let asmName = convAssemblyRef asmref FileSystem.AssemblyLoader.AssemblyLoad asmName + let typT = assembly.GetType qualifiedName + match typT with - | null -> error(Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, asmref.QualifiedName), range0)) + | null -> error (Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, asmref.QualifiedName), range0)) | res -> res /// Convert an Abstract IL type reference to System.Type let convTypeRefAux (tref: ILTypeRef) = - let qualifiedName = (String.concat "+" (tref.Enclosing @ [ tref.Name ])).Replace(",", @"\,") + let qualifiedName = + (String.concat "+" (tref.Enclosing @ [ tref.Name ])).Replace(",", @"\,") + match tref.Scope with - | ILScopeRef.Assembly asmref -> - convResolveAssemblyRef asmref qualifiedName + | ILScopeRef.Assembly asmref -> convResolveAssemblyRef asmref qualifiedName | ILScopeRef.Module _ | ILScopeRef.Local -> let typT = Type.GetType qualifiedName + match typT with - | null -> error(Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, ""), range0)) + | null -> error (Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, ""), range0)) | res -> res - | ILScopeRef.PrimaryAssembly -> - convResolveAssemblyRef ilg.primaryAssemblyRef qualifiedName + | ILScopeRef.PrimaryAssembly -> convResolveAssemblyRef ilg.primaryAssemblyRef qualifiedName /// Convert an ILTypeRef to a dynamic System.Type given the dynamic emit context let convTypeRef (tref: ILTypeRef) = - if tref.Scope.IsLocalRef then + if tref.Scope.IsLocalRef then assert tref.Scope.IsLocalRef let typ, _ = typeMap[tref] typ @@ -302,13 +359,18 @@ type ILMultiInMemoryAssemblyEmitEnv( let tref = tspec.TypeRef let typT = convTypeRef tref let tyargs = List.map convTypeAux tspec.GenericArgs + let res = match isNil tyargs, typT.IsGenericType with | _, true -> typT.MakeGenericType(List.toArray tyargs) | true, false -> typT | _, false -> null + match res with - | null -> error(Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", tspec.TypeRef.QualifiedName, tspec.Scope.QualifiedName), range0)) + | null -> + error ( + Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", tspec.TypeRef.QualifiedName, tspec.Scope.QualifiedName), range0) + ) | _ -> res and convTypeAux ty = @@ -316,8 +378,11 @@ type ILMultiInMemoryAssemblyEmitEnv( | ILType.Void -> Type.GetType("System.Void") | ILType.Array (shape, eltType) -> let baseT = convTypeAux eltType - if shape.Rank=1 then baseT.MakeArrayType() - else baseT.MakeArrayType shape.Rank + + if shape.Rank = 1 then + baseT.MakeArrayType() + else + baseT.MakeArrayType shape.Rank | ILType.Value tspec -> convTypeSpec tspec | ILType.Boxed tspec -> convTypeSpec tspec | ILType.Ptr eltType -> @@ -327,12 +392,11 @@ type ILMultiInMemoryAssemblyEmitEnv( let baseT = convTypeAux eltType baseT.MakeByRefType() | ILType.TypeVar _tv -> failwith "open generic type" - | ILType.Modified (_, _, modifiedTy) -> - convTypeAux modifiedTy + | ILType.Modified (_, _, modifiedTy) -> convTypeAux modifiedTy | ILType.FunctionPointer _callsig -> failwith "convType: fptr" /// Map the given ILTypeRef to the appropriate assembly fragment - member _.MapTypeRef (tref: ILTypeRef) = + member _.MapTypeRef(tref: ILTypeRef) = if tref.Scope.IsLocalRef && typeMap.ContainsKey(tref) then typeMap[tref] |> snd else @@ -340,19 +404,17 @@ type ILMultiInMemoryAssemblyEmitEnv( /// Map an ILTypeRef built from reflection over loaded assembly fragments back to an ILTypeRef suitable /// to use on the F# compiler logic. - member _.ReverseMapTypeRef (tref: ILTypeRef) = + member _.ReverseMapTypeRef(tref: ILTypeRef) = if reverseTypeMap.ContainsKey(tref) then reverseTypeMap[tref] else tref /// Convert an ILTypeRef to a dynamic System.Type given the dynamic emit context - member _.LookupTypeRef (tref: ILTypeRef) = - convTypeRef tref + member _.LookupTypeRef(tref: ILTypeRef) = convTypeRef tref /// Convert an ILType to a dynamic System.Type given the dynamic emit context - member _.LookupType (ty: ILType) = - convTypeAux ty + member _.LookupType(ty: ILType) = convTypeAux ty /// Record the given ILTypeDef in the dynamic emit context member emEnv.AddTypeDef (asm: Assembly) ilScopeRef enc (tdef: ILTypeDef) = @@ -364,9 +426,10 @@ type ILMultiInMemoryAssemblyEmitEnv( let rtref = rescopeILTypeRef dynamicCcuScopeRef tref typeMap.Add(ltref, (typ, tref)) reverseTypeMap.Add(tref, rtref) + for ntdef in tdef.NestedTypes.AsArray() do - emEnv.AddTypeDef asm ilScopeRef (enc@[tdef]) ntdef - + emEnv.AddTypeDef asm ilScopeRef (enc @ [ tdef ]) ntdef + // Record the internal things to give warnings for internal access across fragment boundaries for fdef in tdef.Fields.AsList() do match fdef.Access with @@ -383,10 +446,9 @@ type ILMultiInMemoryAssemblyEmitEnv( internalMethods.Add(lmref) |> ignore match tdef.Access with - | ILTypeDefAccess.Public + | ILTypeDefAccess.Public | ILTypeDefAccess.Nested ILMemberAccess.Public -> () - | _ -> - internalTypes.Add(ltref) |> ignore + | _ -> internalTypes.Add(ltref) |> ignore /// Record the given ILModuleDef (i.e. an assembly) in the dynamic emit context member emEnv.AddModuleDef asm ilScopeRef (mdef: ILModuleDef) = @@ -394,15 +456,15 @@ type ILMultiInMemoryAssemblyEmitEnv( emEnv.AddTypeDef asm ilScopeRef [] tdef /// Check if an ILTypeRef is a reference to an already-emitted internal type within the dynamic emit context - member _.IsLocalInternalType (tref: ILTypeRef) = + member _.IsLocalInternalType(tref: ILTypeRef) = tref.Scope.IsLocalRef && internalTypes.Contains(tref) /// Check if an ILMethodRef is a reference to an already-emitted internal method within the dynamic emit context - member _.IsLocalInternalMethod (mref: ILMethodRef) = + member _.IsLocalInternalMethod(mref: ILMethodRef) = mref.DeclaringTypeRef.Scope.IsLocalRef && internalMethods.Contains(mref) /// Check if an ILFieldRef is a reference to an already-emitted internal field within the dynamic emit context - member _.IsLocalInternalField (fref: ILFieldRef) = + member _.IsLocalInternalField(fref: ILFieldRef) = fref.DeclaringTypeRef.Scope.IsLocalRef && internalFields.Contains(fref) type ILAssemblyEmitEnv = @@ -413,7 +475,7 @@ type internal FsiValuePrinterMode = | PrintExpr | PrintDecl -type EvaluationEventArgs(fsivalue : FsiValue option, symbolUse : FSharpSymbolUse, decl: FSharpImplementationFileDeclaration) = +type EvaluationEventArgs(fsivalue: FsiValue option, symbolUse: FSharpSymbolUse, decl: FSharpImplementationFileDeclaration) = inherit EventArgs() member _.Name = symbolUse.Symbol.DisplayName member _.FsiValue = fsivalue @@ -424,7 +486,7 @@ type EvaluationEventArgs(fsivalue : FsiValue option, symbolUse : FSharpSymbolUse /// User-configurable information that changes how F# Interactive operates, stored in the 'fsi' object /// and accessible via the programming model [] -type FsiEvaluationSessionHostConfig () = +type FsiEvaluationSessionHostConfig() = let evaluationEvent = Event() /// Called by the evaluation session to ask the host for parameters to format text for output @@ -434,7 +496,7 @@ type FsiEvaluationSessionHostConfig () = abstract FloatingPointFormat: string /// Called by the evaluation session to ask the host for parameters to format text for output - abstract AddedPrinters : Choice string), Type * (obj -> obj)> list + abstract AddedPrinters: Choice string), Type * (obj -> obj)> list /// Called by the evaluation session to ask the host for parameters to format text for output abstract ShowDeclarationValues: bool @@ -443,23 +505,23 @@ type FsiEvaluationSessionHostConfig () = abstract ShowIEnumerable: bool /// Called by the evaluation session to ask the host for parameters to format text for output - abstract ShowProperties : bool + abstract ShowProperties: bool /// Called by the evaluation session to ask the host for parameters to format text for output - abstract PrintSize : int + abstract PrintSize: int /// Called by the evaluation session to ask the host for parameters to format text for output - abstract PrintDepth : int + abstract PrintDepth: int /// Called by the evaluation session to ask the host for parameters to format text for output - abstract PrintWidth : int + abstract PrintWidth: int /// Called by the evaluation session to ask the host for parameters to format text for output - abstract PrintLength : int + abstract PrintLength: int /// The evaluation session calls this to report the preferred view of the command line arguments after /// stripping things like "/use:file.fsx", "-r:Foo.dll" etc. - abstract ReportUserCommandLineArgs : string [] -> unit + abstract ReportUserCommandLineArgs: string[] -> unit /// The evaluation session calls this to ask the host for the special console reader. /// Returning 'Some' indicates a console is to be used, so some special rules apply. @@ -480,117 +542,127 @@ type FsiEvaluationSessionHostConfig () = /// - If a console is being used then use GetOptionalConsoleReadLine() /// - Otherwise use inReader.ReadLine() - abstract GetOptionalConsoleReadLine : probeToSeeIfConsoleWorks: bool -> (unit -> string) option + abstract GetOptionalConsoleReadLine: probeToSeeIfConsoleWorks: bool -> (unit -> string) option /// The evaluation session calls this at an appropriate point in the startup phase if the --fsi-server parameter was given - abstract StartServer : fsiServerName:string -> unit + abstract StartServer: fsiServerName: string -> unit /// Called by the evaluation session to ask the host to enter a dispatch loop like Application.Run(). /// Only called if --gui option is used (which is the default). /// Gets called towards the end of startup and every time a ThreadAbort escaped to the backup driver loop. /// Return true if a 'restart' is required, which is a bit meaningless. - abstract EventLoopRun : unit -> bool + abstract EventLoopRun: unit -> bool /// Request that the given operation be run synchronously on the event loop. - abstract EventLoopInvoke : codeToRun: (unit -> 'T) -> 'T + abstract EventLoopInvoke: codeToRun: (unit -> 'T) -> 'T /// Schedule a restart for the event loop. - abstract EventLoopScheduleRestart : unit -> unit + abstract EventLoopScheduleRestart: unit -> unit /// Implicitly reference FSharp.Compiler.Interactive.Settings.dll - abstract UseFsiAuxLib : bool + abstract UseFsiAuxLib: bool /// Hook for listening for evaluation bindings member _.OnEvaluation = evaluationEvent.Publish - member internal x.TriggerEvaluation (value, symbolUse, decl) = - evaluationEvent.Trigger (EvaluationEventArgs (value, symbolUse, decl) ) + member internal x.TriggerEvaluation(value, symbolUse, decl) = + evaluationEvent.Trigger(EvaluationEventArgs(value, symbolUse, decl)) /// Used to print value signatures along with their values, according to the current /// set of pretty printers installed in the system, and default printing rules. type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, outWriter: TextWriter) = /// This printer is used by F# Interactive if no other printers apply. - let DefaultPrintingIntercept (ienv: IEnvironment) (obj:obj) = - match obj with - | null -> None - | :? System.Collections.IDictionary as ie -> - let it = ie.GetEnumerator() - try - let itemLs = - unfoldL // the function to layout each object in the unfold - (fun obj -> ienv.GetLayout obj) - // the function to call at each step of the unfold - (fun () -> - if it.MoveNext() then - Some((it.Key, it.Value),()) - else None) () - // the maximum length - (1+fsi.PrintLength/3) - let makeListL itemLs = - (leftL (TaggedText.tagText "[")) ^^ - sepListL (rightL (TaggedText.tagText ";")) itemLs ^^ - (rightL (TaggedText.tagText "]")) - Some(wordL (TaggedText.tagText "dict") --- makeListL itemLs) - finally - match it with - | :? IDisposable as d -> d.Dispose() - | _ -> () - - | _ -> None + let DefaultPrintingIntercept (ienv: IEnvironment) (obj: obj) = + match obj with + | null -> None + | :? System.Collections.IDictionary as ie -> + let it = ie.GetEnumerator() + + try + let itemLs = + unfoldL // the function to layout each object in the unfold + (fun obj -> ienv.GetLayout obj) + // the function to call at each step of the unfold + (fun () -> if it.MoveNext() then Some((it.Key, it.Value), ()) else None) + () + // the maximum length + (1 + fsi.PrintLength / 3) + let makeListL itemLs = + (leftL (TaggedText.tagText "[")) + ^^ sepListL (rightL (TaggedText.tagText ";")) itemLs + ^^ (rightL (TaggedText.tagText "]")) + + Some(wordL (TaggedText.tagText "dict") --- makeListL itemLs) + finally + match it with + | :? IDisposable as d -> d.Dispose() + | _ -> () + + | _ -> None /// Get the print options used when formatting output using the structured printer. member _.GetFsiPrintOptions() = { FormatOptions.Default with - FormatProvider = fsi.FormatProvider; - PrintIntercepts = - // The fsi object supports the addition of two kinds of printers, one which converts to a string - // and one which converts to another object that is recursively formatted. - // The internal AddedPrinters reports these to FSI.EXE and we pick them up here to produce a layout - [ for x in fsi.AddedPrinters do - match x with - | Choice1Of2 (aty: Type, printer) -> - yield (fun _ienv (obj:obj) -> - match obj with - | null -> None - | _ when aty.IsAssignableFrom(obj.GetType()) -> - let text = printer obj - match box text with - | null -> None - | _ -> Some (wordL (TaggedText.tagText text)) - | _ -> None) - - | Choice2Of2 (aty: Type, converter) -> - yield (fun ienv (obj:obj) -> - match obj with - | null -> None - | _ when aty.IsAssignableFrom(obj.GetType()) -> - match converter obj with - | null -> None - | res -> Some (ienv.GetLayout res) - | _ -> None) - yield DefaultPrintingIntercept]; - FloatingPointFormat = fsi.FloatingPointFormat; - PrintWidth = fsi.PrintWidth; - PrintDepth = fsi.PrintDepth; - PrintLength = fsi.PrintLength; - PrintSize = fsi.PrintSize; - ShowProperties = fsi.ShowProperties; - ShowIEnumerable = fsi.ShowIEnumerable; } + FormatProvider = fsi.FormatProvider + PrintIntercepts = + // The fsi object supports the addition of two kinds of printers, one which converts to a string + // and one which converts to another object that is recursively formatted. + // The internal AddedPrinters reports these to FSI.EXE and we pick them up here to produce a layout + [ + for x in fsi.AddedPrinters do + match x with + | Choice1Of2 (aty: Type, printer) -> + yield + (fun _ienv (obj: obj) -> + match obj with + | null -> None + | _ when aty.IsAssignableFrom(obj.GetType()) -> + let text = printer obj + + match box text with + | null -> None + | _ -> Some(wordL (TaggedText.tagText text)) + | _ -> None) + + | Choice2Of2 (aty: Type, converter) -> + yield + (fun ienv (obj: obj) -> + match obj with + | null -> None + | _ when aty.IsAssignableFrom(obj.GetType()) -> + match converter obj with + | null -> None + | res -> Some(ienv.GetLayout res) + | _ -> None) + yield DefaultPrintingIntercept + ] + FloatingPointFormat = fsi.FloatingPointFormat + PrintWidth = fsi.PrintWidth + PrintDepth = fsi.PrintDepth + PrintLength = fsi.PrintLength + PrintSize = fsi.PrintSize + ShowProperties = fsi.ShowProperties + ShowIEnumerable = fsi.ShowIEnumerable + } /// Get the evaluation context used when inverting the storage mapping of the ILDynamicAssemblyWriter. - member _.GetEvaluationContext (emEnv: ILAssemblyEmitEnv) = - match emEnv with + member _.GetEvaluationContext(emEnv: ILAssemblyEmitEnv) = + match emEnv with | SingleRefEmitAssembly (cenv, emEnv) -> - { LookupTypeRef = LookupTypeRef cenv emEnv - LookupType = LookupType cenv emEnv } + { + LookupTypeRef = LookupTypeRef cenv emEnv + LookupType = LookupType cenv emEnv + } | MultipleInMemoryAssemblies emEnv -> - { LookupTypeRef = emEnv.LookupTypeRef - LookupType = emEnv.LookupType } + { + LookupTypeRef = emEnv.LookupTypeRef + LookupType = emEnv.LookupType + } /// Generate a layout for an actual F# value, where we know the value has the given static type. - member _.PrintValue (printMode, opts:FormatOptions, x:obj, ty:Type) = + member _.PrintValue(printMode, opts: FormatOptions, x: obj, ty: Type) = // We do a dynamic invoke of any_to_layout with the right System.Type parameter for the static type of the saved value. // In principle this helps any_to_layout do the right thing as it descends through terms. In practice it means // it at least does the right thing for top level 'null' list and option values (but not for nested ones). @@ -606,24 +678,24 @@ type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, outWriter: Te // try let anyToLayoutCall = getAnyToLayoutCall ty + match printMode with - | PrintDecl -> - // When printing rhs of fsi declarations, use "fsi_any_to_layout". - // This will suppress some less informative values, by returning an empty layout. [fix 4343]. - anyToLayoutCall.FsiAnyToLayout(opts, x, ty) - | PrintExpr -> - anyToLayoutCall.AnyToLayout(opts, x, ty) + | PrintDecl -> + // When printing rhs of fsi declarations, use "fsi_any_to_layout". + // This will suppress some less informative values, by returning an empty layout. [fix 4343]. + anyToLayoutCall.FsiAnyToLayout(opts, x, ty) + | PrintExpr -> anyToLayoutCall.AnyToLayout(opts, x, ty) with | :? ThreadAbortException -> wordL (TaggedText.tagText "") | e -> #if DEBUG - printf "\n\nPrintValue: x = %+A and ty=%s\n" x ty.FullName + printf "\n\nPrintValue: x = %+A and ty=%s\n" x ty.FullName #endif - printf "%s" (FSIstrings.SR.fsiExceptionDuringPrettyPrinting(e.ToString())); - wordL (TaggedText.tagText "") + printf "%s" (FSIstrings.SR.fsiExceptionDuringPrettyPrinting (e.ToString())) + wordL (TaggedText.tagText "") /// Display the signature of an F# value declaration, along with its actual value. - member valuePrinter.InvokeDeclLayout (emEnv, ilxGenerator: IlxAssemblyGenerator, v:Val) = + member valuePrinter.InvokeDeclLayout(emEnv, ilxGenerator: IlxAssemblyGenerator, v: Val) = // Implemented via a lookup from v to a concrete (System.Object,System.Type). // This (obj,objTy) pair can then be fed to the fsi value printer. // Note: The value may be (null:Object). @@ -639,55 +711,74 @@ type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, outWriter: Te // - No properties, since they may have unexpected effects. // - Limit strings to roughly one line, since huge strings (e.g. 1 million chars without \n are slow in vfsi). // - Limit PrintSize which is a count on nodes. - let declaredValueReductionFactor = 10 (* reduce PrintSize for declared values, e.g. see less of large terms *) + let declaredValueReductionFactor = + 10 (* reduce PrintSize for declared values, e.g. see less of large terms *) let opts = valuePrinter.GetFsiPrintOptions() + let opts = { opts with - ShowProperties = false // properties off, motivated by Form props + ShowProperties = false // properties off, motivated by Form props ShowIEnumerable = false // seq off, motivated by db query concerns - StringLimit = max 0 (opts.PrintWidth-4) // 4 allows for an indent of 2 and 2 quotes (rough) - PrintSize = opts.PrintSize / declaredValueReductionFactor } // print less + StringLimit = max 0 (opts.PrintWidth - 4) // 4 allows for an indent of 2 and 2 quotes (rough) + PrintSize = opts.PrintSize / declaredValueReductionFactor + } // print less let res = try - ilxGenerator.LookupGeneratedValue (valuePrinter.GetEvaluationContext emEnv, v) + ilxGenerator.LookupGeneratedValue(valuePrinter.GetEvaluationContext emEnv, v) with _ -> None match res with | None -> None - | Some (obj,objTy) -> - let lay = valuePrinter.PrintValue (FsiValuePrinterMode.PrintDecl, opts, obj, objTy) + | Some (obj, objTy) -> + let lay = valuePrinter.PrintValue(FsiValuePrinterMode.PrintDecl, opts, obj, objTy) if isEmptyL lay then None else Some lay // suppress empty layout else None - /// Format a value - member valuePrinter.FormatValue (obj:obj, objTy) = - let opts = valuePrinter.GetFsiPrintOptions() - let lay = valuePrinter.PrintValue (FsiValuePrinterMode.PrintExpr, opts, obj, objTy) + member valuePrinter.FormatValue(obj: obj, objTy) = + let opts = valuePrinter.GetFsiPrintOptions() + let lay = valuePrinter.PrintValue(FsiValuePrinterMode.PrintExpr, opts, obj, objTy) Display.layout_to_string opts lay /// Fetch the saved value of an expression out of the 'it' register and show it. - member valuePrinter.InvokeExprPrinter (denv, infoReader, emEnv, ilxGenerator: IlxAssemblyGenerator, vref: ValRef) = - let opts = valuePrinter.GetFsiPrintOptions() - let res = ilxGenerator.LookupGeneratedValue (valuePrinter.GetEvaluationContext emEnv, vref.Deref) + member valuePrinter.InvokeExprPrinter(denv, infoReader, emEnv, ilxGenerator: IlxAssemblyGenerator, vref: ValRef) = + let opts = valuePrinter.GetFsiPrintOptions() + + let res = + ilxGenerator.LookupGeneratedValue(valuePrinter.GetEvaluationContext emEnv, vref.Deref) + let rhsL = match res with - | None -> None - | Some (obj,objTy) -> - let lay = valuePrinter.PrintValue (FsiValuePrinterMode.PrintExpr, opts, obj, objTy) - if isEmptyL lay then None else Some lay // suppress empty layout - let denv = { denv with suppressMutableKeyword = true } // suppress 'mutable' in 'val mutable it = ...' - let denv = { denv with suppressInlineKeyword = false } // dont' suppress 'inline' in 'val inline f = ...' + | None -> None + | Some (obj, objTy) -> + let lay = valuePrinter.PrintValue(FsiValuePrinterMode.PrintExpr, opts, obj, objTy) + if isEmptyL lay then None else Some lay // suppress empty layout + + let denv = + { denv with + suppressMutableKeyword = true + } // suppress 'mutable' in 'val mutable it = ...' + + let denv = + { denv with + suppressInlineKeyword = false + } // dont' suppress 'inline' in 'val inline f = ...' + let fullL = if Option.isNone rhsL || isEmptyL rhsL.Value then - NicePrint.prettyLayoutOfValOrMemberNoInst denv infoReader vref (* the rhs was suppressed by the printer, so no value to print *) + NicePrint.prettyLayoutOfValOrMemberNoInst + denv + infoReader + vref (* the rhs was suppressed by the printer, so no value to print *) else - (NicePrint.prettyLayoutOfValOrMemberNoInst denv infoReader vref ++ wordL (TaggedText.tagText "=")) --- rhsL.Value + (NicePrint.prettyLayoutOfValOrMemberNoInst denv infoReader vref + ++ wordL (TaggedText.tagText "=")) + --- rhsL.Value colorPrintL outWriter opts fullL @@ -696,12 +787,10 @@ type internal FsiStdinSyphon(errorWriter: TextWriter) = let syphonText = StringBuilder() /// Clears the syphon text - member _.Reset () = - syphonText.Clear() |> ignore + member _.Reset() = syphonText.Clear() |> ignore /// Adds a new line to the syphon text - member _.Add (str:string) = - syphonText.Append str |> ignore + member _.Add(str: string) = syphonText.Append str |> ignore /// Gets the indicated line in the syphon text member _.GetLine fileName i = @@ -714,9 +803,10 @@ type internal FsiStdinSyphon(errorWriter: TextWriter) = // and second to get them back into stdin context (no position stack...). // To find an error line, trim upto the last stdinReset string the syphoned text. //printf "PrePrune:-->%s<--\n\n" text; - let rec prune (text:string) = + let rec prune (text: string) = let stdinReset = "# 1 \"stdin\"\n" - let idx = text.IndexOf(stdinReset,StringComparison.Ordinal) + let idx = text.IndexOf(stdinReset, StringComparison.Ordinal) + if idx <> -1 then prune (text.Substring(idx + stdinReset.Length)) else @@ -724,12 +814,13 @@ type internal FsiStdinSyphon(errorWriter: TextWriter) = let text = prune text let lines = text.Split '\n' - if 0 < i && i <= lines.Length then lines[i-1] else "" + if 0 < i && i <= lines.Length then lines[i - 1] else "" /// Display the given error. - member syphon.PrintDiagnostic (tcConfig:TcConfig, diagnostic: PhasedDiagnostic) = + member syphon.PrintDiagnostic(tcConfig: TcConfig, diagnostic: PhasedDiagnostic) = ignoreAllErrors (fun () -> let severity = FSharpDiagnosticSeverity.Error + DoWithDiagnosticColor severity (fun () -> errorWriter.WriteLine() diagnostic.WriteWithContext(errorWriter, " ", syphon.GetLine, tcConfig, severity) @@ -738,57 +829,80 @@ type internal FsiStdinSyphon(errorWriter: TextWriter) = errorWriter.Flush())) /// Encapsulates functions used to write to outWriter and errorWriter -type internal FsiConsoleOutput(tcConfigB, outWriter:TextWriter, errorWriter:TextWriter) = +type internal FsiConsoleOutput(tcConfigB, outWriter: TextWriter, errorWriter: TextWriter) = let nullOut = new StreamWriter(Stream.Null) :> TextWriter - let fprintfnn (os: TextWriter) fmt = Printf.kfprintf (fun _ -> os.WriteLine(); os.WriteLine()) os fmt + + let fprintfnn (os: TextWriter) fmt = + Printf.kfprintf + (fun _ -> + os.WriteLine() + os.WriteLine()) + os + fmt /// uprintf to write usual responses to stdout (suppressed by --quiet), with various pre/post newlines - member _.uprintf fmt = fprintf (if tcConfigB.noFeedback then nullOut else outWriter) fmt + member _.uprintf fmt = + fprintf (if tcConfigB.noFeedback then nullOut else outWriter) fmt - member _.uprintfn fmt = fprintfn (if tcConfigB.noFeedback then nullOut else outWriter) fmt + member _.uprintfn fmt = + fprintfn (if tcConfigB.noFeedback then nullOut else outWriter) fmt - member _.uprintfnn fmt = fprintfnn (if tcConfigB.noFeedback then nullOut else outWriter) fmt + member _.uprintfnn fmt = + fprintfnn (if tcConfigB.noFeedback then nullOut else outWriter) fmt - member out.uprintnf fmt = out.uprintfn ""; out.uprintf fmt + member out.uprintnf fmt = + out.uprintfn "" + out.uprintf fmt - member out.uprintnfn fmt = out.uprintfn ""; out.uprintfn fmt + member out.uprintnfn fmt = + out.uprintfn "" + out.uprintfn fmt + + member out.uprintnfnn fmt = + out.uprintfn "" + out.uprintfnn fmt - member out.uprintnfnn fmt = out.uprintfn ""; out.uprintfnn fmt - /// clear screen - member _.Clear () = System.Console.Clear() + member _.Clear() = System.Console.Clear() member _.Out = outWriter member _.Error = errorWriter /// This DiagnosticsLogger reports all warnings, but raises StopProcessing on first error or early exit -type internal DiagnosticsLoggerThatStopsOnFirstError(tcConfigB:TcConfigBuilder, fsiStdinSyphon:FsiStdinSyphon, fsiConsoleOutput: FsiConsoleOutput) = +type internal DiagnosticsLoggerThatStopsOnFirstError + ( + tcConfigB: TcConfigBuilder, + fsiStdinSyphon: FsiStdinSyphon, + fsiConsoleOutput: FsiConsoleOutput + ) = inherit DiagnosticsLogger("DiagnosticsLoggerThatStopsOnFirstError") let mutable errorCount = 0 - member _.SetError() = - errorCount <- 1 + member _.SetError() = errorCount <- 1 member _.ResetErrorCount() = errorCount <- 0 override _.DiagnosticSink(diagnostic, severity) = - let tcConfig = TcConfig.Create(tcConfigB,validate=false) - if diagnostic.ReportAsError (tcConfig.diagnosticsOptions, severity) then - fsiStdinSyphon.PrintDiagnostic(tcConfig,diagnostic) + let tcConfig = TcConfig.Create(tcConfigB, validate = false) + + if diagnostic.ReportAsError(tcConfig.diagnosticsOptions, severity) then + fsiStdinSyphon.PrintDiagnostic(tcConfig, diagnostic) errorCount <- errorCount + 1 - if tcConfigB.abortOnError then exit 1 (* non-zero exit code *) + + if tcConfigB.abortOnError then + exit 1 (* non-zero exit code *) // STOP ON FIRST ERROR (AVOIDS PARSER ERROR RECOVERY) raise StopProcessing - elif diagnostic.ReportAsWarning (tcConfig.diagnosticsOptions, severity) then + elif diagnostic.ReportAsWarning(tcConfig.diagnosticsOptions, severity) then DoWithDiagnosticColor FSharpDiagnosticSeverity.Warning (fun () -> fsiConsoleOutput.Error.WriteLine() diagnostic.WriteWithContext(fsiConsoleOutput.Error, " ", fsiStdinSyphon.GetLine, tcConfig, severity) fsiConsoleOutput.Error.WriteLine() fsiConsoleOutput.Error.WriteLine() fsiConsoleOutput.Error.Flush()) - elif diagnostic.ReportAsInfo (tcConfig.diagnosticsOptions, severity) then + elif diagnostic.ReportAsInfo(tcConfig.diagnosticsOptions, severity) then DoWithDiagnosticColor FSharpDiagnosticSeverity.Info (fun () -> fsiConsoleOutput.Error.WriteLine() diagnostic.WriteWithContext(fsiConsoleOutput.Error, " ", fsiStdinSyphon.GetLine, tcConfig, severity) @@ -801,55 +915,52 @@ type internal DiagnosticsLoggerThatStopsOnFirstError(tcConfigB:TcConfigBuilder, type DiagnosticsLogger with /// A helper function to check if its time to abort - member x.AbortOnError(fsiConsoleOutput:FsiConsoleOutput) = + member x.AbortOnError(fsiConsoleOutput: FsiConsoleOutput) = if x.ErrorCount > 0 then - fprintf fsiConsoleOutput.Error "%s" (FSIstrings.SR.stoppedDueToError()) + fprintf fsiConsoleOutput.Error "%s" (FSIstrings.SR.stoppedDueToError ()) fsiConsoleOutput.Error.Flush() raise StopProcessing /// Get the directory name from a string, with some defaults if it doesn't have one -let internal directoryName (s:string) = - if s = "" then "." +let internal directoryName (s: string) = + if s = "" then + "." else match Path.GetDirectoryName s with | null -> if FileSystem.IsPathRootedShim s then s else "." | res -> if res = "" then "." else res - //---------------------------------------------------------------------------- // cmd line - state for options //---------------------------------------------------------------------------- /// Process the command line options -type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, - argv: string[], - tcConfigB, - fsiConsoleOutput: FsiConsoleOutput) = +type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, argv: string[], tcConfigB, fsiConsoleOutput: FsiConsoleOutput) = let mutable enableConsoleKeyProcessing = true - let mutable gui = true // override via "--gui" on by default + let mutable gui = true // override via "--gui" on by default #if DEBUG let mutable showILCode = false // show modul il code #endif - let mutable showTypes = true // show types after each interaction? + let mutable showTypes = true // show types after each interaction? let mutable fsiServerName = "" let mutable interact = true let mutable explicitArgs = [] let mutable writeReferencesAndExit = None - let mutable inputFilesAcc = [] + let mutable inputFilesAcc = [] let mutable fsiServerInputCodePage = None let mutable fsiServerOutputCodePage = None let mutable fsiLCID = None // internal options - let mutable probeToSeeIfConsoleWorks = true + let mutable probeToSeeIfConsoleWorks = true let mutable peekAheadOnConsoleToPermitTyping = true - let isInteractiveServer() = fsiServerName <> "" - let recordExplicitArg arg = explicitArgs <- explicitArgs @ [arg] + let isInteractiveServer () = fsiServerName <> "" + let recordExplicitArg arg = explicitArgs <- explicitArgs @ [ arg ] let executableFileNameWithoutExtension = lazy @@ -860,8 +971,10 @@ type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, let processFileName = fileNameWithoutExtension currentProcess.MainModule.FileName let commandLineExecutableFileName = - try fileNameWithoutExtension (Environment.GetCommandLineArgs().[0]) - with _ -> "" + try + fileNameWithoutExtension (Environment.GetCommandLineArgs().[0]) + with _ -> + "" let stringComparison = match Environment.OSVersion.Platform with @@ -869,94 +982,184 @@ type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, | PlatformID.Unix -> StringComparison.Ordinal | _ -> StringComparison.OrdinalIgnoreCase - if String.Compare(processFileName, commandLineExecutableFileName, stringComparison) = 0 - then processFileName - else sprintf "%s %s" processFileName commandLineExecutableFileName + if String.Compare(processFileName, commandLineExecutableFileName, stringComparison) = 0 then + processFileName + else + sprintf "%s %s" processFileName commandLineExecutableFileName tcConfigB.exename |> Option.defaultWith getFsiCommandLine - // Additional fsi options are list below. // In the "--help", these options can be printed either before (fsiUsagePrefix) or after (fsiUsageSuffix) the core options. - let displayHelpFsi tcConfigB (blocks:CompilerOptionBlock list) = - Console.Write (GetBannerText tcConfigB) + let displayHelpFsi tcConfigB (blocks: CompilerOptionBlock list) = + Console.Write(GetBannerText tcConfigB) fprintfn fsiConsoleOutput.Out "" - fprintfn fsiConsoleOutput.Out "%s" (FSIstrings.SR.fsiUsage(executableFileNameWithoutExtension.Value)) - Console.Write (GetCompilerOptionBlocks blocks tcConfigB.bufferWidth) + fprintfn fsiConsoleOutput.Out "%s" (FSIstrings.SR.fsiUsage (executableFileNameWithoutExtension.Value)) + Console.Write(GetCompilerOptionBlocks blocks tcConfigB.bufferWidth) exit 0 // option tags - let tagFile = "" - let tagNone = "" + let tagFile = "" + let tagNone = "" /// These options precede the FsiCoreCompilerOptions in the help blocks let fsiUsagePrefix tcConfigB = - [PublicOptions(FSIstrings.SR.fsiInputFiles(), - [CompilerOption("use",tagFile, OptionString (fun s -> inputFilesAcc <- inputFilesAcc @ [(s,true)]), None, - Some (FSIstrings.SR.fsiUse())); - CompilerOption("load",tagFile, OptionString (fun s -> inputFilesAcc <- inputFilesAcc @ [(s,false)]), None, - Some (FSIstrings.SR.fsiLoad())); - ]); - PublicOptions(FSIstrings.SR.fsiCodeGeneration(),[]); - PublicOptions(FSIstrings.SR.fsiErrorsAndWarnings(),[]); - PublicOptions(FSIstrings.SR.fsiLanguage(),[]); - PublicOptions(FSIstrings.SR.fsiMiscellaneous(),[]); - PublicOptions(FSIstrings.SR.fsiAdvanced(),[]); - PrivateOptions( - [// Make internal fsi-server* options. Do not print in the help. They are used by VFSI. - CompilerOption("fsi-server-report-references","", OptionString (fun s -> writeReferencesAndExit <- Some s), None, None); - CompilerOption("fsi-server","", OptionString (fun s -> fsiServerName <- s), None, None); // "FSI server mode on given named channel"); - CompilerOption("fsi-server-input-codepage","",OptionInt (fun n -> fsiServerInputCodePage <- Some(n)), None, None); // " Set the input codepage for the console"); - CompilerOption("fsi-server-output-codepage","",OptionInt (fun n -> fsiServerOutputCodePage <- Some(n)), None, None); // " Set the output codepage for the console"); - CompilerOption("fsi-server-no-unicode","", OptionUnit (fun () -> fsiServerOutputCodePage <- None; fsiServerInputCodePage <- None), None, None); // "Do not set the codepages for the console"); - CompilerOption("fsi-server-lcid","", OptionInt (fun n -> fsiLCID <- Some(n)), None, None); // "LCID from Visual Studio" - - // We do not want to print the "script.fsx arg2..." as part of the options - CompilerOption("script.fsx arg1 arg2 ...","", - OptionGeneral((fun args -> args.Length > 0 && IsScript args[0]), - (fun args -> let scriptFile = args[0] - let scriptArgs = List.tail args - inputFilesAcc <- inputFilesAcc @ [(scriptFile,true)] (* record script.fsx for evaluation *) - List.iter recordExplicitArg scriptArgs (* record rest of line as explicit arguments *) - tcConfigB.noFeedback <- true (* "quiet", no banners responses etc *) - interact <- false (* --exec, exit after eval *) - [] (* no arguments passed on, all consumed here *) - - )),None,None); // "Run script.fsx with the follow command line arguments: arg1 arg2 ..."); - ]); - PrivateOptions( [ - // Private options, related to diagnostics around console probing - CompilerOption("probeconsole","", OptionSwitch (fun flag -> probeToSeeIfConsoleWorks <- flag=OptionSwitch.On), None, None); // "Probe to see if Console looks functional"); - - CompilerOption("peekahead","", OptionSwitch (fun flag -> peekAheadOnConsoleToPermitTyping <- flag=OptionSwitch.On), None, None); // "Probe to see if Console looks functional"); - - // Disables interaction (to be used by libraries embedding FSI only!) - CompilerOption("noninteractive","", OptionUnit (fun () -> interact <- false), None, None); // "Deprecated, use --exec instead" + PublicOptions( + FSIstrings.SR.fsiInputFiles (), + [ + CompilerOption( + "use", + tagFile, + OptionString(fun s -> inputFilesAcc <- inputFilesAcc @ [ (s, true) ]), + None, + Some(FSIstrings.SR.fsiUse ()) + ) + CompilerOption( + "load", + tagFile, + OptionString(fun s -> inputFilesAcc <- inputFilesAcc @ [ (s, false) ]), + None, + Some(FSIstrings.SR.fsiLoad ()) + ) + ] + ) + PublicOptions(FSIstrings.SR.fsiCodeGeneration (), []) + PublicOptions(FSIstrings.SR.fsiErrorsAndWarnings (), []) + PublicOptions(FSIstrings.SR.fsiLanguage (), []) + PublicOptions(FSIstrings.SR.fsiMiscellaneous (), []) + PublicOptions(FSIstrings.SR.fsiAdvanced (), []) + PrivateOptions( + [ // Make internal fsi-server* options. Do not print in the help. They are used by VFSI. + CompilerOption("fsi-server-report-references", "", OptionString(fun s -> writeReferencesAndExit <- Some s), None, None) + CompilerOption("fsi-server", "", OptionString(fun s -> fsiServerName <- s), None, None) // "FSI server mode on given named channel"); + CompilerOption("fsi-server-input-codepage", "", OptionInt(fun n -> fsiServerInputCodePage <- Some(n)), None, None) // " Set the input codepage for the console"); + CompilerOption("fsi-server-output-codepage", "", OptionInt(fun n -> fsiServerOutputCodePage <- Some(n)), None, None) // " Set the output codepage for the console"); + CompilerOption( + "fsi-server-no-unicode", + "", + OptionUnit(fun () -> + fsiServerOutputCodePage <- None + fsiServerInputCodePage <- None), + None, + None + ) // "Do not set the codepages for the console"); + CompilerOption("fsi-server-lcid", "", OptionInt(fun n -> fsiLCID <- Some(n)), None, None) // "LCID from Visual Studio" + + // We do not want to print the "script.fsx arg2..." as part of the options + CompilerOption( + "script.fsx arg1 arg2 ...", + "", + OptionGeneral( + (fun args -> args.Length > 0 && IsScript args[0]), + (fun args -> + let scriptFile = args[0] + let scriptArgs = List.tail args + inputFilesAcc <- inputFilesAcc @ [ (scriptFile, true) ] (* record script.fsx for evaluation *) + List.iter recordExplicitArg scriptArgs (* record rest of line as explicit arguments *) + tcConfigB.noFeedback <- true (* "quiet", no banners responses etc *) + interact <- false (* --exec, exit after eval *) + [] (* no arguments passed on, all consumed here *) + + ) + ), + None, + None + ) // "Run script.fsx with the follow command line arguments: arg1 arg2 ..."); + ] + ) + PrivateOptions( + [ + // Private options, related to diagnostics around console probing + CompilerOption( + "probeconsole", + "", + OptionSwitch(fun flag -> probeToSeeIfConsoleWorks <- flag = OptionSwitch.On), + None, + None + ) // "Probe to see if Console looks functional"); + + CompilerOption( + "peekahead", + "", + OptionSwitch(fun flag -> peekAheadOnConsoleToPermitTyping <- flag = OptionSwitch.On), + None, + None + ) // "Probe to see if Console looks functional"); + + // Disables interaction (to be used by libraries embedding FSI only!) + CompilerOption("noninteractive", "", OptionUnit(fun () -> interact <- false), None, None) // "Deprecated, use --exec instead" - ]) - ] + ] + ) + ] /// These options follow the FsiCoreCompilerOptions in the help blocks - let fsiUsageSuffix tcConfigB = [ - PublicOptions(FSComp.SR.optsHelpBannerInputFiles(), [CompilerOption("--","", OptionRest recordExplicitArg, None, Some (FSIstrings.SR.fsiRemaining())); ]); - PublicOptions(FSComp.SR.optsHelpBannerMisc(), [ CompilerOption("help", tagNone, OptionConsoleOnly (displayHelpFsi tcConfigB), None, Some (FSIstrings.SR.fsiHelp())) ]); - PrivateOptions([ - CompilerOption("?", tagNone, OptionConsoleOnly (displayHelpFsi tcConfigB), None, None); // "Short form of --help"); - CompilerOption("help", tagNone, OptionConsoleOnly (displayHelpFsi tcConfigB), None, None); // "Short form of --help"); - CompilerOption("full-help", tagNone, OptionConsoleOnly (displayHelpFsi tcConfigB), None, None); // "Short form of --help"); - ]); - PublicOptions(FSComp.SR.optsHelpBannerAdvanced(), [ - CompilerOption("exec", "", OptionUnit (fun () -> interact <- false), None, Some (FSIstrings.SR.fsiExec())) - CompilerOption("gui", tagNone, OptionSwitch(fun flag -> gui <- (flag = OptionSwitch.On)),None,Some (FSIstrings.SR.fsiGui())) - CompilerOption("quiet", "", OptionUnit (fun () -> tcConfigB.noFeedback <- true), None,Some (FSIstrings.SR.fsiQuiet())); - CompilerOption("readline", tagNone, OptionSwitch(fun flag -> enableConsoleKeyProcessing <- (flag = OptionSwitch.On)), None, Some(FSIstrings.SR.fsiReadline())) - CompilerOption("quotations-debug", tagNone, OptionSwitch(fun switch -> tcConfigB.emitDebugInfoInQuotations <- switch = OptionSwitch.On),None, Some(FSIstrings.SR.fsiEmitDebugInfoInQuotations())) - CompilerOption("shadowcopyreferences", tagNone, OptionSwitch(fun flag -> tcConfigB.shadowCopyReferences <- flag = OptionSwitch.On), None, Some(FSIstrings.SR.shadowCopyReferences())) - CompilerOption("multiemit", tagNone, OptionSwitch(fun flag -> tcConfigB.fsiMultiAssemblyEmit <- flag = OptionSwitch.On), None, Some(FSIstrings.SR.fsiMultiAssemblyEmitOption())) - ]); - ] + let fsiUsageSuffix tcConfigB = + [ + PublicOptions( + FSComp.SR.optsHelpBannerInputFiles (), + [ + CompilerOption("--", "", OptionRest recordExplicitArg, None, Some(FSIstrings.SR.fsiRemaining ())) + ] + ) + PublicOptions( + FSComp.SR.optsHelpBannerMisc (), + [ + CompilerOption("help", tagNone, OptionConsoleOnly(displayHelpFsi tcConfigB), None, Some(FSIstrings.SR.fsiHelp ())) + ] + ) + PrivateOptions( + [ + CompilerOption("?", tagNone, OptionConsoleOnly(displayHelpFsi tcConfigB), None, None) // "Short form of --help"); + CompilerOption("help", tagNone, OptionConsoleOnly(displayHelpFsi tcConfigB), None, None) // "Short form of --help"); + CompilerOption("full-help", tagNone, OptionConsoleOnly(displayHelpFsi tcConfigB), None, None) // "Short form of --help"); + ] + ) + PublicOptions( + FSComp.SR.optsHelpBannerAdvanced (), + [ + CompilerOption("exec", "", OptionUnit(fun () -> interact <- false), None, Some(FSIstrings.SR.fsiExec ())) + CompilerOption( + "gui", + tagNone, + OptionSwitch(fun flag -> gui <- (flag = OptionSwitch.On)), + None, + Some(FSIstrings.SR.fsiGui ()) + ) + CompilerOption("quiet", "", OptionUnit(fun () -> tcConfigB.noFeedback <- true), None, Some(FSIstrings.SR.fsiQuiet ())) + CompilerOption( + "readline", + tagNone, + OptionSwitch(fun flag -> enableConsoleKeyProcessing <- (flag = OptionSwitch.On)), + None, + Some(FSIstrings.SR.fsiReadline ()) + ) + CompilerOption( + "quotations-debug", + tagNone, + OptionSwitch(fun switch -> tcConfigB.emitDebugInfoInQuotations <- switch = OptionSwitch.On), + None, + Some(FSIstrings.SR.fsiEmitDebugInfoInQuotations ()) + ) + CompilerOption( + "shadowcopyreferences", + tagNone, + OptionSwitch(fun flag -> tcConfigB.shadowCopyReferences <- flag = OptionSwitch.On), + None, + Some(FSIstrings.SR.shadowCopyReferences ()) + ) + CompilerOption( + "multiemit", + tagNone, + OptionSwitch(fun flag -> tcConfigB.fsiMultiAssemblyEmit <- flag = OptionSwitch.On), + None, + Some(FSIstrings.SR.fsiMultiAssemblyEmitOption ()) + ) + ] + ) + ] /// Process command line, flags and collect filenames. /// The ParseCompilerOptions function calls imperative function to process "real" args @@ -964,74 +1167,96 @@ type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, let sourceFiles = let collect name = let fsx = IsScript name - inputFilesAcc <- inputFilesAcc @ [(name,fsx)] // O(n^2), but n small... + inputFilesAcc <- inputFilesAcc @ [ (name, fsx) ] // O(n^2), but n small... + try - let fsiCompilerOptions = fsiUsagePrefix tcConfigB @ GetCoreFsiCompilerOptions tcConfigB @ fsiUsageSuffix tcConfigB - let abbrevArgs = GetAbbrevFlagSet tcConfigB false - ParseCompilerOptions (collect, fsiCompilerOptions, List.tail (PostProcessCompilerArgs abbrevArgs argv)) + let fsiCompilerOptions = + fsiUsagePrefix tcConfigB + @ GetCoreFsiCompilerOptions tcConfigB @ fsiUsageSuffix tcConfigB + + let abbrevArgs = GetAbbrevFlagSet tcConfigB false + ParseCompilerOptions(collect, fsiCompilerOptions, List.tail (PostProcessCompilerArgs abbrevArgs argv)) with e -> - stopProcessingRecovery e range0; failwithf "Error creating evaluation session: %A" e + stopProcessingRecovery e range0 + failwithf "Error creating evaluation session: %A" e + inputFilesAcc // We need a dependency provider with native resolution. Managed resolution is handled by generated `#r` - let dependencyProvider = new DependencyProvider(NativeResolutionProbe(tcConfigB.GetNativeProbingRoots)) + let dependencyProvider = + new DependencyProvider(NativeResolutionProbe(tcConfigB.GetNativeProbingRoots)) do if tcConfigB.clearResultsCache then dependencyProvider.ClearResultsCache(tcConfigB.compilerToolPaths, getOutputDir tcConfigB, reportError rangeCmdArgs) + if tcConfigB.utf8output then let prev = Console.OutputEncoding Console.OutputEncoding <- Encoding.UTF8 System.AppDomain.CurrentDomain.ProcessExit.Add(fun _ -> Console.OutputEncoding <- prev) + do let firstArg = match sourceFiles with | [] -> argv[0] - | _ -> fst (List.head (List.rev sourceFiles) ) + | _ -> fst (List.head (List.rev sourceFiles)) + let args = Array.ofList (firstArg :: explicitArgs) fsi.ReportUserCommandLineArgs args - //---------------------------------------------------------------------------- // Banner //---------------------------------------------------------------------------- member _.ShowBanner() = fsiConsoleOutput.uprintnfn "%s" tcConfigB.productNameForBannerText - fsiConsoleOutput.uprintfnn "%s" (FSComp.SR.optsCopyright()) - fsiConsoleOutput.uprintfn "%s" (FSIstrings.SR.fsiBanner3()) + fsiConsoleOutput.uprintfnn "%s" (FSComp.SR.optsCopyright ()) + fsiConsoleOutput.uprintfn "%s" (FSIstrings.SR.fsiBanner3 ()) member _.ShowHelp(m) = let helpLine = sprintf "%s --help" executableFileNameWithoutExtension.Value - fsiConsoleOutput.uprintfn "" - fsiConsoleOutput.uprintfnn "%s" (FSIstrings.SR.fsiIntroTextHeader1directives()) - fsiConsoleOutput.uprintfn """ #r "file.dll";; // %s""" (FSIstrings.SR.fsiIntroTextHashrInfo()) - fsiConsoleOutput.uprintfn """ #i "package source uri";; // %s""" (FSIstrings.SR.fsiIntroPackageSourceUriInfo()) - fsiConsoleOutput.uprintfn """ #I "path";; // %s""" (FSIstrings.SR.fsiIntroTextHashIInfo()) - fsiConsoleOutput.uprintfn """ #load "file.fs" ...;; // %s""" (FSIstrings.SR.fsiIntroTextHashloadInfo()) - fsiConsoleOutput.uprintfn """ #time ["on"|"off"];; // %s""" (FSIstrings.SR.fsiIntroTextHashtimeInfo()) - fsiConsoleOutput.uprintfn """ #help;; // %s""" (FSIstrings.SR.fsiIntroTextHashhelpInfo()) + fsiConsoleOutput.uprintfn "" + fsiConsoleOutput.uprintfnn "%s" (FSIstrings.SR.fsiIntroTextHeader1directives ()) + fsiConsoleOutput.uprintfn """ #r "file.dll";; // %s""" (FSIstrings.SR.fsiIntroTextHashrInfo ()) + + fsiConsoleOutput.uprintfn + """ #i "package source uri";; // %s""" + (FSIstrings.SR.fsiIntroPackageSourceUriInfo ()) + + fsiConsoleOutput.uprintfn """ #I "path";; // %s""" (FSIstrings.SR.fsiIntroTextHashIInfo ()) + fsiConsoleOutput.uprintfn """ #load "file.fs" ...;; // %s""" (FSIstrings.SR.fsiIntroTextHashloadInfo ()) + fsiConsoleOutput.uprintfn """ #time ["on"|"off"];; // %s""" (FSIstrings.SR.fsiIntroTextHashtimeInfo ()) + fsiConsoleOutput.uprintfn """ #help;; // %s""" (FSIstrings.SR.fsiIntroTextHashhelpInfo ()) if tcConfigB.langVersion.SupportsFeature(LanguageFeature.PackageManagement) then - for msg in dependencyProvider.GetRegisteredDependencyManagerHelpText(tcConfigB.compilerToolPaths, getOutputDir tcConfigB, reportError m) do + for msg in + dependencyProvider.GetRegisteredDependencyManagerHelpText( + tcConfigB.compilerToolPaths, + getOutputDir tcConfigB, + reportError m + ) do fsiConsoleOutput.uprintfn "%s" msg - fsiConsoleOutput.uprintfn """ #clear;; // %s""" (FSIstrings.SR.fsiIntroTextHashclearInfo()) - fsiConsoleOutput.uprintfn """ #quit;; // %s""" (FSIstrings.SR.fsiIntroTextHashquitInfo()) - fsiConsoleOutput.uprintfn ""; - fsiConsoleOutput.uprintfnn "%s" (FSIstrings.SR.fsiIntroTextHeader2commandLine()) - fsiConsoleOutput.uprintfn "%s" (FSIstrings.SR.fsiIntroTextHeader3(helpLine)) - fsiConsoleOutput.uprintfn "" - fsiConsoleOutput.uprintfn "" + fsiConsoleOutput.uprintfn """ #clear;; // %s""" (FSIstrings.SR.fsiIntroTextHashclearInfo ()) + fsiConsoleOutput.uprintfn """ #quit;; // %s""" (FSIstrings.SR.fsiIntroTextHashquitInfo ()) + fsiConsoleOutput.uprintfn "" + fsiConsoleOutput.uprintfnn "%s" (FSIstrings.SR.fsiIntroTextHeader2commandLine ()) + fsiConsoleOutput.uprintfn "%s" (FSIstrings.SR.fsiIntroTextHeader3 (helpLine)) + fsiConsoleOutput.uprintfn "" + fsiConsoleOutput.uprintfn "" member _.ClearScreen() = fsiConsoleOutput.Clear() #if DEBUG - member _.ShowILCode with get() = showILCode and set v = showILCode <- v + member _.ShowILCode + with get () = showILCode + and set v = showILCode <- v #endif - member _.ShowTypes with get() = showTypes and set v = showTypes <- v + member _.ShowTypes + with get () = showTypes + and set v = showTypes <- v member _.FsiServerName = fsiServerName @@ -1039,11 +1264,13 @@ type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, member _.FsiServerOutputCodePage = fsiServerOutputCodePage - member _.FsiLCID with get() = fsiLCID and set v = fsiLCID <- v + member _.FsiLCID + with get () = fsiLCID + and set v = fsiLCID <- v - member _.UseServerPrompt = isInteractiveServer() + member _.UseServerPrompt = isInteractiveServer () - member _.IsInteractiveServer = isInteractiveServer() + member _.IsInteractiveServer = isInteractiveServer () member _.ProbeToSeeIfConsoleWorks = probeToSeeIfConsoleWorks @@ -1064,50 +1291,68 @@ type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, member _.FxResolver = tcConfigB.FxResolver /// Set the current ui culture for the current thread. -let internal SetCurrentUICultureForThread (lcid : int option) = +let internal SetCurrentUICultureForThread (lcid: int option) = let culture = Thread.CurrentThread.CurrentUICulture + match lcid with | Some n -> Thread.CurrentThread.CurrentUICulture <- CultureInfo(n) | None -> () - { new IDisposable with member _.Dispose() = Thread.CurrentThread.CurrentUICulture <- culture } + + { new IDisposable with + member _.Dispose() = + Thread.CurrentThread.CurrentUICulture <- culture + } //---------------------------------------------------------------------------- // Reporting - warnings, errors //---------------------------------------------------------------------------- let internal InstallErrorLoggingOnThisThread diagnosticsLogger = - if progress then dprintfn "Installing logger on id=%d name=%s" Thread.CurrentThread.ManagedThreadId Thread.CurrentThread.Name + if progress then + dprintfn "Installing logger on id=%d name=%s" Thread.CurrentThread.ManagedThreadId Thread.CurrentThread.Name + SetThreadDiagnosticsLoggerNoUnwind(diagnosticsLogger) SetThreadBuildPhaseNoUnwind(BuildPhase.Interactive) /// Set the input/output encoding. The use of a thread is due to a known bug on /// on Vista where calls to Console.InputEncoding can block the process. -let internal SetServerCodePages(fsiOptions: FsiCommandLineOptions) = +let internal SetServerCodePages (fsiOptions: FsiCommandLineOptions) = match fsiOptions.FsiServerInputCodePage, fsiOptions.FsiServerOutputCodePage with - | None,None -> () - | inputCodePageOpt,outputCodePageOpt -> + | None, None -> () + | inputCodePageOpt, outputCodePageOpt -> let mutable successful = false - Async.Start (async { do match inputCodePageOpt with - | None -> () - | Some(n:int) -> - let encoding = Encoding.GetEncoding(n) - // Note this modifies the real honest-to-goodness settings for the current shell. - // and the modifications hang around even after the process has exited. - Console.InputEncoding <- encoding - do match outputCodePageOpt with - | None -> () - | Some(n:int) -> - let encoding = Encoding.GetEncoding n - // Note this modifies the real honest-to-goodness settings for the current shell. - // and the modifications hang around even after the process has exited. - Console.OutputEncoding <- encoding - do successful <- true }); - for pause in [10;50;100;1000;2000;10000] do + + Async.Start( + async { + do + match inputCodePageOpt with + | None -> () + | Some (n: int) -> + let encoding = Encoding.GetEncoding(n) + // Note this modifies the real honest-to-goodness settings for the current shell. + // and the modifications hang around even after the process has exited. + Console.InputEncoding <- encoding + + do + match outputCodePageOpt with + | None -> () + | Some (n: int) -> + let encoding = Encoding.GetEncoding n + // Note this modifies the real honest-to-goodness settings for the current shell. + // and the modifications hang around even after the process has exited. + Console.OutputEncoding <- encoding + + do successful <- true + } + ) + + for pause in [ 10; 50; 100; 1000; 2000; 10000 ] do if not successful then - Thread.Sleep(pause); + Thread.Sleep(pause) #if LOGGING_GUI if not !successful then - System.Windows.Forms.MessageBox.Show(FSIstrings.SR.fsiConsoleProblem()) |> ignore + System.Windows.Forms.MessageBox.Show(FSIstrings.SR.fsiConsoleProblem ()) + |> ignore #endif //---------------------------------------------------------------------------- @@ -1157,7 +1402,13 @@ type internal FsiConsolePrompt(fsiOptions: FsiCommandLineOptions, fsiConsoleOutp //---------------------------------------------------------------------------- // Startup processing //---------------------------------------------------------------------------- -type internal FsiConsoleInput(fsi: FsiEvaluationSessionHostConfig, fsiOptions: FsiCommandLineOptions, inReader: TextReader, outWriter: TextWriter) = +type internal FsiConsoleInput + ( + fsi: FsiEvaluationSessionHostConfig, + fsiOptions: FsiCommandLineOptions, + inReader: TextReader, + outWriter: TextWriter + ) = let consoleOpt = // The "console.fs" code does a limited form of "TAB-completion". @@ -1168,7 +1419,9 @@ type internal FsiConsoleInput(fsi: FsiEvaluationSessionHostConfig, fsiOptions: F None // When VFSI is running, there should be no "console", and in particular the console.fs readline code should not to run. - do if fsiOptions.IsInteractiveServer then assert consoleOpt.IsNone + do + if fsiOptions.IsInteractiveServer then + assert consoleOpt.IsNone /// This threading event gets set after the first-line-reader has finished its work let consoleReaderStartupDone = new ManualResetEvent(false) @@ -1177,35 +1430,48 @@ type internal FsiConsoleInput(fsi: FsiEvaluationSessionHostConfig, fsiOptions: F let mutable firstLine = None // Peek on the standard input so that the user can type into it from a console window. - do if fsiOptions.Interact then - if fsiOptions.PeekAheadOnConsoleToPermitTyping then - (Thread(fun () -> - match consoleOpt with - | Some console when fsiOptions.EnableConsoleKeyProcessing && not fsiOptions.UseServerPrompt -> - if List.isEmpty fsiOptions.SourceFiles then - if progress then fprintfn outWriter "first-line-reader-thread reading first line..."; - firstLine <- Some(console()); - if progress then fprintfn outWriter "first-line-reader-thread got first line = %A..." firstLine; - consoleReaderStartupDone.Set() |> ignore - if progress then fprintfn outWriter "first-line-reader-thread has set signal and exited." ; - | _ -> - ignore(inReader.Peek()); - consoleReaderStartupDone.Set() |> ignore - )).Start() - else - if progress then fprintfn outWriter "first-line-reader-thread not in use." - consoleReaderStartupDone.Set() |> ignore + do + if fsiOptions.Interact then + if fsiOptions.PeekAheadOnConsoleToPermitTyping then + (Thread(fun () -> + match consoleOpt with + | Some console when fsiOptions.EnableConsoleKeyProcessing && not fsiOptions.UseServerPrompt -> + if List.isEmpty fsiOptions.SourceFiles then + if progress then + fprintfn outWriter "first-line-reader-thread reading first line..." + + firstLine <- Some(console ()) + + if progress then + fprintfn outWriter "first-line-reader-thread got first line = %A..." firstLine + + consoleReaderStartupDone.Set() |> ignore + + if progress then + fprintfn outWriter "first-line-reader-thread has set signal and exited." + | _ -> + ignore (inReader.Peek()) + consoleReaderStartupDone.Set() |> ignore)) + .Start() + else + if progress then + fprintfn outWriter "first-line-reader-thread not in use." + + consoleReaderStartupDone.Set() |> ignore /// Try to get the first line, if we snarfed it while probing. - member _.TryGetFirstLine() = let r = firstLine in firstLine <- None; r + member _.TryGetFirstLine() = + let r = firstLine in + firstLine <- None + r /// Try to get the console, if it appears operational. member _.TryGetConsole() = consoleOpt member _.In = inReader - member _.WaitForInitialConsoleInput() = WaitHandle.WaitAll [| consoleReaderStartupDone |] |> ignore; - + member _.WaitForInitialConsoleInput() = + WaitHandle.WaitAll [| consoleReaderStartupDone |] |> ignore //---------------------------------------------------------------------------- // FsiDynamicCompilerState @@ -1221,22 +1487,27 @@ type FsiInteractionStepStatus = [] [] type FsiDynamicCompilerState = - { optEnv: Optimizer.IncrementalOptimizationEnv - emEnv: ILAssemblyEmitEnv - tcGlobals: TcGlobals - tcState: TcState - tcImports: TcImports - ilxGenerator: IlxAssemblyGenerator - boundValues: NameMap - // Why is this not in FsiOptions? - timing: bool - debugBreak: bool } + { + optEnv: Optimizer.IncrementalOptimizationEnv + emEnv: ILAssemblyEmitEnv + tcGlobals: TcGlobals + tcState: TcState + tcImports: TcImports + ilxGenerator: IlxAssemblyGenerator + boundValues: NameMap + // Why is this not in FsiOptions? + timing: bool + debugBreak: bool + } let WithImplicitHome (tcConfigB, dir) f = let old = tcConfigB.implicitIncludeDir - tcConfigB.implicitIncludeDir <- dir; - try f() - finally tcConfigB.implicitIncludeDir <- old + tcConfigB.implicitIncludeDir <- dir + + try + f () + finally + tcConfigB.implicitIncludeDir <- old let ConvReflectionTypeToILTypeRef (reflectionTy: Type) = if reflectionTy.Assembly.IsDynamic then @@ -1250,6 +1521,7 @@ let ConvReflectionTypeToILTypeRef (reflectionTy: Type) = let fullName = reflectionTy.FullName let index = fullName.IndexOf("[") + let fullName = if index = -1 then fullName @@ -1257,25 +1529,40 @@ let ConvReflectionTypeToILTypeRef (reflectionTy: Type) = fullName.Substring(0, index) let isTop = reflectionTy.DeclaringType = null + if isTop then ILTypeRef.Create(scoref, [], fullName) else - let names = String.split StringSplitOptions.None [|"+";"."|] fullName - let enc = names[..names.Length - 2] + let names = String.split StringSplitOptions.None [| "+"; "." |] fullName + let enc = names[.. names.Length - 2] let nm = names[names.Length - 1] ILTypeRef.Create(scoref, List.ofArray enc, nm) let rec ConvReflectionTypeToILType (reflectionTy: Type) = - let arrayRank = if reflectionTy.IsArray then reflectionTy.GetArrayRank() else 0 + let arrayRank = + if reflectionTy.IsArray then + reflectionTy.GetArrayRank() + else + 0 + let reflectionTy = // Special case functions. if FSharp.Reflection.FSharpType.IsFunction reflectionTy then - let ctors = reflectionTy.GetConstructors(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance) - if ctors.Length = 1 && - ctors[0].GetCustomAttribute() <> null && - not ctors[0].IsPublic && - IsCompilerGeneratedName reflectionTy.Name then - let rec get (typ: Type) = if FSharp.Reflection.FSharpType.IsFunction typ.BaseType then get typ.BaseType else typ + let ctors = + reflectionTy.GetConstructors(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance) + + if + ctors.Length = 1 + && ctors[ 0 ].GetCustomAttribute() <> null + && not ctors[0].IsPublic + && IsCompilerGeneratedName reflectionTy.Name + then + let rec get (typ: Type) = + if FSharp.Reflection.FSharpType.IsFunction typ.BaseType then + get typ.BaseType + else + typ + get reflectionTy else reflectionTy @@ -1283,7 +1570,10 @@ let rec ConvReflectionTypeToILType (reflectionTy: Type) = reflectionTy let elementOrItemTref = - if reflectionTy.HasElementType then reflectionTy.GetElementType() else reflectionTy + if reflectionTy.HasElementType then + reflectionTy.GetElementType() + else + reflectionTy |> ConvReflectionTypeToILTypeRef let genericArgs = @@ -1301,34 +1591,60 @@ let rec ConvReflectionTypeToILType (reflectionTy: Type) = let tspec = ILTypeSpec.Create(elementOrItemTref, genericArgs) let ilType = mkILTy boxity tspec + if arrayRank = 0 then - [ilType] + [ ilType ] else let arrayShape = ILArrayShape.FromRank arrayRank let arrayIlType = mkILArrTy (ilType, arrayShape) - [arrayIlType; ilType] + [ arrayIlType; ilType ] let internal mkBoundValueTypedImpl tcGlobals m moduleName name ty = let vis = Accessibility.TAccess([]) let compPath = (CompilationPath.CompPath(ILScopeRef.Local, [])) let mutable mty = Unchecked.defaultof<_> - let entity = Construct.NewModuleOrNamespace (Some compPath) vis (Ident(moduleName, m)) XmlDoc.Empty [] (MaybeLazy.Lazy(lazy mty)) + + let entity = + Construct.NewModuleOrNamespace (Some compPath) vis (Ident(moduleName, m)) XmlDoc.Empty [] (MaybeLazy.Lazy(lazy mty)) + let v = - Construct.NewVal - (name, m, None, ty, ValMutability.Immutable, - false, Some(ValReprInfo([], [], { Attribs = []; Name = None })), vis, ValNotInRecScope, None, NormalVal, [], ValInline.Optional, - XmlDoc.Empty, true, false, false, false, - false, false, None, Parent(TypedTreeBasics.ERefLocal entity)) + Construct.NewVal( + name, + m, + None, + ty, + ValMutability.Immutable, + false, + Some(ValReprInfo([], [], { Attribs = []; Name = None })), + vis, + ValNotInRecScope, + None, + NormalVal, + [], + ValInline.Optional, + XmlDoc.Empty, + true, + false, + false, + false, + false, + false, + None, + Parent(TypedTreeBasics.ERefLocal entity) + ) + mty <- ModuleOrNamespaceType(ModuleOrNamespaceKind.ModuleOrType, QueueList.one v, QueueList.empty) let bindExpr = mkCallDefaultOf tcGlobals range0 ty let binding = Binding.TBind(v, bindExpr, DebugPointAtBinding.NoneAtLet) - let mbinding = ModuleOrNamespaceBinding.Module(entity, TMDefs([TMDefLet(binding, m)])) - let contents = TMDefs([TMDefs[TMDefRec(false, [], [], [mbinding], m)]]) + + let mbinding = + ModuleOrNamespaceBinding.Module(entity, TMDefs([ TMDefLet(binding, m) ])) + + let contents = TMDefs([ TMDefs[TMDefRec(false, [], [], [ mbinding ], m)] ]) let qname = QualifiedNameOfFile.QualifiedNameOfFile(Ident(moduleName, m)) entity, v, CheckedImplFile.CheckedImplFile(qname, [], mty, contents, false, false, StampMap.Empty, Map.empty) - let scriptingSymbolsPath = let createDirectory path = lazy @@ -1345,16 +1661,17 @@ let scriptingSymbolsPath = let deleteScriptingSymbols () = try #if !DEBUG - if scriptingSymbolsPath.IsValueCreated then - if Directory.Exists(scriptingSymbolsPath.Value) then - Directory.Delete(scriptingSymbolsPath.Value, true) + if scriptingSymbolsPath.IsValueCreated then + if Directory.Exists(scriptingSymbolsPath.Value) then + Directory.Delete(scriptingSymbolsPath.Value, true) #else - () + () #endif with _ -> () -AppDomain.CurrentDomain.ProcessExit |> Event.add (fun _ -> deleteScriptingSymbols ()) +AppDomain.CurrentDomain.ProcessExit +|> Event.add (fun _ -> deleteScriptingSymbols ()) let dynamicCcuName = "FSI-ASSEMBLY" @@ -1362,16 +1679,17 @@ let dynamicCcuName = "FSI-ASSEMBLY" /// components of the F# compiler for interactively executed fragments of code. /// /// A single instance of this object is created per interactive session. -type internal FsiDynamicCompiler( +type internal FsiDynamicCompiler + ( fsi: FsiEvaluationSessionHostConfig, - timeReporter : FsiTimeReporter, + timeReporter: FsiTimeReporter, tcConfigB: TcConfigBuilder, - tcLockObject : obj, + tcLockObject: obj, outWriter: TextWriter, tcImports: TcImports, tcGlobals: TcGlobals, - fsiOptions : FsiCommandLineOptions, - fsiConsoleOutput : FsiConsoleOutput, + fsiOptions: FsiCommandLineOptions, + fsiConsoleOutput: FsiConsoleOutput, fsiCollectible: bool, resolveAssemblyRef ) = @@ -1388,7 +1706,7 @@ type internal FsiDynamicCompiler( static let maxVersion = int Int16.MaxValue - let mutable prevIt : ValRef option = None + let mutable prevIt: ValRef option = None let dynamicAssemblies = ResizeArray() @@ -1404,81 +1722,116 @@ type internal FsiDynamicCompiler( if tcConfigB.fsiMultiAssemblyEmit then None else - let assemBuilder, moduleBuilder = mkDynamicAssemblyAndModule (dynamicCcuName, tcConfigB.optSettings.LocalOptimizationsEnabled, fsiCollectible) + let assemBuilder, moduleBuilder = + mkDynamicAssemblyAndModule (dynamicCcuName, tcConfigB.optSettings.LocalOptimizationsEnabled, fsiCollectible) + dynamicAssemblies.Add(assemBuilder) - Some (assemBuilder, moduleBuilder) + Some(assemBuilder, moduleBuilder) let rangeStdin0 = rangeN stdinMockFileName 0 - let infoReader = InfoReader(tcGlobals,tcImports.GetImportMap()) + let infoReader = InfoReader(tcGlobals, tcImports.GetImportMap()) let reportedAssemblies = Dictionary() /// Add attributes let CreateModuleFragment (tcConfigB: TcConfigBuilder, dynamicCcuName, codegenResults) = - if progress then fprintfn fsiConsoleOutput.Out "Creating main module..." + if progress then + fprintfn fsiConsoleOutput.Out "Creating main module..." + let mainModule = - mkILSimpleModule dynamicCcuName (GetGeneratedILModuleName tcConfigB.target dynamicCcuName) (tcConfigB.target = CompilerTarget.Dll) tcConfigB.subsystemVersion tcConfigB.useHighEntropyVA (mkILTypeDefs codegenResults.ilTypeDefs) None None 0x0 (mkILExportedTypes []) "" - { mainModule - with Manifest = + mkILSimpleModule + dynamicCcuName + (GetGeneratedILModuleName tcConfigB.target dynamicCcuName) + (tcConfigB.target = CompilerTarget.Dll) + tcConfigB.subsystemVersion + tcConfigB.useHighEntropyVA + (mkILTypeDefs codegenResults.ilTypeDefs) + None + None + 0x0 + (mkILExportedTypes []) + "" + + { mainModule with + Manifest = (let man = mainModule.ManifestOfAssembly - Some { man with CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs codegenResults.ilAssemAttrs) }) } + + Some + { man with + CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs codegenResults.ilAssemAttrs) + }) + } /// Generate one assembly using multi-assembly emit let EmitInMemoryAssembly (tcConfig: TcConfig, emEnv: ILMultiInMemoryAssemblyEmitEnv, ilxMainModule: ILModuleDef) = - let embeddedTypes = tcGlobals.tryRemoveEmbeddedILTypeDefs() |> List.filter(fun tdef -> not(emEnv.IsLocalInternalType(mkRefForNestedILTypeDef ILScopeRef.Local ([], tdef)))) - let ilxMainModule = { ilxMainModule with TypeDefs = mkILTypeDefs (ilxMainModule.TypeDefs.AsList() @ embeddedTypes) } + let embeddedTypes = + tcGlobals.tryRemoveEmbeddedILTypeDefs () + |> List.filter (fun tdef -> not (emEnv.IsLocalInternalType(mkRefForNestedILTypeDef ILScopeRef.Local ([], tdef)))) + + let ilxMainModule = + { ilxMainModule with + TypeDefs = mkILTypeDefs (ilxMainModule.TypeDefs.AsList() @ embeddedTypes) + } + let multiAssemblyName = ilxMainModule.ManifestOfAssembly.Name - // Adjust the assembly name of this fragment, and add InternalsVisibleTo attributes to + + // Adjust the assembly name of this fragment, and add InternalsVisibleTo attributes to // allow internals access by all future assemblies with the same name (and only differing in version) let manifest = let manifest = ilxMainModule.Manifest.Value - let attrs = [ - tcGlobals.MakeInternalsVisibleToAttribute(dynamicCcuName) - yield! manifest.CustomAttrs.AsList() + + let attrs = + [ + tcGlobals.MakeInternalsVisibleToAttribute(dynamicCcuName) + yield! manifest.CustomAttrs.AsList() ] - { manifest with + + { manifest with Name = multiAssemblyName // Because the coreclr loader will not load a higher assembly make versions go downwards - Version = Some (parseILVersion $"0.0.0.{maxVersion - dynamicAssemblyId}") + Version = Some(parseILVersion $"0.0.0.{maxVersion - dynamicAssemblyId}") CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs attrs) } // The name of the assembly is "FSI-ASSEMBLY" for all submissions. This number is used for the Version dynamicAssemblyId <- (dynamicAssemblyId + 1) % maxVersion - let ilxMainModule = { ilxMainModule with Manifest = Some manifest } + let ilxMainModule = + { ilxMainModule with + Manifest = Some manifest + } // Rewrite references to local types to their respective dynamic assemblies let ilxMainModule = ilxMainModule |> Morphs.morphILTypeRefsInILModuleMemoized emEnv.MapTypeRef - let opts = { - ilg = tcGlobals.ilg - outfile = multiAssemblyName + ".dll" - pdbfile = Some (Path.Combine(scriptingSymbolsPath.Value, $"{multiAssemblyName}-{dynamicAssemblyId}.pdb")) - emitTailcalls = tcConfig.emitTailcalls - deterministic = tcConfig.deterministic - portablePDB = true - embeddedPDB = false - embedAllSource = false - embedSourceList = [] - allGivenSources = [] - sourceLink = tcConfig.sourceLink - checksumAlgorithm = tcConfig.checksumAlgorithm - signer = None - dumpDebugInfo = tcConfig.dumpDebugInfo - referenceAssemblyOnly = false - referenceAssemblyAttribOpt = None - pathMap = tcConfig.pathMap - } + let opts = + { + ilg = tcGlobals.ilg + outfile = multiAssemblyName + ".dll" + pdbfile = Some(Path.Combine(scriptingSymbolsPath.Value, $"{multiAssemblyName}-{dynamicAssemblyId}.pdb")) + emitTailcalls = tcConfig.emitTailcalls + deterministic = tcConfig.deterministic + portablePDB = true + embeddedPDB = false + embedAllSource = false + embedSourceList = [] + allGivenSources = [] + sourceLink = tcConfig.sourceLink + checksumAlgorithm = tcConfig.checksumAlgorithm + signer = None + dumpDebugInfo = tcConfig.dumpDebugInfo + referenceAssemblyOnly = false + referenceAssemblyAttribOpt = None + pathMap = tcConfig.pathMap + } - let assemblyBytes, pdbBytes = WriteILBinaryInMemory (opts, ilxMainModule, id) + let assemblyBytes, pdbBytes = WriteILBinaryInMemory(opts, ilxMainModule, id) let asm = match opts.pdbfile, pdbBytes with - | (Some pdbfile), (Some pdbBytes) -> - File.WriteAllBytes(pdbfile, pdbBytes) + | (Some pdbfile), (Some pdbBytes) -> File.WriteAllBytes(pdbfile, pdbBytes) | _ -> () match pdbBytes with @@ -1486,34 +1839,57 @@ type internal FsiDynamicCompiler( | Some pdbBytes -> Assembly.Load(assemblyBytes, pdbBytes) // Force generated types to load - for t in asm.GetTypes() do ignore t + for t in asm.GetTypes() do + ignore t // remember this assembly dynamicAssemblies.Add(asm) - let ilScopeRef = ILScopeRef.Assembly (ILAssemblyRef.FromAssemblyName(asm.GetName())) + let ilScopeRef = ILScopeRef.Assembly(ILAssemblyRef.FromAssemblyName(asm.GetName())) // Collect up the entry points for initialization let entries = let rec loop enc (tdef: ILTypeDef) = - [ for mdef in tdef.Methods do - if mdef.IsEntryPoint then - yield mkRefForILMethod ilScopeRef (enc, tdef) mdef - for ntdef in tdef.NestedTypes do - yield! loop (enc@[tdef]) ntdef ] - [ for tdef in ilxMainModule.TypeDefs do yield! loop [] tdef ] - + [ + for mdef in tdef.Methods do + if mdef.IsEntryPoint then + yield mkRefForILMethod ilScopeRef (enc, tdef) mdef + + for ntdef in tdef.NestedTypes do + yield! loop (enc @ [ tdef ]) ntdef + ] + + [ + for tdef in ilxMainModule.TypeDefs do + yield! loop [] tdef + ] + let execs = - [ for edef in entries do - if edef.ArgCount = 0 then - yield (fun () -> - let typ = asm.GetType(edef.DeclaringTypeRef.BasicQualifiedName) - try - ignore (typ.InvokeMember (edef.Name, BindingFlags.InvokeMethod ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static, null, null, [| |], Globalization.CultureInfo.InvariantCulture)) - None - with - | :? TargetInvocationException as e -> - Some e.InnerException) + [ + for edef in entries do + if edef.ArgCount = 0 then + yield + (fun () -> + let typ = asm.GetType(edef.DeclaringTypeRef.BasicQualifiedName) + + try + ignore ( + typ.InvokeMember( + edef.Name, + BindingFlags.InvokeMethod + ||| BindingFlags.Public + ||| BindingFlags.NonPublic + ||| BindingFlags.Static, + null, + null, + [||], + Globalization.CultureInfo.InvariantCulture + ) + ) + + None + with :? TargetInvocationException as e -> + Some e.InnerException) ] emEnv.AddModuleDef asm ilScopeRef ilxMainModule @@ -1521,25 +1897,44 @@ type internal FsiDynamicCompiler( execs // Emit the codegen results using the assembly writer - let ProcessCodegenResults (ctok, diagnosticsLogger: DiagnosticsLogger, istate, optEnv, tcState: TcState, tcConfig, prefixPath, showTypes: bool, isIncrementalFragment, fragName, declaredImpls, ilxGenerator: IlxAssemblyGenerator, codegenResults, m) = + let ProcessCodegenResults + ( + ctok, + diagnosticsLogger: DiagnosticsLogger, + istate, + optEnv, + tcState: TcState, + tcConfig, + prefixPath, + showTypes: bool, + isIncrementalFragment, + fragName, + declaredImpls, + ilxGenerator: IlxAssemblyGenerator, + codegenResults, + m + ) = let emEnv = istate.emEnv // Each input is like a small separately compiled extension to a single source file. // The incremental extension to the environment is dictated by the "signature" of the values as they come out // of the type checker. Hence we add the declaredImpls (unoptimized) to the environment, rather than the // optimizedImpls. - ilxGenerator.AddIncrementalLocalAssemblyFragment (isIncrementalFragment, fragName, declaredImpls) + ilxGenerator.AddIncrementalLocalAssemblyFragment(isIncrementalFragment, fragName, declaredImpls) ReportTime tcConfig "TAST -> ILX" diagnosticsLogger.AbortOnError(fsiConsoleOutput) ReportTime tcConfig "Linking" - let ilxMainModule = CreateModuleFragment (tcConfigB, dynamicCcuName, codegenResults) + let ilxMainModule = CreateModuleFragment(tcConfigB, dynamicCcuName, codegenResults) diagnosticsLogger.AbortOnError(fsiConsoleOutput) ReportTime tcConfig "Assembly refs Normalised" - let ilxMainModule = Morphs.morphILScopeRefsInILModuleMemoized (NormalizeAssemblyRefs (ctok, ilGlobals, tcImports)) ilxMainModule + + let ilxMainModule = + Morphs.morphILScopeRefsInILModuleMemoized (NormalizeAssemblyRefs(ctok, ilGlobals, tcImports)) ilxMainModule + diagnosticsLogger.AbortOnError(fsiConsoleOutput) #if DEBUG @@ -1548,24 +1943,35 @@ type internal FsiDynamicCompiler( ILAsciiWriter.output_module outWriter ilGlobals ilxMainModule fsiConsoleOutput.uprintnfn "--------------------" #else - ignore(fsiOptions) + ignore (fsiOptions) #endif ReportTime tcConfig "Reflection.Emit" let emEnv, execs = - match emEnv with + match emEnv with | SingleRefEmitAssembly (cenv, emEnv) -> let assemblyBuilder, moduleBuilder = builders.Value - let emEnv, execs = EmitDynamicAssemblyFragment (ilGlobals, tcConfig.emitTailcalls, emEnv, assemblyBuilder, moduleBuilder, ilxMainModule, generateDebugInfo, cenv.resolveAssemblyRef, tcGlobals.TryFindSysILTypeRef) + let emEnv, execs = + EmitDynamicAssemblyFragment( + ilGlobals, + tcConfig.emitTailcalls, + emEnv, + assemblyBuilder, + moduleBuilder, + ilxMainModule, + generateDebugInfo, + cenv.resolveAssemblyRef, + tcGlobals.TryFindSysILTypeRef + ) - SingleRefEmitAssembly (cenv, emEnv), execs + SingleRefEmitAssembly(cenv, emEnv), execs | MultipleInMemoryAssemblies emEnv -> - let execs = EmitInMemoryAssembly (tcConfig, emEnv, ilxMainModule) + let execs = EmitInMemoryAssembly(tcConfig, emEnv, ilxMainModule) MultipleInMemoryAssemblies emEnv, execs @@ -1579,36 +1985,41 @@ type internal FsiDynamicCompiler( for referencedTypeDefs, bytes in codegenResults.quotationResourceInfo do let referencedTypes = - [| for tref in referencedTypeDefs do - yield LookupTypeRef cenv emEnv tref |] - Quotations.Expr.RegisterReflectedDefinitions (assemblyBuilder, fragName, bytes, referencedTypes) + [| + for tref in referencedTypeDefs do + yield LookupTypeRef cenv emEnv tref + |] + + Quotations.Expr.RegisterReflectedDefinitions(assemblyBuilder, fragName, bytes, referencedTypes) | MultipleInMemoryAssemblies emEnv -> // Get the last assembly emitted - let assembly = dynamicAssemblies[dynamicAssemblies.Count-1] + let assembly = dynamicAssemblies[dynamicAssemblies.Count - 1] for referencedTypeDefs, bytes in codegenResults.quotationResourceInfo do let referencedTypes = - [| for tref in referencedTypeDefs do - yield emEnv.LookupTypeRef tref |] + [| + for tref in referencedTypeDefs do + yield emEnv.LookupTypeRef tref + |] - Quotations.Expr.RegisterReflectedDefinitions (assembly, fragName, bytes, referencedTypes) + Quotations.Expr.RegisterReflectedDefinitions(assembly, fragName, bytes, referencedTypes) ReportTime tcConfig "Run Bindings" timeReporter.TimeOpIf istate.timing (fun () -> - execs |> List.iter (fun exec -> - match exec() with - | Some err -> - match diagnosticsLogger with - | :? DiagnosticsLoggerThatStopsOnFirstError as diagnosticsLogger -> - fprintfn fsiConsoleOutput.Error "%s" (err.ToString()) - diagnosticsLogger.SetError() - diagnosticsLogger.AbortOnError(fsiConsoleOutput) - | _ -> - raise (StopProcessingExn (Some err)) + execs + |> List.iter (fun exec -> + match exec () with + | Some err -> + match diagnosticsLogger with + | :? DiagnosticsLoggerThatStopsOnFirstError as diagnosticsLogger -> + fprintfn fsiConsoleOutput.Error "%s" (err.ToString()) + diagnosticsLogger.SetError() + diagnosticsLogger.AbortOnError(fsiConsoleOutput) + | _ -> raise (StopProcessingExn(Some err)) - | None -> ())) + | None -> ())) diagnosticsLogger.AbortOnError(fsiConsoleOutput) @@ -1617,20 +2028,29 @@ type internal FsiDynamicCompiler( // So stored values will have been initialised, modified etc. if showTypes && not tcConfig.noFeedback then let denv = tcState.TcEnvFromImpls.DisplayEnv + let denv = if isIncrementalFragment then - // Extend denv with a (Val -> layout option) function for printing of val bindings. - {denv with generatedValueLayout = (fun v -> valuePrinter.InvokeDeclLayout (emEnv, ilxGenerator, v)) } + // Extend denv with a (Val -> layout option) function for printing of val bindings. + { denv with + generatedValueLayout = (fun v -> valuePrinter.InvokeDeclLayout(emEnv, ilxGenerator, v)) + } else - // With #load items, the vals in the inferred signature do not tie up with those generated. Disable printing. - denv - let denv = { denv with suppressInlineKeyword = false } // dont' suppress 'inline' in 'val inline f = ...' + // With #load items, the vals in the inferred signature do not tie up with those generated. Disable printing. + denv + + let denv = + { denv with + suppressInlineKeyword = false + } // dont' suppress 'inline' in 'val inline f = ...' // 'Open' the path for the fragment we just compiled for any future printing. - let denv = denv.AddOpenPath (pathOfLid prefixPath) + let denv = denv.AddOpenPath(pathOfLid prefixPath) + + for CheckedImplFile (contents = mexpr) in declaredImpls do + let responseL = + NicePrint.layoutImpliedSignatureOfModuleOrNamespace false denv infoReader AccessibleFromSomewhere m mexpr - for CheckedImplFile (contents=mexpr) in declaredImpls do - let responseL = NicePrint.layoutImpliedSignatureOfModuleOrNamespace false denv infoReader AccessibleFromSomewhere m mexpr if not (isEmptyL responseL) then let opts = valuePrinter.GetFsiPrintOptions() colorPrintL outWriter opts responseL @@ -1641,13 +2061,26 @@ type internal FsiDynamicCompiler( optEnv = optEnv emEnv = emEnv ilxGenerator = ilxGenerator - tcState = tcState } + tcState = tcState + } // Return the new state and the environment at the end of the last input, ready for further inputs. - (istate,declaredImpls) - - let ProcessTypedImpl (diagnosticsLogger: DiagnosticsLogger, optEnv, tcState: TcState, tcConfig: TcConfig, isInteractiveItExpr, topCustomAttrs, prefixPath, isIncrementalFragment, declaredImpls, ilxGenerator: IlxAssemblyGenerator) = - #if DEBUG + (istate, declaredImpls) + + let ProcessTypedImpl + ( + diagnosticsLogger: DiagnosticsLogger, + optEnv, + tcState: TcState, + tcConfig: TcConfig, + isInteractiveItExpr, + topCustomAttrs, + prefixPath, + isIncrementalFragment, + declaredImpls, + ilxGenerator: IlxAssemblyGenerator + ) = +#if DEBUG // Logging/debugging if tcConfig.printAst then for input in declaredImpls do @@ -1660,11 +2093,26 @@ type internal FsiDynamicCompiler( let importMap = tcImports.GetImportMap() // optimize: note we collect the incremental optimization environment - let optimizedImpls, _optData, optEnv = ApplyAllOptimizations (tcConfig, tcGlobals, LightweightTcValForUsingInBuildMethodCall tcGlobals, outfile, importMap, isIncrementalFragment, optEnv, tcState.Ccu, declaredImpls) + let optimizedImpls, _optData, optEnv = + ApplyAllOptimizations( + tcConfig, + tcGlobals, + LightweightTcValForUsingInBuildMethodCall tcGlobals, + outfile, + importMap, + isIncrementalFragment, + optEnv, + tcState.Ccu, + declaredImpls + ) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) let fragName = textOfLid prefixPath - let codegenResults = GenerateIlxCode (IlReflectBackend, isInteractiveItExpr, tcConfig, topCustomAttrs, optimizedImpls, fragName, ilxGenerator) + + let codegenResults = + GenerateIlxCode(IlReflectBackend, isInteractiveItExpr, tcConfig, topCustomAttrs, optimizedImpls, fragName, ilxGenerator) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) codegenResults, optEnv, fragName @@ -1674,13 +2122,15 @@ type internal FsiDynamicCompiler( TryFindFSharpAttribute tcGlobals tcGlobals.attrib_EntryPointAttribute value.Attribs |> Option.map (fun attrib -> value.DisplayName, attrib) - let rec findEntryPointInContents = function + let rec findEntryPointInContents = + function | TMDefLet (binding = binding) -> tryGetEntryPoint binding | TMDefs defs -> defs |> List.tryPick findEntryPointInContents | TMDefRec (bindings = bindings) -> bindings |> List.tryPick findEntryPointInBinding | _ -> None - and findEntryPointInBinding = function + and findEntryPointInBinding = + function | ModuleOrNamespaceBinding.Binding binding -> tryGetEntryPoint binding | ModuleOrNamespaceBinding.Module (moduleOrNamespaceContents = contents) -> findEntryPointInContents contents @@ -1690,16 +2140,26 @@ type internal FsiDynamicCompiler( |> Seq.choose (fun implFile -> implFile.Contents |> findEntryPointInContents) for name, attrib in entryPointBindings do - warning(Error(FSIstrings.SR.fsiEntryPointWontBeInvoked(name, name, name), attrib.Range)) - - let ProcessInputs (ctok, diagnosticsLogger: DiagnosticsLogger, istate: FsiDynamicCompilerState, inputs: ParsedInput list, showTypes: bool, isIncrementalFragment: bool, isInteractiveItExpr: bool, prefixPath: LongIdent, m) = - let optEnv = istate.optEnv - let tcState = istate.tcState + warning (Error(FSIstrings.SR.fsiEntryPointWontBeInvoked (name, name, name), attrib.Range)) + + let ProcessInputs + ( + ctok, + diagnosticsLogger: DiagnosticsLogger, + istate: FsiDynamicCompilerState, + inputs: ParsedInput list, + showTypes: bool, + isIncrementalFragment: bool, + isInteractiveItExpr: bool, + prefixPath: LongIdent, + m + ) = + let optEnv = istate.optEnv + let tcState = istate.tcState let ilxGenerator = istate.ilxGenerator - let tcConfig = TcConfig.Create(tcConfigB,validate=false) + let tcConfig = TcConfig.Create(tcConfigB, validate = false) - let eagerFormat (diag: PhasedDiagnostic) = - diag.EagerlyFormatCore true + let eagerFormat (diag: PhasedDiagnostic) = diag.EagerlyFormatCore true // Typecheck. The lock stops the type checker running at the same time as the // server intellisense implementation (which is currently incomplete and #if disabled) @@ -1712,57 +2172,90 @@ type internal FsiDynamicCompiler( tcImports, tcGlobals, Some prefixPath, - tcState, + tcState, eagerFormat, - inputs) + inputs + )) + + let codegenResults, optEnv, fragName = + ProcessTypedImpl( + diagnosticsLogger, + optEnv, + tcState, + tcConfig, + isInteractiveItExpr, + topCustomAttrs, + prefixPath, + isIncrementalFragment, + declaredImpls, + ilxGenerator ) - let codegenResults, optEnv, fragName = ProcessTypedImpl(diagnosticsLogger, optEnv, tcState, tcConfig, isInteractiveItExpr, topCustomAttrs, prefixPath, isIncrementalFragment, declaredImpls, ilxGenerator) + let newState, declaredImpls = + ProcessCodegenResults( + ctok, + diagnosticsLogger, + istate, + optEnv, + tcState, + tcConfig, + prefixPath, + showTypes, + isIncrementalFragment, + fragName, + declaredImpls, + ilxGenerator, + codegenResults, + m + ) - let newState, declaredImpls = ProcessCodegenResults(ctok, diagnosticsLogger, istate, optEnv, tcState, tcConfig, prefixPath, showTypes, isIncrementalFragment, fragName, declaredImpls, ilxGenerator, codegenResults, m) - CheckEntryPoint istate.tcGlobals declaredImpls (newState, tcEnvAtEndOfLastInput, declaredImpls) let tryGetGeneratedValue istate cenv v = match istate.ilxGenerator.LookupGeneratedValue(valuePrinter.GetEvaluationContext(istate.emEnv), v) with - | Some (res, ty) -> - Some (FsiValue(res, ty, FSharpType(cenv, v.Type))) - | _ -> - None + | Some (res, ty) -> Some(FsiValue(res, ty, FSharpType(cenv, v.Type))) + | _ -> None - let nextFragmentId() = + let nextFragmentId () = fragmentId <- fragmentId + 1 $"%04d{fragmentId}" let mkFragmentPath m fragmentId = - [mkSynId m (FsiDynamicModulePrefix + fragmentId())] + [ mkSynId m (FsiDynamicModulePrefix + fragmentId ()) ] let processContents istate declaredImpls = let tcState = istate.tcState let mutable itValue = None let mutable boundValues = istate.boundValues + try - let contents = FSharpAssemblyContents(tcGlobals, tcState.Ccu, Some tcState.CcuSig, tcImports, declaredImpls) + let contents = + FSharpAssemblyContents(tcGlobals, tcState.Ccu, Some tcState.CcuSig, tcImports, declaredImpls) + let contentFile = contents.ImplementationFiles[0] // Skip the "FSI_NNNN" match contentFile.Declarations with - | [FSharpImplementationFileDeclaration.Entity (_eFakeModule,modDecls) ] -> - let cenv = SymbolEnv(istate.tcGlobals, istate.tcState.Ccu, Some istate.tcState.CcuSig, istate.tcImports) + | [ FSharpImplementationFileDeclaration.Entity (_eFakeModule, modDecls) ] -> + let cenv = + SymbolEnv(istate.tcGlobals, istate.tcState.Ccu, Some istate.tcState.CcuSig, istate.tcImports) + for decl in modDecls do match decl with - | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue (v,_,_) -> + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue (v, _, _) -> // Report a top-level function or value definition if v.IsModuleValueOrMember && not v.IsMember then let fsiValueOpt = match v.Item with | Item.Value vref -> let fsiValueOpt = tryGetGeneratedValue istate cenv vref.Deref + if fsiValueOpt.IsSome then boundValues <- boundValues |> NameMap.add v.CompiledName vref.Deref + fsiValueOpt | _ -> None @@ -1774,26 +2267,50 @@ type internal FsiDynamicCompiler( | None -> () let symbol = FSharpSymbol.Create(cenv, v.Item) - let symbolUse = FSharpSymbolUse(istate.tcState.TcEnvFromImpls.DisplayEnv, symbol, [], ItemOccurence.Binding, v.DeclarationLocation) - fsi.TriggerEvaluation (fsiValueOpt, symbolUse, decl) - | FSharpImplementationFileDeclaration.Entity (e,_) -> + let symbolUse = + FSharpSymbolUse( + istate.tcState.TcEnvFromImpls.DisplayEnv, + symbol, + [], + ItemOccurence.Binding, + v.DeclarationLocation + ) + + fsi.TriggerEvaluation(fsiValueOpt, symbolUse, decl) + + | FSharpImplementationFileDeclaration.Entity (e, _) -> // Report a top-level module or namespace definition let symbol = FSharpSymbol.Create(cenv, e.Item) - let symbolUse = FSharpSymbolUse(istate.tcState.TcEnvFromImpls.DisplayEnv, symbol, [], ItemOccurence.Binding, e.DeclarationLocation) - fsi.TriggerEvaluation (None, symbolUse, decl) + + let symbolUse = + FSharpSymbolUse( + istate.tcState.TcEnvFromImpls.DisplayEnv, + symbol, + [], + ItemOccurence.Binding, + e.DeclarationLocation + ) + + fsi.TriggerEvaluation(None, symbolUse, decl) | FSharpImplementationFileDeclaration.InitAction _ -> // Top level 'do' bindings are not reported as incremental declarations () | _ -> () - with _ -> () + with _ -> + () - { istate with boundValues = boundValues }, Completed itValue + { istate with + boundValues = boundValues + }, + Completed itValue let addCcusToIncrementalEnv istate ccuinfos = - let optEnv = List.fold (AddExternalCcuToOptimizationEnv tcGlobals) istate.optEnv ccuinfos - istate.ilxGenerator.AddExternalCcus (ccuinfos |> List.map (fun ccuinfo -> ccuinfo.FSharpViewOfMetadata)) + let optEnv = + List.fold (AddExternalCcuToOptimizationEnv tcGlobals) istate.optEnv ccuinfos + + istate.ilxGenerator.AddExternalCcus(ccuinfos |> List.map (fun ccuinfo -> ccuinfo.FSharpViewOfMetadata)) { istate with optEnv = optEnv } let importReflectionType istate reflectionTy = @@ -1811,17 +2328,20 @@ type internal FsiDynamicCompiler( (ccuinfos2 @ ccuinfos, ty :: tinst)) let ty = Import.ImportILType amap range0 tinst ilTy + let ccuinfos = match tryTcrefOfAppTy tcGlobals ty with | ValueSome tcref -> match tcref.CompilationPath.ILScopeRef with | ILScopeRef.Assembly aref -> - let ccuinfo = tcImports.GetImportedAssemblies() |> List.find (fun x -> x.FSharpViewOfMetadata.AssemblyName = aref.Name) + let ccuinfo = + tcImports.GetImportedAssemblies() + |> List.find (fun x -> x.FSharpViewOfMetadata.AssemblyName = aref.Name) + ccuinfo :: ccuinfos - | _ -> - ccuinfos - | _ -> - ccuinfos + | _ -> ccuinfos + | _ -> ccuinfos + ccuinfos, ty let addTypeToEnvironment state ilTy = @@ -1829,116 +2349,212 @@ type internal FsiDynamicCompiler( invalidOp (sprintf "Unable to import type, %A." reflectionTy) let ccuinfos, ty = import [] ilTy + let ccuinfos = ccuinfos |> List.distinctBy (fun x -> x.FSharpViewOfMetadata.AssemblyName) - |> List.filter (fun asm1 -> not (prevCcuinfos |> List.exists (fun asm2 -> asm2.FSharpViewOfMetadata.AssemblyName = asm1.FSharpViewOfMetadata.AssemblyName))) + |> List.filter (fun asm1 -> + not ( + prevCcuinfos + |> List.exists (fun asm2 -> asm2.FSharpViewOfMetadata.AssemblyName = asm1.FSharpViewOfMetadata.AssemblyName) + )) // After we have successfully imported the type, then we can add newly resolved ccus to the env. addCcusToIncrementalEnv state ccuinfos, ty let ilTys = ConvReflectionTypeToILType reflectionTy - + // Rewrite references to dynamic .NET assemblies back to dynamicCcuName let ilTys = - ilTys |> List.map (fun ilTy -> - match istate.emEnv with - | MultipleInMemoryAssemblies emEnv -> - ilTy |> Morphs.morphILTypeRefsInILType emEnv.ReverseMapTypeRef + ilTys + |> List.map (fun ilTy -> + match istate.emEnv with + | MultipleInMemoryAssemblies emEnv -> ilTy |> Morphs.morphILTypeRefsInILType emEnv.ReverseMapTypeRef | _ -> ilTy) - ((istate, []), ilTys) ||> List.fold (fun (state, addedTys) ilTy -> + ((istate, []), ilTys) + ||> List.fold (fun (state, addedTys) ilTy -> let nextState, addedTy = addTypeToEnvironment state ilTy - nextState, addedTys @ [addedTy]) + nextState, addedTys @ [ addedTy ]) member _.DynamicAssemblies = dynamicAssemblies.ToArray() - member _.FindDynamicAssembly (name, useFullName: bool) = + member _.FindDynamicAssembly(name, useFullName: bool) = let getName (assemblyName: AssemblyName) = if useFullName then assemblyName.FullName else assemblyName.Name - dynamicAssemblies |> ResizeArray.tryFind (fun asm -> getName (asm.GetName()) = name) + dynamicAssemblies + |> ResizeArray.tryFind (fun asm -> getName (asm.GetName()) = name) - member _.EvalParsedSourceFiles (ctok, diagnosticsLogger, istate, inputs, m) = + member _.EvalParsedSourceFiles(ctok, diagnosticsLogger, istate, inputs, m) = let prefix = mkFragmentPath m nextFragmentId // Ensure the path includes the qualifying name let inputs = inputs |> List.map (PrependPathToInput prefix) let isIncrementalFragment = false - let istate,_,_ = ProcessInputs (ctok, diagnosticsLogger, istate, inputs, true, isIncrementalFragment, false, prefix, m) + + let istate, _, _ = + ProcessInputs(ctok, diagnosticsLogger, istate, inputs, true, isIncrementalFragment, false, prefix, m) + istate /// Evaluate the given definitions and produce a new interactive state. - member _.EvalParsedDefinitions (ctok, diagnosticsLogger: DiagnosticsLogger, istate, showTypes, isInteractiveItExpr, defs: SynModuleDecl list) = + member _.EvalParsedDefinitions + ( + ctok, + diagnosticsLogger: DiagnosticsLogger, + istate, + showTypes, + isInteractiveItExpr, + defs: SynModuleDecl list + ) = let fileName = stdinMockFileName - let m = match defs with [] -> rangeStdin0 | _ -> List.reduce unionRanges [for d in defs -> d.Range] + + let m = + match defs with + | [] -> rangeStdin0 + | _ -> List.reduce unionRanges [ for d in defs -> d.Range ] + let prefix = mkFragmentPath m nextFragmentId let prefixPath = pathOfLid prefix - let impl = SynModuleOrNamespace(prefix,false, SynModuleOrNamespaceKind.NamedModule,defs,PreXmlDoc.Empty,[],None,m, { LeadingKeyword = SynModuleOrNamespaceLeadingKeyword.None }) + + let impl = + SynModuleOrNamespace( + prefix, + false, + SynModuleOrNamespaceKind.NamedModule, + defs, + PreXmlDoc.Empty, + [], + None, + m, + { + LeadingKeyword = SynModuleOrNamespaceLeadingKeyword.None + } + ) + let isLastCompiland = true let isExe = false - let input = ParsedInput.ImplFile (ParsedImplFileInput (fileName,true, ComputeQualifiedNameOfFileFromUniquePath (m,prefixPath),[],[],[impl],(isLastCompiland, isExe), { ConditionalDirectives = []; CodeComments = [] }, Set.empty)) + + let input = + ParsedInput.ImplFile( + ParsedImplFileInput( + fileName, + true, + ComputeQualifiedNameOfFileFromUniquePath(m, prefixPath), + [], + [], + [ impl ], + (isLastCompiland, isExe), + { + ConditionalDirectives = [] + CodeComments = [] + }, + Set.empty + ) + ) + let isIncrementalFragment = true - let istate,tcEnvAtEndOfLastInput,declaredImpls = ProcessInputs (ctok, diagnosticsLogger, istate, [input], showTypes, isIncrementalFragment, isInteractiveItExpr, prefix, m) + + let istate, tcEnvAtEndOfLastInput, declaredImpls = + ProcessInputs(ctok, diagnosticsLogger, istate, [ input ], showTypes, isIncrementalFragment, isInteractiveItExpr, prefix, m) + let tcState = istate.tcState - let newState = { istate with tcState = tcState.NextStateAfterIncrementalFragment(tcEnvAtEndOfLastInput) } + + let newState = + { istate with + tcState = tcState.NextStateAfterIncrementalFragment(tcEnvAtEndOfLastInput) + } + processContents newState declaredImpls /// Evaluate the given expression and produce a new interactive state. - member fsiDynamicCompiler.EvalParsedExpression (ctok, diagnosticsLogger: DiagnosticsLogger, istate, expr: SynExpr) = - let tcConfig = TcConfig.Create (tcConfigB, validate=false) + member fsiDynamicCompiler.EvalParsedExpression(ctok, diagnosticsLogger: DiagnosticsLogger, istate, expr: SynExpr) = + let tcConfig = TcConfig.Create(tcConfigB, validate = false) let itName = "it" // Construct the code that saves the 'it' value into the 'SaveIt' register. let defs = fsiDynamicCompiler.BuildItBinding expr // Evaluate the overall definitions. - let istate = fsiDynamicCompiler.EvalParsedDefinitions (ctok, diagnosticsLogger, istate, false, true, defs) |> fst + let istate = + fsiDynamicCompiler.EvalParsedDefinitions(ctok, diagnosticsLogger, istate, false, true, defs) + |> fst // Snarf the type for 'it' via the binding match istate.tcState.TcEnvFromImpls.NameEnv.FindUnqualifiedItem itName with | Item.Value vref -> - if not tcConfig.noFeedback then - let infoReader = InfoReader(istate.tcGlobals, istate.tcImports.GetImportMap()) - valuePrinter.InvokeExprPrinter (istate.tcState.TcEnvFromImpls.DisplayEnv, infoReader, istate.emEnv, istate.ilxGenerator, vref) + if not tcConfig.noFeedback then + let infoReader = InfoReader(istate.tcGlobals, istate.tcImports.GetImportMap()) + + valuePrinter.InvokeExprPrinter( + istate.tcState.TcEnvFromImpls.DisplayEnv, + infoReader, + istate.emEnv, + istate.ilxGenerator, + vref + ) - // Clear the value held in the previous "it" binding, if any, as long as it has never been referenced. - match prevIt with - | Some prevVal when not prevVal.Deref.HasBeenReferenced -> - istate.ilxGenerator.ClearGeneratedValue (valuePrinter.GetEvaluationContext istate.emEnv, prevVal.Deref) - | _ -> () - prevIt <- Some vref + // Clear the value held in the previous "it" binding, if any, as long as it has never been referenced. + match prevIt with + | Some prevVal when not prevVal.Deref.HasBeenReferenced -> + istate.ilxGenerator.ClearGeneratedValue(valuePrinter.GetEvaluationContext istate.emEnv, prevVal.Deref) + | _ -> () + + prevIt <- Some vref - // - let optValue = istate.ilxGenerator.LookupGeneratedValue(valuePrinter.GetEvaluationContext(istate.emEnv), vref.Deref) + // + let optValue = + istate.ilxGenerator.LookupGeneratedValue(valuePrinter.GetEvaluationContext(istate.emEnv), vref.Deref) - let fsiValue = - match optValue with - | Some (res, ty) -> Some(FsiValue(res, ty, FSharpType(tcGlobals, istate.tcState.Ccu, istate.tcState.CcuSig, istate.tcImports, vref.Type))) - | _ -> None + let fsiValue = + match optValue with + | Some (res, ty) -> + Some(FsiValue(res, ty, FSharpType(tcGlobals, istate.tcState.Ccu, istate.tcState.CcuSig, istate.tcImports, vref.Type))) + | _ -> None - istate, Completed fsiValue + istate, Completed fsiValue // Return the interactive state. | _ -> istate, Completed None // Construct the code that saves the 'it' value into the 'SaveIt' register. - member _.BuildItBinding (expr: SynExpr) = + member _.BuildItBinding(expr: SynExpr) = let m = expr.Range let itName = "it" - let itID = mkSynId m itName - let mkBind pat expr = SynBinding (None, SynBindingKind.Do, false, false, [], PreXmlDoc.Empty, SynInfo.emptySynValData, pat, None, expr, m, DebugPointAtBinding.NoneAtInvisible, SynBindingTrivia.Zero) + let itID = mkSynId m itName + + let mkBind pat expr = + SynBinding( + None, + SynBindingKind.Do, + false, + false, + [], + PreXmlDoc.Empty, + SynInfo.emptySynValData, + pat, + None, + expr, + m, + DebugPointAtBinding.NoneAtInvisible, + SynBindingTrivia.Zero + ) + let bindingA = mkBind (mkSynPatVar None itID) expr - let defA = SynModuleDecl.Let (false, [bindingA], m) - [defA] + let defA = SynModuleDecl.Let(false, [ bindingA ], m) + [ defA ] // Construct an invisible call to Debugger.Break(), in the specified range - member _.CreateDebuggerBreak (m: range) = - let breakPath = ["System";"Diagnostics";"Debugger";"Break"] + member _.CreateDebuggerBreak(m: range) = + let breakPath = [ "System"; "Diagnostics"; "Debugger"; "Break" ] let dots = List.replicate (breakPath.Length - 1) m - let methCall = SynExpr.LongIdent (false, SynLongIdent(List.map (mkSynId m) breakPath, dots, List.replicate breakPath.Length None), None, m) - let args = SynExpr.Const (SynConst.Unit, m) - let breakStatement = SynExpr.App (ExprAtomicFlag.Atomic, false, methCall, args, m) + + let methCall = + SynExpr.LongIdent(false, SynLongIdent(List.map (mkSynId m) breakPath, dots, List.replicate breakPath.Length None), None, m) + + let args = SynExpr.Const(SynConst.Unit, m) + let breakStatement = SynExpr.App(ExprAtomicFlag.Atomic, false, methCall, args, m) SynModuleDecl.Expr(breakStatement, m) /// Resolve and register an assembly reference, delaying the actual addition of the reference @@ -1946,15 +2562,15 @@ type internal FsiDynamicCompiler( /// /// That is, references are collected across a group of #r declarations and only added to the /// tcImports state once all are collected. - member _.AddDelayedReference (ctok, path, show, m) = + member _.AddDelayedReference(ctok, path, show, m) = // Check the file can be resolved if FileSystem.IsInvalidPathShim(path) then - error(Error(FSIstrings.SR.fsiInvalidAssembly(path), m)) + error (Error(FSIstrings.SR.fsiInvalidAssembly (path), m)) // Do the resolution let resolutions = - tcImports.ResolveAssemblyReference(ctok, AssemblyReference(m,path,None), ResolveAssemblyReferenceMode.ReportErrors) + tcImports.ResolveAssemblyReference(ctok, AssemblyReference(m, path, None), ResolveAssemblyReferenceMode.ReportErrors) // Delay the addition of the assembly to the interactive state delayedReferences.Add((path, resolutions, show, m)) @@ -1963,12 +2579,12 @@ type internal FsiDynamicCompiler( member _.HasDelayedReferences = delayedReferences.Count > 0 /// Process any delayed assembly additions. - member _.ProcessDelayedReferences (ctok, istate) = + member _.ProcessDelayedReferences(ctok, istate) = // Grab the dealyed assembly reference additions let refs = delayedReferences |> Seq.toList delayedReferences.Clear() - + // Print the explicit assembly resolutions. Only for explicit '#r' in direct inputs, not those // in #load files. This means those resulting from nuget package resolution are not shown. for (_, resolutions, show, _) in refs do @@ -1978,23 +2594,24 @@ type internal FsiDynamicCompiler( if tcConfigB.shadowCopyReferences then let resolvedPath = ar.resolvedPath.ToUpperInvariant() let fileTime = FileSystem.GetLastWriteTimeShim(resolvedPath) + match reportedAssemblies.TryGetValue resolvedPath with | false, _ -> reportedAssemblies.Add(resolvedPath, fileTime) - FSIstrings.SR.fsiDidAHashr(ar.resolvedPath) - | true, time when time <> fileTime -> - FSIstrings.SR.fsiDidAHashrWithStaleWarning(ar.resolvedPath) - | _ -> - FSIstrings.SR.fsiDidAHashr(ar.resolvedPath) + FSIstrings.SR.fsiDidAHashr (ar.resolvedPath) + | true, time when time <> fileTime -> FSIstrings.SR.fsiDidAHashrWithStaleWarning (ar.resolvedPath) + | _ -> FSIstrings.SR.fsiDidAHashr (ar.resolvedPath) else - FSIstrings.SR.fsiDidAHashrWithLockWarning(ar.resolvedPath) + FSIstrings.SR.fsiDidAHashrWithLockWarning (ar.resolvedPath) fsiConsoleOutput.uprintnfnn "%s" format // Collect the overall resolutions let resolutions = - [ for (_, resolutions, _, _) in refs do - yield! resolutions ] + [ + for (_, resolutions, _, _) in refs do + yield! resolutions + ] // Add then to the config. for (path, _, _, m) in refs do @@ -2004,90 +2621,150 @@ type internal FsiDynamicCompiler( let tcEnv, asms = try - RequireReferences (ctok, tcImports, tcState.TcEnvFromImpls, dynamicCcuName, resolutions) + RequireReferences(ctok, tcImports, tcState.TcEnvFromImpls, dynamicCcuName, resolutions) with _ -> for (path, _, _, m) in refs do - tcConfigB.RemoveReferencedAssemblyByPath(m,path) - reraise() + tcConfigB.RemoveReferencedAssemblyByPath(m, path) + + reraise () + + let istate = + { addCcusToIncrementalEnv istate asms with + tcState = tcState.NextStateAfterIncrementalFragment(tcEnv) + } - let istate = { addCcusToIncrementalEnv istate asms with tcState = tcState.NextStateAfterIncrementalFragment(tcEnv) } - istate // Dependency manager text is collected across a group of #r and #i declarations and // only actually processed once all are collected. - member _.AddDelayedDependencyManagerText (packageManager:IDependencyManagerProvider, lt, m, path: string) = + member _.AddDelayedDependencyManagerText(packageManager: IDependencyManagerProvider, lt, m, path: string) = tcConfigB.packageManagerLines <- PackageManagerLine.AddLineWithKey packageManager.Key lt path m tcConfigB.packageManagerLines hasDelayedDependencyManagerText <- true member _.HasDelayedDependencyManagerText = hasDelayedDependencyManagerText - member fsiDynamicCompiler.ProcessDelayedDependencyManagerText (ctok, istate: FsiDynamicCompilerState, lexResourceManager, diagnosticsLogger) = - if not hasDelayedDependencyManagerText then istate else - hasDelayedDependencyManagerText <- false + member fsiDynamicCompiler.ProcessDelayedDependencyManagerText + ( + ctok, + istate: FsiDynamicCompilerState, + lexResourceManager, + diagnosticsLogger + ) = + if not hasDelayedDependencyManagerText then + istate + else + hasDelayedDependencyManagerText <- false + + (istate, tcConfigB.packageManagerLines) + ||> Seq.fold (fun istate kv -> + let (KeyValue (packageManagerKey, packageManagerLines)) = kv + + match packageManagerLines with + | [] -> istate + | { + Directive = _ + LineStatus = _ + Line = _ + Range = m + } :: _ -> + let outputDir = tcConfigB.outputDir |> Option.defaultValue "" + + match + fsiOptions.DependencyProvider.TryFindDependencyManagerByKey( + tcConfigB.compilerToolPaths, + getOutputDir tcConfigB, + reportError m, + packageManagerKey + ) + with + | Null -> + let err = + fsiOptions.DependencyProvider.CreatePackageManagerUnknownError( + tcConfigB.compilerToolPaths, + outputDir, + packageManagerKey, + reportError m + ) - (istate, tcConfigB.packageManagerLines) ||> Seq.fold (fun istate kv -> - let (KeyValue(packageManagerKey, packageManagerLines)) = kv - match packageManagerLines with - | [] -> istate - | { Directive=_; LineStatus=_; Line=_; Range=m } :: _ -> - let outputDir = tcConfigB.outputDir |> Option.defaultValue "" - - match fsiOptions.DependencyProvider.TryFindDependencyManagerByKey(tcConfigB.compilerToolPaths, getOutputDir tcConfigB, reportError m, packageManagerKey) with - | Null -> - let err = fsiOptions.DependencyProvider.CreatePackageManagerUnknownError(tcConfigB.compilerToolPaths, outputDir, packageManagerKey, reportError m) - errorR(Error(err, m)) - istate - | NonNull dependencyManager -> - let directive d = - match d with - | Directive.Resolution -> "r" - | Directive.Include -> "i" - - let packageManagerTextLines = - packageManagerLines |> List.map (fun line -> directive line.Directive, line.Line) - - try - let tfm, rid = fsiOptions.FxResolver.GetTfmAndRid() - let result = fsiOptions.DependencyProvider.Resolve(dependencyManager, ".fsx", packageManagerTextLines, reportError m, tfm, rid, tcConfigB.implicitIncludeDir, "stdin.fsx", "stdin.fsx") - if result.Success then - - for line in result.StdOut do - Console.Out.WriteLine(line) - - for line in result.StdError do - Console.Error.WriteLine(line) - - tcConfigB.packageManagerLines <- PackageManagerLine.SetLinesAsProcessed packageManagerKey tcConfigB.packageManagerLines - - for folder in result.Roots do - tcConfigB.AddIncludePath(m, folder, "") + errorR (Error(err, m)) + istate + | NonNull dependencyManager -> + let directive d = + match d with + | Directive.Resolution -> "r" + | Directive.Include -> "i" - for resolution in result.Resolutions do - tcConfigB.AddReferencedAssemblyByPath(m, resolution) + let packageManagerTextLines = + packageManagerLines + |> List.map (fun line -> directive line.Directive, line.Line) - let scripts = result.SourceFiles |> Seq.toList - if not (isNil scripts) then - fsiDynamicCompiler.EvalSourceFiles(ctok, istate, m, scripts, lexResourceManager, diagnosticsLogger) - else istate - else - // Send outputs via diagnostics - if result.StdOut.Length > 0 || result.StdError.Length > 0 then - for line in Array.append result.StdOut result.StdError do - errorR(Error(FSComp.SR.packageManagerError(line), m)) - - //Write outputs in F# Interactive and compiler - tcConfigB.packageManagerLines <- PackageManagerLine.RemoveUnprocessedLines packageManagerKey tcConfigB.packageManagerLines - istate // error already reported - - with _ -> - // An exception occured during processing, so remove the lines causing the error from the package manager list. - tcConfigB.packageManagerLines <- PackageManagerLine.RemoveUnprocessedLines packageManagerKey tcConfigB.packageManagerLines - reraise () + try + let tfm, rid = fsiOptions.FxResolver.GetTfmAndRid() + + let result = + fsiOptions.DependencyProvider.Resolve( + dependencyManager, + ".fsx", + packageManagerTextLines, + reportError m, + tfm, + rid, + tcConfigB.implicitIncludeDir, + "stdin.fsx", + "stdin.fsx" + ) + + if result.Success then + + for line in result.StdOut do + Console.Out.WriteLine(line) + + for line in result.StdError do + Console.Error.WriteLine(line) + + tcConfigB.packageManagerLines <- + PackageManagerLine.SetLinesAsProcessed packageManagerKey tcConfigB.packageManagerLines + + for folder in result.Roots do + tcConfigB.AddIncludePath(m, folder, "") + + for resolution in result.Resolutions do + tcConfigB.AddReferencedAssemblyByPath(m, resolution) + + let scripts = result.SourceFiles |> Seq.toList + + if not (isNil scripts) then + fsiDynamicCompiler.EvalSourceFiles(ctok, istate, m, scripts, lexResourceManager, diagnosticsLogger) + else + istate + else + // Send outputs via diagnostics + if result.StdOut.Length > 0 || result.StdError.Length > 0 then + for line in Array.append result.StdOut result.StdError do + errorR (Error(FSComp.SR.packageManagerError (line), m)) + + //Write outputs in F# Interactive and compiler + tcConfigB.packageManagerLines <- + PackageManagerLine.RemoveUnprocessedLines packageManagerKey tcConfigB.packageManagerLines + + istate // error already reported + + with _ -> + // An exception occured during processing, so remove the lines causing the error from the package manager list. + tcConfigB.packageManagerLines <- + PackageManagerLine.RemoveUnprocessedLines packageManagerKey tcConfigB.packageManagerLines + + reraise ()) + + member fsiDynamicCompiler.PartiallyProcessReferenceOrPackageIncudePathDirective(ctok, istate, directiveKind, path, show, m) = + let dm = + fsiOptions.DependencyProvider.TryFindDependencyManagerInPath( + tcConfigB.compilerToolPaths, + getOutputDir tcConfigB, + reportError m, + path ) - member fsiDynamicCompiler.PartiallyProcessReferenceOrPackageIncudePathDirective (ctok, istate, directiveKind, path, show, m) = - let dm = fsiOptions.DependencyProvider.TryFindDependencyManagerInPath(tcConfigB.compilerToolPaths, getOutputDir tcConfigB, reportError m, path) match dm with | Null, Null -> // error already reported @@ -2098,112 +2775,135 @@ type internal FsiDynamicCompiler( fsiDynamicCompiler.AddDelayedDependencyManagerText(dependencyManager, directiveKind, m, path) istate, Completed None else - errorR(Error(FSComp.SR.packageManagementRequiresVFive(), m)) + errorR (Error(FSComp.SR.packageManagementRequiresVFive (), m)) istate, Completed None | _, _ when directiveKind = Directive.Include -> - errorR(Error(FSComp.SR.poundiNotSupportedByRegisteredDependencyManagers(), m)) + errorR (Error(FSComp.SR.poundiNotSupportedByRegisteredDependencyManagers (), m)) istate, Completed None | NonNull p, Null -> - let path = - if String.IsNullOrWhiteSpace(p) then "" - else p + let path = if String.IsNullOrWhiteSpace(p) then "" else p fsiDynamicCompiler.AddDelayedReference(ctok, path, show, m) istate, Completed None /// Scrape #r, #I and package manager commands from a #load - member fsiDynamicCompiler.ProcessMetaCommandsFromParsedInputAsInteractiveCommands(ctok, istate: FsiDynamicCompilerState, sourceFile, input) = - WithImplicitHome - (tcConfigB, directoryName sourceFile) - (fun () -> - ProcessMetaCommandsFromInput - ((fun st (m,nm) -> tcConfigB.TurnWarningOff(m,nm); st), - (fun st (m, path, directive) -> - let st, _ = fsiDynamicCompiler.PartiallyProcessReferenceOrPackageIncudePathDirective (ctok, st, directive, path, false, m) - st - ), - (fun _ _ -> ())) - (tcConfigB, input, Path.GetDirectoryName sourceFile, istate)) + member fsiDynamicCompiler.ProcessMetaCommandsFromParsedInputAsInteractiveCommands + ( + ctok, + istate: FsiDynamicCompilerState, + sourceFile, + input + ) = + WithImplicitHome (tcConfigB, directoryName sourceFile) (fun () -> + ProcessMetaCommandsFromInput + ((fun st (m, nm) -> + tcConfigB.TurnWarningOff(m, nm) + st), + (fun st (m, path, directive) -> + let st, _ = + fsiDynamicCompiler.PartiallyProcessReferenceOrPackageIncudePathDirective(ctok, st, directive, path, false, m) + + st), + (fun _ _ -> ())) + (tcConfigB, input, Path.GetDirectoryName sourceFile, istate)) member fsiDynamicCompiler.EvalSourceFiles(ctok, istate, m, sourceFiles, lexResourceManager, diagnosticsLogger: DiagnosticsLogger) = - let tcConfig = TcConfig.Create(tcConfigB,validate=false) + let tcConfig = TcConfig.Create(tcConfigB, validate = false) + match sourceFiles with | [] -> istate | _ -> // use a set of source files as though they were command line inputs - let sourceFiles = sourceFiles |> List.map (fun nm -> tcConfig.ResolveSourceFile(m, nm, tcConfig.implicitIncludeDir),m) + let sourceFiles = + sourceFiles + |> List.map (fun nm -> tcConfig.ResolveSourceFile(m, nm, tcConfig.implicitIncludeDir), m) // Close the #load graph on each file and gather the inputs from the scripts. - let tcConfig = TcConfig.Create(tcConfigB,validate=false) + let tcConfig = TcConfig.Create(tcConfigB, validate = false) let closure = - LoadClosure.ComputeClosureOfScriptFiles(tcConfig, - sourceFiles, CodeContext.CompilationAndEvaluation, - lexResourceManager, fsiOptions.DependencyProvider) + LoadClosure.ComputeClosureOfScriptFiles( + tcConfig, + sourceFiles, + CodeContext.CompilationAndEvaluation, + lexResourceManager, + fsiOptions.DependencyProvider + ) // Intent "[Loading %s]\n" (String.concat "\n and " sourceFiles) - fsiConsoleOutput.uprintf "[%s " (FSIstrings.SR.fsiLoadingFilesPrefixText()) + fsiConsoleOutput.uprintf "[%s " (FSIstrings.SR.fsiLoadingFilesPrefixText ()) - closure.Inputs |> List.iteri (fun i input -> - if i=0 then fsiConsoleOutput.uprintf "%s" input.FileName - else fsiConsoleOutput.uprintnf " %s %s" (FSIstrings.SR.fsiLoadingFilesPrefixText()) input.FileName) + closure.Inputs + |> List.iteri (fun i input -> + if i = 0 then + fsiConsoleOutput.uprintf "%s" input.FileName + else + fsiConsoleOutput.uprintnf " %s %s" (FSIstrings.SR.fsiLoadingFilesPrefixText ()) input.FileName) fsiConsoleOutput.uprintfn "]" for (warnNum, ranges) in closure.NoWarns do for m in ranges do - tcConfigB.TurnWarningOff (m, warnNum) + tcConfigB.TurnWarningOff(m, warnNum) // Play errors and warnings from resolution closure.ResolutionDiagnostics |> List.iter diagnosticSink // Non-scripts will not have been parsed during #load closure so parse them now - let sourceFiles,inputs = + let sourceFiles, inputs = closure.Inputs - |> List.map (fun input-> + |> List.map (fun input -> input.ParseDiagnostics |> List.iter diagnosticSink input.MetaCommandDiagnostics |> List.iter diagnosticSink + let parsedInput = match input.SyntaxTree with | None -> ParseOneInputFile(tcConfig, lexResourceManager, input.FileName, (true, false), diagnosticsLogger, false) | Some parseTree -> parseTree + input.FileName, parsedInput) |> List.unzip - diagnosticsLogger.AbortOnError(fsiConsoleOutput); - let istate = (istate, sourceFiles, inputs) |||> List.fold2 (fun istate sourceFile input -> fsiDynamicCompiler.ProcessMetaCommandsFromParsedInputAsInteractiveCommands(ctok, istate, sourceFile, input)) + diagnosticsLogger.AbortOnError(fsiConsoleOutput) - let istate = fsiDynamicCompiler.ProcessDelayedReferences (ctok, istate) + let istate = + (istate, sourceFiles, inputs) + |||> List.fold2 (fun istate sourceFile input -> + fsiDynamicCompiler.ProcessMetaCommandsFromParsedInputAsInteractiveCommands(ctok, istate, sourceFile, input)) - fsiDynamicCompiler.EvalParsedSourceFiles (ctok, diagnosticsLogger, istate, inputs, m) + let istate = fsiDynamicCompiler.ProcessDelayedReferences(ctok, istate) + + fsiDynamicCompiler.EvalParsedSourceFiles(ctok, diagnosticsLogger, istate, inputs, m) member _.GetBoundValues istate = - let cenv = SymbolEnv(istate.tcGlobals, istate.tcState.Ccu, Some istate.tcState.CcuSig, istate.tcImports) - [ for pair in istate.boundValues do - let nm = pair.Key - let v = pair.Value - match tryGetGeneratedValue istate cenv v with - | Some fsiValue -> - FsiBoundValue(nm, fsiValue) - | _ -> - () ] + let cenv = + SymbolEnv(istate.tcGlobals, istate.tcState.Ccu, Some istate.tcState.CcuSig, istate.tcImports) + + [ + for pair in istate.boundValues do + let nm = pair.Key + let v = pair.Value + + match tryGetGeneratedValue istate cenv v with + | Some fsiValue -> FsiBoundValue(nm, fsiValue) + | _ -> () + ] member _.TryFindBoundValue(istate, nm) = match istate.boundValues.TryFind nm with | Some v -> - let cenv = SymbolEnv(istate.tcGlobals, istate.tcState.Ccu, Some istate.tcState.CcuSig, istate.tcImports) + let cenv = + SymbolEnv(istate.tcGlobals, istate.tcState.Ccu, Some istate.tcState.CcuSig, istate.tcImports) + match tryGetGeneratedValue istate cenv v with - | Some fsiValue -> - Some (FsiBoundValue(nm, fsiValue)) - | _ -> - None - | _ -> - None + | Some fsiValue -> Some(FsiBoundValue(nm, fsiValue)) + | _ -> None + | _ -> None - member _.AddBoundValue (ctok, diagnosticsLogger: DiagnosticsLogger, istate, name: string, value: obj) = + member _.AddBoundValue(ctok, diagnosticsLogger: DiagnosticsLogger, istate, name: string, value: obj) = try match value with | null -> nullArg "value" @@ -2213,15 +2913,19 @@ type internal FsiDynamicCompiler( invalidArg "name" "Name cannot be null or white-space." // Verify that the name is a valid identifier for a value. - FSharpLexer.Tokenize(SourceText.ofString name, + FSharpLexer.Tokenize( + SourceText.ofString name, let mutable foundOne = false + fun t -> if not t.IsIdentifier || foundOne then invalidArg "name" "Name is not a valid identifier." - foundOne <- true) + + foundOne <- true + ) if IsCompilerGeneratedName name then - invalidArg "name" (FSComp.SR.lexhlpIdentifiersContainingAtSymbolReserved() |> snd) + invalidArg "name" (FSComp.SR.lexhlpIdentifiersContainingAtSymbolReserved () |> snd) let istate, tys = importReflectionType istate (value.GetType()) let ty = List.head tys @@ -2230,12 +2934,14 @@ type internal FsiDynamicCompiler( let m = rangeStdin0 let prefix = mkFragmentPath m nextFragmentId let prefixPath = pathOfLid prefix - let qualifiedName = ComputeQualifiedNameOfFileFromUniquePath (m,prefixPath) + let qualifiedName = ComputeQualifiedNameOfFileFromUniquePath(m, prefixPath) - let tcConfig = TcConfig.Create(tcConfigB,validate=false) + let tcConfig = TcConfig.Create(tcConfigB, validate = false) // Build a simple module with a single 'let' decl with a default value. - let moduleEntity, v, impl = mkBoundValueTypedImpl istate.tcGlobals range0 qualifiedName.Text name ty + let moduleEntity, v, impl = + mkBoundValueTypedImpl istate.tcGlobals range0 qualifiedName.Text name ty + let tcEnvAtEndOfLastInput = AddLocalSubModule tcGlobals amap range0 istate.tcState.TcEnvFromImpls moduleEntity |> AddLocalVal tcGlobals TcResultsSink.NoSink range0 v @@ -2244,10 +2950,44 @@ type internal FsiDynamicCompiler( let ilxGenerator = istate.ilxGenerator let isIncrementalFragment = true let showTypes = false - let declaredImpls = [impl] - let codegenResults, optEnv, fragName = ProcessTypedImpl(diagnosticsLogger, istate.optEnv, istate.tcState, tcConfig, false, EmptyTopAttrs, prefix, isIncrementalFragment, declaredImpls, ilxGenerator) - let istate, declaredImpls = ProcessCodegenResults(ctok, diagnosticsLogger, istate, optEnv, istate.tcState, tcConfig, prefix, showTypes, isIncrementalFragment, fragName, declaredImpls, ilxGenerator, codegenResults, m) - let newState = { istate with tcState = istate.tcState.NextStateAfterIncrementalFragment tcEnvAtEndOfLastInput } + let declaredImpls = [ impl ] + + let codegenResults, optEnv, fragName = + ProcessTypedImpl( + diagnosticsLogger, + istate.optEnv, + istate.tcState, + tcConfig, + false, + EmptyTopAttrs, + prefix, + isIncrementalFragment, + declaredImpls, + ilxGenerator + ) + + let istate, declaredImpls = + ProcessCodegenResults( + ctok, + diagnosticsLogger, + istate, + optEnv, + istate.tcState, + tcConfig, + prefix, + showTypes, + isIncrementalFragment, + fragName, + declaredImpls, + ilxGenerator, + codegenResults, + m + ) + + let newState = + { istate with + tcState = istate.tcState.NextStateAfterIncrementalFragment tcEnvAtEndOfLastInput + } // Force set the val with the given value obj. let ctxt = valuePrinter.GetEvaluationContext(newState.emEnv) @@ -2257,41 +2997,56 @@ type internal FsiDynamicCompiler( with ex -> istate, CompletedWithReportedError(StopProcessingExn(Some ex)) - member _.GetInitialInteractiveState () = - let tcConfig = TcConfig.Create(tcConfigB,validate=false) - let optEnv0 = GetInitialOptimizationEnv (tcImports, tcGlobals) + member _.GetInitialInteractiveState() = + let tcConfig = TcConfig.Create(tcConfigB, validate = false) + let optEnv0 = GetInitialOptimizationEnv(tcImports, tcGlobals) - let emEnv0 = + let emEnv0 = if tcConfigB.fsiMultiAssemblyEmit then - let emEnv = ILMultiInMemoryAssemblyEmitEnv(ilGlobals, resolveAssemblyRef, dynamicCcuName) + let emEnv = + ILMultiInMemoryAssemblyEmitEnv(ilGlobals, resolveAssemblyRef, dynamicCcuName) + MultipleInMemoryAssemblies emEnv else - let cenv = { ilg = ilGlobals; emitTailcalls = tcConfig.emitTailcalls; generatePdb = generateDebugInfo; resolveAssemblyRef=resolveAssemblyRef; tryFindSysILTypeRef=tcGlobals.TryFindSysILTypeRef } - let emEnv = ILDynamicAssemblyWriter.emEnv0 - SingleRefEmitAssembly (cenv, emEnv) + let cenv = + { + ilg = ilGlobals + emitTailcalls = tcConfig.emitTailcalls + generatePdb = generateDebugInfo + resolveAssemblyRef = resolveAssemblyRef + tryFindSysILTypeRef = tcGlobals.TryFindSysILTypeRef + } - let tcEnv, openDecls0 = GetInitialTcEnv (dynamicCcuName, rangeStdin0, tcConfig, tcImports, tcGlobals) - let ccuName = dynamicCcuName + let emEnv = ILDynamicAssemblyWriter.emEnv0 + SingleRefEmitAssembly(cenv, emEnv) - let tcState = GetInitialTcState (rangeStdin0, ccuName, tcConfig, tcGlobals, tcImports, tcEnv, openDecls0) + let tcEnv, openDecls0 = + GetInitialTcEnv(dynamicCcuName, rangeStdin0, tcConfig, tcImports, tcGlobals) - let ilxGenerator = CreateIlxAssemblyGenerator (tcConfig, tcImports, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), tcState.Ccu) + let ccuName = dynamicCcuName - { optEnv = optEnv0 - emEnv = emEnv0 - tcGlobals = tcGlobals - tcState = tcState - tcImports = tcImports - ilxGenerator = ilxGenerator - boundValues = NameMap.empty - timing = false - debugBreak = false } + let tcState = + GetInitialTcState(rangeStdin0, ccuName, tcConfig, tcGlobals, tcImports, tcEnv, openDecls0) + + let ilxGenerator = + CreateIlxAssemblyGenerator(tcConfig, tcImports, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), tcState.Ccu) + + { + optEnv = optEnv0 + emEnv = emEnv0 + tcGlobals = tcGlobals + tcState = tcState + tcImports = tcImports + ilxGenerator = ilxGenerator + boundValues = NameMap.empty + timing = false + debugBreak = false + } member _.CurrentPartialAssemblySignature(istate) = FSharpAssemblySignature(istate.tcGlobals, istate.tcState.Ccu, istate.tcState.CcuSig, istate.tcImports, None, istate.tcState.CcuSig) - member _.FormatValue(obj:obj, objTy) = - valuePrinter.FormatValue(obj, objTy) + member _.FormatValue(obj: obj, objTy) = valuePrinter.FormatValue(obj, objTy) member _.ValueBound = valueBoundEvent.Publish @@ -2320,18 +3075,20 @@ type internal FsiInterruptControllerKillerThreadRequest = | ExitRequest | PrintInterruptRequest -type internal FsiInterruptController( - fsiOptions: FsiCommandLineOptions, - controlledExecution: ControlledExecution, - fsiConsoleOutput: FsiConsoleOutput) = +type internal FsiInterruptController + ( + fsiOptions: FsiCommandLineOptions, + controlledExecution: ControlledExecution, + fsiConsoleOutput: FsiConsoleOutput + ) = let mutable stdinInterruptState = StdinNormal let CTRL_C = 0 let mutable interruptAllowed = InterruptIgnored let mutable killThreadRequest = NoRequest - let mutable ctrlEventHandlers = []: ControlEventHandler list - let mutable ctrlEventActions = []: (unit -> unit) list + let mutable ctrlEventHandlers: ControlEventHandler list = [] + let mutable ctrlEventActions: (unit -> unit) list = [] let mutable exitViaKillThread = false let mutable posixReinstate = (fun () -> ()) @@ -2340,6 +3097,7 @@ type internal FsiInterruptController( if exitViaKillThread then killThreadRequest <- ExitRequest Thread.Sleep(1000) + exit 0 member _.FsiInterruptStdinState @@ -2351,7 +3109,8 @@ type internal FsiInterruptController( member _.InterruptAllowed with set v = interruptAllowed <- v - member _.Interrupt() = ctrlEventActions |> List.iter (fun act -> act()) + member _.Interrupt() = + ctrlEventActions |> List.iter (fun act -> act ()) member _.EventHandlers = ctrlEventHandlers @@ -2363,48 +3122,70 @@ type internal FsiInterruptController( let pauseMilliseconds = (if fsiOptions.Gui then 400 else 100) // Fsi Interrupt handler - let raiseCtrlC() = + let raiseCtrlC () = use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID - fprintf fsiConsoleOutput.Error "%s" (FSIstrings.SR.fsiInterrupt()) + fprintf fsiConsoleOutput.Error "%s" (FSIstrings.SR.fsiInterrupt ()) stdinInterruptState <- StdinEOFPermittedBecauseCtrlCRecentlyPressed + if interruptAllowed = InterruptCanRaiseException then killThreadRequest <- ThreadAbortRequest + let killerThread = - Thread(ThreadStart(fun () -> - use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID - // sleep long enough to allow ControlEventHandler handler on main thread to return - // Also sleep to give computations a bit of time to terminate - Thread.Sleep(pauseMilliseconds) - if killThreadRequest = ThreadAbortRequest then - if progress then fsiConsoleOutput.uprintnfn "%s" (FSIstrings.SR.fsiAbortingMainThread()) - killThreadRequest <- NoRequest - controlledExecution.TryAbort() - ()), Name="ControlCAbortThread") + Thread( + ThreadStart(fun () -> + use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID + // sleep long enough to allow ControlEventHandler handler on main thread to return + // Also sleep to give computations a bit of time to terminate + Thread.Sleep(pauseMilliseconds) + + if killThreadRequest = ThreadAbortRequest then + if progress then + fsiConsoleOutput.uprintnfn "%s" (FSIstrings.SR.fsiAbortingMainThread ()) + + killThreadRequest <- NoRequest + controlledExecution.TryAbort() + + ()), + Name = "ControlCAbortThread" + ) + killerThread.IsBackground <- true killerThread.Start() - let fsiInterruptHandler (args:ConsoleCancelEventArgs) = + let fsiInterruptHandler (args: ConsoleCancelEventArgs) = args.Cancel <- true - ctrlEventHandlers |> List.iter(fun handler -> handler.Invoke(CTRL_C) |> ignore) + ctrlEventHandlers |> List.iter (fun handler -> handler.Invoke(CTRL_C) |> ignore) do Console.CancelKeyPress.Add(fsiInterruptHandler) // WINDOWS TECHNIQUE: .NET has more safe points, and you can do more when a safe point. // Hence we actually start up the killer thread within the handler. - let ctrlEventHandler = ControlEventHandler(fun i -> if i = CTRL_C then (raiseCtrlC(); true) else false ) + let ctrlEventHandler = + ControlEventHandler(fun i -> + if i = CTRL_C then + (raiseCtrlC () + true) + else + false) + ctrlEventHandlers <- ctrlEventHandler :: ctrlEventHandlers - ctrlEventActions <- raiseCtrlC :: ctrlEventActions + ctrlEventActions <- raiseCtrlC :: ctrlEventActions exitViaKillThread <- false // don't exit via kill thread - member _.PosixInvoke(n:int) = + member _.PosixInvoke(n: int) = // we run this code once with n = -1 to make sure it is JITted before execution begins // since we are not allowed to JIT a signal handler. This also ensures the "PosixInvoke" // method is not eliminated by dead-code elimination if n >= 0 then - posixReinstate() + posixReinstate () stdinInterruptState <- StdinEOFPermittedBecauseCtrlCRecentlyPressed - killThreadRequest <- if (interruptAllowed = InterruptCanRaiseException) then ThreadAbortRequest else PrintInterruptRequest + + killThreadRequest <- + if (interruptAllowed = InterruptCanRaiseException) then + ThreadAbortRequest + else + PrintInterruptRequest //---------------------------------------------------------------------------- // assembly finder @@ -2453,109 +3234,163 @@ type internal FsiInterruptController( // // For information about contexts, see the Assembly.LoadFrom(String) method overload. -type internal MagicAssemblyResolution () = +type internal MagicAssemblyResolution() = // See bug 5501 for details on decision to use UnsafeLoadFrom here. // Summary: // It is an explicit user trust decision to load an assembly with #r. Scripts are not run automatically (for example, by double-clicking in explorer). // We considered setting loadFromRemoteSources in fsi.exe.config but this would transitively confer unsafe loading to the code in the referenced // assemblies. Better to let those assemblies decide for themselves which is safer. - static let assemblyLoadFrom (path:string) = Assembly.UnsafeLoadFrom(path) - - static member private ResolveAssemblyCore (ctok, m, tcConfigB, tcImports: TcImports, fsiDynamicCompiler: FsiDynamicCompiler, fsiConsoleOutput: FsiConsoleOutput, fullAssemName: string) = + static let assemblyLoadFrom (path: string) = Assembly.UnsafeLoadFrom(path) + + static member private ResolveAssemblyCore + ( + ctok, + m, + tcConfigB, + tcImports: TcImports, + fsiDynamicCompiler: FsiDynamicCompiler, + fsiConsoleOutput: FsiConsoleOutput, + fullAssemName: string + ) = try // Grab the name of the assembly - let tcConfig = TcConfig.Create(tcConfigB,validate=false) + let tcConfig = TcConfig.Create(tcConfigB, validate = false) let simpleAssemName = fullAssemName.Split([| ',' |]).[0] - if progress then fsiConsoleOutput.uprintfn "ATTEMPT MAGIC LOAD ON ASSEMBLY, simpleAssemName = %s" simpleAssemName // "Attempting to load a dynamically required assembly in response to an AssemblyResolve event by using known static assembly references..." - if simpleAssemName.EndsWith(".XmlSerializers", StringComparison.OrdinalIgnoreCase) || - simpleAssemName = "UIAutomationWinforms" then null + if progress then + fsiConsoleOutput.uprintfn "ATTEMPT MAGIC LOAD ON ASSEMBLY, simpleAssemName = %s" simpleAssemName // "Attempting to load a dynamically required assembly in response to an AssemblyResolve event by using known static assembly references..." + + if + simpleAssemName.EndsWith(".XmlSerializers", StringComparison.OrdinalIgnoreCase) + || simpleAssemName = "UIAutomationWinforms" + then + null else // Check dynamic assemblies by exact version match fsiDynamicCompiler.FindDynamicAssembly(fullAssemName, true) with | Some asm -> asm | None -> - // Check dynamic assemblies by simple name - match fsiDynamicCompiler.FindDynamicAssembly(simpleAssemName, false) with - | Some asm -> asm - | None -> - - - // Otherwise continue - let assemblyReferenceTextDll = (simpleAssemName + ".dll") - let assemblyReferenceTextExe = (simpleAssemName + ".exe") - let overallSearchResult = - - // OK, try to resolve as an existing DLL in the resolved reference set. This does unification by assembly name - // once an assembly has been referenced. - let searchResult = tcImports.TryFindExistingFullyQualifiedPathBySimpleAssemblyName simpleAssemName + // Check dynamic assemblies by simple name + match fsiDynamicCompiler.FindDynamicAssembly(simpleAssemName, false) with + | Some asm -> asm + | None -> - match searchResult with - | Some r -> OkResult ([], Choice1Of2 r) - | _ -> + // Otherwise continue + let assemblyReferenceTextDll = (simpleAssemName + ".dll") + let assemblyReferenceTextExe = (simpleAssemName + ".exe") - // OK, try to resolve as a .dll - let searchResult = tcImports.TryResolveAssemblyReference (ctok, AssemblyReference (m, assemblyReferenceTextDll, None), ResolveAssemblyReferenceMode.Speculative) + let overallSearchResult = - match searchResult with - | OkResult (warns,[r]) -> OkResult (warns, Choice1Of2 r.resolvedPath) - | _ -> + // OK, try to resolve as an existing DLL in the resolved reference set. This does unification by assembly name + // once an assembly has been referenced. + let searchResult = + tcImports.TryFindExistingFullyQualifiedPathBySimpleAssemblyName simpleAssemName - // OK, try to resolve as a .exe - let searchResult = tcImports.TryResolveAssemblyReference (ctok, AssemblyReference (m, assemblyReferenceTextExe, None), ResolveAssemblyReferenceMode.Speculative) + match searchResult with + | Some r -> OkResult([], Choice1Of2 r) + | _ -> - match searchResult with - | OkResult (warns, [r]) -> OkResult (warns, Choice1Of2 r.resolvedPath) - | _ -> - - if progress then fsiConsoleOutput.uprintfn "ATTEMPT LOAD, assemblyReferenceTextDll = %s" assemblyReferenceTextDll - /// Take a look through the files quoted, perhaps with explicit paths - let searchResult = - tcConfig.referencedDLLs |> List.tryPick (fun assemblyReference -> - if progress then fsiConsoleOutput.uprintfn "ATTEMPT MAGIC LOAD ON FILE, referencedDLL = %s" assemblyReference.Text - if String.Compare(FileSystemUtils.fileNameOfPath assemblyReference.Text, assemblyReferenceTextDll,StringComparison.OrdinalIgnoreCase) = 0 || - String.Compare(FileSystemUtils.fileNameOfPath assemblyReference.Text, assemblyReferenceTextExe,StringComparison.OrdinalIgnoreCase) = 0 then - Some(tcImports.TryResolveAssemblyReference (ctok, assemblyReference, ResolveAssemblyReferenceMode.Speculative)) - else None) - - match searchResult with - | Some (OkResult (warns,[r])) -> OkResult (warns, Choice1Of2 r.resolvedPath) - | _ -> + // OK, try to resolve as a .dll + let searchResult = + tcImports.TryResolveAssemblyReference( + ctok, + AssemblyReference(m, assemblyReferenceTextDll, None), + ResolveAssemblyReferenceMode.Speculative + ) + + match searchResult with + | OkResult (warns, [ r ]) -> OkResult(warns, Choice1Of2 r.resolvedPath) + | _ -> + + // OK, try to resolve as a .exe + let searchResult = + tcImports.TryResolveAssemblyReference( + ctok, + AssemblyReference(m, assemblyReferenceTextExe, None), + ResolveAssemblyReferenceMode.Speculative + ) + + match searchResult with + | OkResult (warns, [ r ]) -> OkResult(warns, Choice1Of2 r.resolvedPath) + | _ -> + + if progress then + fsiConsoleOutput.uprintfn "ATTEMPT LOAD, assemblyReferenceTextDll = %s" assemblyReferenceTextDll + + /// Take a look through the files quoted, perhaps with explicit paths + let searchResult = + tcConfig.referencedDLLs + |> List.tryPick (fun assemblyReference -> + if progress then + fsiConsoleOutput.uprintfn + "ATTEMPT MAGIC LOAD ON FILE, referencedDLL = %s" + assemblyReference.Text + + if + String.Compare( + FileSystemUtils.fileNameOfPath assemblyReference.Text, + assemblyReferenceTextDll, + StringComparison.OrdinalIgnoreCase + ) = 0 + || String.Compare( + FileSystemUtils.fileNameOfPath assemblyReference.Text, + assemblyReferenceTextExe, + StringComparison.OrdinalIgnoreCase + ) = 0 + then + Some( + tcImports.TryResolveAssemblyReference( + ctok, + assemblyReference, + ResolveAssemblyReferenceMode.Speculative + ) + ) + else + None) + + match searchResult with + | Some (OkResult (warns, [ r ])) -> OkResult(warns, Choice1Of2 r.resolvedPath) + | _ -> #if !NO_TYPEPROVIDERS - match tcImports.TryFindProviderGeneratedAssemblyByName(ctok, simpleAssemName) with - | Some assembly -> OkResult([],Choice2Of2 assembly) - | None -> + match tcImports.TryFindProviderGeneratedAssemblyByName(ctok, simpleAssemName) with + | Some assembly -> OkResult([], Choice2Of2 assembly) + | None -> #endif - // As a last resort, try to find the reference without an extension - match tcImports.TryFindExistingFullyQualifiedPathByExactAssemblyRef(ILAssemblyRef.Create(simpleAssemName,None,None,false,None,None)) with - | Some resolvedPath -> - OkResult([],Choice1Of2 resolvedPath) - | None -> - - ErrorResult([],Failure (FSIstrings.SR.fsiFailedToResolveAssembly(simpleAssemName))) - - match overallSearchResult with - | ErrorResult _ -> null - | OkResult _ -> - let res = CommitOperationResult overallSearchResult - match res with - | Choice1Of2 assemblyName -> - if simpleAssemName <> "Mono.Posix" && progress then fsiConsoleOutput.uprintfn "%s" (FSIstrings.SR.fsiBindingSessionTo(assemblyName)) - if isRunningOnCoreClr then - assemblyLoadFrom assemblyName - else - try - let an = AssemblyName.GetAssemblyName(assemblyName) - an.CodeBase <- assemblyName - Assembly.Load an - with _ -> - assemblyLoadFrom assemblyName - | Choice2Of2 assembly -> - assembly + // As a last resort, try to find the reference without an extension + match + tcImports.TryFindExistingFullyQualifiedPathByExactAssemblyRef( + ILAssemblyRef.Create(simpleAssemName, None, None, false, None, None) + ) + with + | Some resolvedPath -> OkResult([], Choice1Of2 resolvedPath) + | None -> + + ErrorResult([], Failure(FSIstrings.SR.fsiFailedToResolveAssembly (simpleAssemName))) + + match overallSearchResult with + | ErrorResult _ -> null + | OkResult _ -> + let res = CommitOperationResult overallSearchResult + + match res with + | Choice1Of2 assemblyName -> + if simpleAssemName <> "Mono.Posix" && progress then + fsiConsoleOutput.uprintfn "%s" (FSIstrings.SR.fsiBindingSessionTo (assemblyName)) + + if isRunningOnCoreClr then + assemblyLoadFrom assemblyName + else + try + let an = AssemblyName.GetAssemblyName(assemblyName) + an.CodeBase <- assemblyName + Assembly.Load an + with _ -> + assemblyLoadFrom assemblyName + | Choice2Of2 assembly -> assembly with e -> stopProcessingRecovery e range0 @@ -2564,7 +3399,16 @@ type internal MagicAssemblyResolution () = [] static val mutable private resolving: bool - static member private ResolveAssembly (ctok, m, tcConfigB, tcImports: TcImports, fsiDynamicCompiler: FsiDynamicCompiler, fsiConsoleOutput: FsiConsoleOutput, fullAssemName: string) = + static member private ResolveAssembly + ( + ctok, + m, + tcConfigB, + tcImports: TcImports, + fsiDynamicCompiler: FsiDynamicCompiler, + fsiConsoleOutput: FsiConsoleOutput, + fullAssemName: string + ) = //Eliminate recursive calls to Resolve which can happen via our callout to msbuild resolution if MagicAssemblyResolution.resolving then @@ -2572,7 +3416,16 @@ type internal MagicAssemblyResolution () = else try MagicAssemblyResolution.resolving <- true - MagicAssemblyResolution.ResolveAssemblyCore (ctok, m, tcConfigB, tcImports, fsiDynamicCompiler, fsiConsoleOutput, fullAssemName) + + MagicAssemblyResolution.ResolveAssemblyCore( + ctok, + m, + tcConfigB, + tcImports, + fsiDynamicCompiler, + fsiConsoleOutput, + fullAssemName + ) finally MagicAssemblyResolution.resolving <- false @@ -2580,17 +3433,27 @@ type internal MagicAssemblyResolution () = let rangeStdin0 = rangeN stdinMockFileName 0 - let resolveAssembly = ResolveEventHandler(fun _ args -> - // Explanation: our understanding is that magic assembly resolution happens - // during compilation. So we recover the CompilationThreadToken here. - let ctok = AssumeCompilationThreadWithoutEvidence () - MagicAssemblyResolution.ResolveAssembly (ctok, rangeStdin0, tcConfigB, tcImports, fsiDynamicCompiler, fsiConsoleOutput, args.Name)) + let resolveAssembly = + ResolveEventHandler(fun _ args -> + // Explanation: our understanding is that magic assembly resolution happens + // during compilation. So we recover the CompilationThreadToken here. + let ctok = AssumeCompilationThreadWithoutEvidence() - AppDomain.CurrentDomain.add_AssemblyResolve(resolveAssembly) + MagicAssemblyResolution.ResolveAssembly( + ctok, + rangeStdin0, + tcConfigB, + tcImports, + fsiDynamicCompiler, + fsiConsoleOutput, + args.Name + )) + + AppDomain.CurrentDomain.add_AssemblyResolve (resolveAssembly) { new IDisposable with member _.Dispose() = - AppDomain.CurrentDomain.remove_AssemblyResolve(resolveAssembly) + AppDomain.CurrentDomain.remove_AssemblyResolve (resolveAssembly) } //---------------------------------------------------------------------------- @@ -2599,7 +3462,8 @@ type internal MagicAssemblyResolution () = type FsiStdinLexerProvider ( - tcConfigB, fsiStdinSyphon, + tcConfigB, + fsiStdinSyphon, fsiConsoleInput: FsiConsoleInput, fsiConsoleOutput: FsiConsoleOutput, fsiOptions: FsiCommandLineOptions, @@ -2608,50 +3472,76 @@ type FsiStdinLexerProvider // #light is the default for FSI let indentationSyntaxStatus = - let initialIndentationAwareSyntaxStatus = (tcConfigB.indentationAwareSyntax <> Some false) - IndentationAwareSyntaxStatus (initialIndentationAwareSyntaxStatus, warn=false) + let initialIndentationAwareSyntaxStatus = + (tcConfigB.indentationAwareSyntax <> Some false) + + IndentationAwareSyntaxStatus(initialIndentationAwareSyntaxStatus, warn = false) let LexbufFromLineReader (fsiStdinSyphon: FsiStdinSyphon) readF = - UnicodeLexing.FunctionAsLexbuf - (true, tcConfigB.langVersion, (fun (buf: char[], start, len) -> - //fprintf fsiConsoleOutput.Out "Calling ReadLine\n" - let inputOption = try Some(readF()) with :? EndOfStreamException -> None - inputOption |> Option.iter (fun t -> fsiStdinSyphon.Add (t + "\n")) - match inputOption with - | Some null | None -> - if progress then fprintfn fsiConsoleOutput.Out "End of file from TextReader.ReadLine" - 0 - | Some (input: string) -> - let input = input + "\n" + UnicodeLexing.FunctionAsLexbuf( + true, + tcConfigB.langVersion, + (fun (buf: char[], start, len) -> + //fprintf fsiConsoleOutput.Out "Calling ReadLine\n" + let inputOption = + try + Some(readF ()) + with :? EndOfStreamException -> + None + + inputOption |> Option.iter (fun t -> fsiStdinSyphon.Add(t + "\n")) - if input.Length > len then - fprintf fsiConsoleOutput.Error "%s" (FSIstrings.SR.fsiLineTooLong()) + match inputOption with + | Some null + | None -> + if progress then + fprintfn fsiConsoleOutput.Out "End of file from TextReader.ReadLine" - let numTrimmed = min len input.Length + 0 + | Some (input: string) -> + let input = input + "\n" - for i = 0 to numTrimmed-1 do - buf[i+start] <- input[i] + if input.Length > len then + fprintf fsiConsoleOutput.Error "%s" (FSIstrings.SR.fsiLineTooLong ()) - numTrimmed - )) + let numTrimmed = min len input.Length + + for i = 0 to numTrimmed - 1 do + buf[i + start] <- input[i] + + numTrimmed) + ) //---------------------------------------------------------------------------- // Reading stdin as a lex stream //---------------------------------------------------------------------------- - let removeZeroCharsFromString (str:string) = + let removeZeroCharsFromString (str: string) = if str <> null && str.Contains("\000") then - String(str |> Seq.filter (fun c -> c<>'\000') |> Seq.toArray) + String(str |> Seq.filter (fun c -> c <> '\000') |> Seq.toArray) else - str + str let CreateLexerForLexBuffer (sourceFileName, lexbuf, diagnosticsLogger) = resetLexbufPos sourceFileName lexbuf - let skip = true // don't report whitespace from lexer + let skip = true // don't report whitespace from lexer let applyLineDirectives = true - let lexargs = mkLexargs (tcConfigB.conditionalDefines, indentationSyntaxStatus, lexResourceManager, [], diagnosticsLogger, PathMap.empty, applyLineDirectives) - let tokenizer = LexFilter.LexFilter(indentationSyntaxStatus, tcConfigB.compilingFSharpCore, Lexer.token lexargs skip, lexbuf) + + let lexargs = + mkLexargs ( + tcConfigB.conditionalDefines, + indentationSyntaxStatus, + lexResourceManager, + [], + diagnosticsLogger, + PathMap.empty, + applyLineDirectives + ) + + let tokenizer = + LexFilter.LexFilter(indentationSyntaxStatus, tcConfigB.compilingFSharpCore, Lexer.token lexargs skip, lexbuf) + tokenizer // Create a new lexer to read stdin @@ -2662,27 +3552,26 @@ type FsiStdinLexerProvider LexbufFromLineReader fsiStdinSyphon (fun () -> match fsiConsoleInput.TryGetFirstLine() with | Some firstLine -> firstLine - | None -> console()) - | _ -> - LexbufFromLineReader fsiStdinSyphon (fun () -> fsiConsoleInput.In.ReadLine() |> removeZeroCharsFromString) + | None -> console ()) + | _ -> LexbufFromLineReader fsiStdinSyphon (fun () -> fsiConsoleInput.In.ReadLine() |> removeZeroCharsFromString) fsiStdinSyphon.Reset() - CreateLexerForLexBuffer (stdinMockFileName, lexbuf, diagnosticsLogger) + CreateLexerForLexBuffer(stdinMockFileName, lexbuf, diagnosticsLogger) // Create a new lexer to read an "included" script file - member _.CreateIncludedScriptLexer (sourceFileName, reader, diagnosticsLogger) = + member _.CreateIncludedScriptLexer(sourceFileName, reader, diagnosticsLogger) = let lexbuf = UnicodeLexing.StreamReaderAsLexbuf(true, tcConfigB.langVersion, reader) - CreateLexerForLexBuffer (sourceFileName, lexbuf, diagnosticsLogger) + CreateLexerForLexBuffer(sourceFileName, lexbuf, diagnosticsLogger) // Create a new lexer to read a string - member _.CreateStringLexer (sourceFileName, source, diagnosticsLogger) = + member _.CreateStringLexer(sourceFileName, source, diagnosticsLogger) = let lexbuf = UnicodeLexing.StringAsLexbuf(true, tcConfigB.langVersion, source) - CreateLexerForLexBuffer (sourceFileName, lexbuf, diagnosticsLogger) + CreateLexerForLexBuffer(sourceFileName, lexbuf, diagnosticsLogger) member _.ConsoleInput = fsiConsoleInput - member _.CreateBufferLexer (sourceFileName, lexbuf, diagnosticsLogger) = - CreateLexerForLexBuffer (sourceFileName, lexbuf, diagnosticsLogger) + member _.CreateBufferLexer(sourceFileName, lexbuf, diagnosticsLogger) = + CreateLexerForLexBuffer(sourceFileName, lexbuf, diagnosticsLogger) [] type InteractionGroup = @@ -2701,21 +3590,24 @@ type FsiInteractionProcessor tcConfigB, fsiOptions: FsiCommandLineOptions, fsiDynamicCompiler: FsiDynamicCompiler, - fsiConsolePrompt : FsiConsolePrompt, - fsiConsoleOutput : FsiConsoleOutput, - fsiInterruptController : FsiInterruptController, - fsiStdinLexerProvider : FsiStdinLexerProvider, - lexResourceManager : LexResourceManager, + fsiConsolePrompt: FsiConsolePrompt, + fsiConsoleOutput: FsiConsoleOutput, + fsiInterruptController: FsiInterruptController, + fsiStdinLexerProvider: FsiStdinLexerProvider, + lexResourceManager: LexResourceManager, initialInteractiveState ) = let mutable currState = initialInteractiveState let event = Control.Event() - let setCurrState s = currState <- s; event.Trigger() + + let setCurrState s = + currState <- s + event.Trigger() let runCodeOnEventLoop diagnosticsLogger f istate = try - fsi.EventLoopInvoke (fun () -> + fsi.EventLoopInvoke(fun () -> // Explanation: We assume the event loop on the 'fsi' object correctly transfers control to // a unique compilation thread. @@ -2726,35 +3618,38 @@ type FsiInteractionProcessor use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID f ctok istate) with _ -> - (istate,Completed None) + (istate, Completed None) - let InteractiveCatch (diagnosticsLogger: DiagnosticsLogger) (f:_ -> _ * FsiInteractionStepStatus) istate = + let InteractiveCatch (diagnosticsLogger: DiagnosticsLogger) (f: _ -> _ * FsiInteractionStepStatus) istate = try // reset error count match diagnosticsLogger with - | :? DiagnosticsLoggerThatStopsOnFirstError as diagnosticsLogger -> diagnosticsLogger.ResetErrorCount() + | :? DiagnosticsLoggerThatStopsOnFirstError as diagnosticsLogger -> diagnosticsLogger.ResetErrorCount() | _ -> () f istate - with e -> + with e -> stopProcessingRecovery e range0 istate, CompletedWithReportedError e let rangeStdin0 = rangeN stdinMockFileName 0 - let ChangeDirectory (path:string) m = - let tcConfig = TcConfig.Create(tcConfigB,validate=false) + let ChangeDirectory (path: string) m = + let tcConfig = TcConfig.Create(tcConfigB, validate = false) let path = tcConfig.MakePathAbsolute path + if FileSystem.DirectoryExistsShim(path) then tcConfigB.implicitIncludeDir <- path else - error(Error(FSIstrings.SR.fsiDirectoryDoesNotExist(path),m)) + error (Error(FSIstrings.SR.fsiDirectoryDoesNotExist (path), m)) /// Parse one interaction. Called on the parser thread. - let ParseInteraction (tokenizer:LexFilter.LexFilter) = + let ParseInteraction (tokenizer: LexFilter.LexFilter) = let mutable lastToken = Parser.ELSE // Any token besides SEMICOLON_SEMICOLON will do for initial value + try - if progress then fprintfn fsiConsoleOutput.Out "In ParseInteraction..." + if progress then + fprintfn fsiConsoleOutput.Out "In ParseInteraction..." let input = reusingLexbufForParsing tokenizer.LexBuffer (fun () -> @@ -2762,15 +3657,24 @@ type FsiInteractionProcessor let tok = tokenizer.GetToken() lastToken <- tok tok + Parser.interaction lexerWhichSavesLastToken tokenizer.LexBuffer) + Some input with e -> // On error, consume tokens until to ;; or EOF. // Caveat: Unless the error parse ended on ;; - so check the lastToken returned by the lexer function. // Caveat: What if this was a look-ahead? That's fine! Since we need to skip to the ;; anyway. - if (match lastToken with Parser.SEMICOLON_SEMICOLON -> false | _ -> true) then + if + (match lastToken with + | Parser.SEMICOLON_SEMICOLON -> false + | _ -> true) + then let mutable tok = Parser.ELSE (* <-- any token <> SEMICOLON_SEMICOLON will do *) - while (match tok with Parser.SEMICOLON_SEMICOLON -> false | _ -> true) + + while (match tok with + | Parser.SEMICOLON_SEMICOLON -> false + | _ -> true) && not tokenizer.LexBuffer.IsPastEndOfStream do tok <- tokenizer.GetToken() @@ -2780,94 +3684,101 @@ type FsiInteractionProcessor /// Partially process a hash directive, leaving state in packageManagerLines and required assemblies let PartiallyProcessHashDirective (ctok, istate, hash, diagnosticsLogger: DiagnosticsLogger) = match hash with - | ParsedHashDirective("load", ParsedHashDirectiveArguments sourceFiles, m) -> - let istate = fsiDynamicCompiler.EvalSourceFiles (ctok, istate, m, sourceFiles, lexResourceManager, diagnosticsLogger) + | ParsedHashDirective ("load", ParsedHashDirectiveArguments sourceFiles, m) -> + let istate = + fsiDynamicCompiler.EvalSourceFiles(ctok, istate, m, sourceFiles, lexResourceManager, diagnosticsLogger) + istate, Completed None - | ParsedHashDirective(("reference" | "r"), ParsedHashDirectiveArguments [path], m) -> - fsiDynamicCompiler.PartiallyProcessReferenceOrPackageIncudePathDirective (ctok, istate, Directive.Resolution, path, true, m) + | ParsedHashDirective (("reference" | "r"), ParsedHashDirectiveArguments [ path ], m) -> + fsiDynamicCompiler.PartiallyProcessReferenceOrPackageIncudePathDirective(ctok, istate, Directive.Resolution, path, true, m) - | ParsedHashDirective("i", ParsedHashDirectiveArguments [path], m) -> - fsiDynamicCompiler.PartiallyProcessReferenceOrPackageIncudePathDirective (ctok, istate, Directive.Include, path, true, m) + | ParsedHashDirective ("i", ParsedHashDirectiveArguments [ path ], m) -> + fsiDynamicCompiler.PartiallyProcessReferenceOrPackageIncudePathDirective(ctok, istate, Directive.Include, path, true, m) - | ParsedHashDirective("I", ParsedHashDirectiveArguments [path], m) -> - tcConfigB.AddIncludePath (m, path, tcConfigB.implicitIncludeDir) - let tcConfig = TcConfig.Create(tcConfigB,validate=false) - fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiDidAHashI(tcConfig.MakePathAbsolute path)) + | ParsedHashDirective ("I", ParsedHashDirectiveArguments [ path ], m) -> + tcConfigB.AddIncludePath(m, path, tcConfigB.implicitIncludeDir) + let tcConfig = TcConfig.Create(tcConfigB, validate = false) + fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiDidAHashI (tcConfig.MakePathAbsolute path)) istate, Completed None - | ParsedHashDirective("cd", ParsedHashDirectiveArguments [path], m) -> + | ParsedHashDirective ("cd", ParsedHashDirectiveArguments [ path ], m) -> ChangeDirectory path m istate, Completed None - | ParsedHashDirective("silentCd", ParsedHashDirectiveArguments [path], m) -> + | ParsedHashDirective ("silentCd", ParsedHashDirectiveArguments [ path ], m) -> ChangeDirectory path m fsiConsolePrompt.SkipNext() (* "silent" directive *) istate, Completed None - | ParsedHashDirective("interactiveprompt", ParsedHashDirectiveArguments ["show" | "hide" | "skip" as showPrompt], m) -> + | ParsedHashDirective ("interactiveprompt", ParsedHashDirectiveArguments [ "show" | "hide" | "skip" as showPrompt ], m) -> match showPrompt with | "show" -> fsiConsolePrompt.ShowPrompt <- true | "hide" -> fsiConsolePrompt.ShowPrompt <- false | "skip" -> fsiConsolePrompt.SkipNext() - | _ -> error(Error((FSComp.SR.fsiInvalidDirective("prompt", String.concat " " [showPrompt])), m)) + | _ -> error (Error((FSComp.SR.fsiInvalidDirective ("prompt", String.concat " " [ showPrompt ])), m)) istate, Completed None - | ParsedHashDirective("dbgbreak", [], _) -> - let istate = {istate with debugBreak = true} + | ParsedHashDirective ("dbgbreak", [], _) -> + let istate = { istate with debugBreak = true } istate, Completed None - | ParsedHashDirective("time", [], _) -> + | ParsedHashDirective ("time", [], _) -> if istate.timing then - fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiTurnedTimingOff()) + fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiTurnedTimingOff ()) else - fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiTurnedTimingOn()) - let istate = {istate with timing = not istate.timing} + fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiTurnedTimingOn ()) + + let istate = + { istate with + timing = not istate.timing + } + istate, Completed None - | ParsedHashDirective("time", ParsedHashDirectiveArguments ["on" | "off" as v], _) -> + | ParsedHashDirective ("time", ParsedHashDirectiveArguments [ "on" | "off" as v ], _) -> if v <> "on" then - fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiTurnedTimingOff()) + fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiTurnedTimingOff ()) else - fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiTurnedTimingOn()) - let istate = {istate with timing = (v = "on")} + fsiConsoleOutput.uprintnfnn "%s" (FSIstrings.SR.fsiTurnedTimingOn ()) + + let istate = { istate with timing = (v = "on") } istate, Completed None - | ParsedHashDirective("nowarn", ParsedHashDirectiveArguments numbers, m) -> - List.iter (fun (d:string) -> tcConfigB.TurnWarningOff(m, d)) numbers + | ParsedHashDirective ("nowarn", ParsedHashDirectiveArguments numbers, m) -> + List.iter (fun (d: string) -> tcConfigB.TurnWarningOff(m, d)) numbers istate, Completed None - | ParsedHashDirective("terms", [], _) -> + | ParsedHashDirective ("terms", [], _) -> tcConfigB.showTerms <- not tcConfigB.showTerms istate, Completed None - | ParsedHashDirective("types", [], _) -> + | ParsedHashDirective ("types", [], _) -> fsiOptions.ShowTypes <- not fsiOptions.ShowTypes istate, Completed None #if DEBUG - | ParsedHashDirective("ilcode", [], _m) -> - fsiOptions.ShowILCode <- not fsiOptions.ShowILCode; + | ParsedHashDirective ("ilcode", [], _m) -> + fsiOptions.ShowILCode <- not fsiOptions.ShowILCode istate, Completed None - | ParsedHashDirective("info", [], _m) -> + | ParsedHashDirective ("info", [], _m) -> PrintOptionInfo tcConfigB istate, Completed None #endif - | ParsedHashDirective(("clear"), [], _) -> + | ParsedHashDirective (("clear"), [], _) -> fsiOptions.ClearScreen() istate, Completed None - - | ParsedHashDirective(("q" | "quit"), [], _) -> - fsiInterruptController.Exit() - | ParsedHashDirective("help", [], m) -> + | ParsedHashDirective (("q" | "quit"), [], _) -> fsiInterruptController.Exit() + + | ParsedHashDirective ("help", [], m) -> fsiOptions.ShowHelp(m) istate, Completed None - | ParsedHashDirective(c, ParsedHashDirectiveArguments arg, m) -> - warning(Error((FSComp.SR.fsiInvalidDirective(c, String.concat " " arg)), m)) + | ParsedHashDirective (c, ParsedHashDirectiveArguments arg, m) -> + warning (Error((FSComp.SR.fsiInvalidDirective (c, String.concat " " arg)), m)) istate, Completed None /// Most functions return a step status - this decides whether to continue and propogates the @@ -2877,8 +3788,8 @@ type FsiInteractionProcessor | Completed newResult -> f newResult istate // stop on error | CompletedWithReportedError e -> istate, CompletedWithReportedError e - // stop on error - | CompletedWithAlreadyReportedError -> istate, CompletedWithAlreadyReportedError + // stop on error + | CompletedWithAlreadyReportedError -> istate, CompletedWithAlreadyReportedError // stop on EOF | EndOfFile -> istate, Completed lastResult // stop on CtrlC @@ -2887,7 +3798,8 @@ type FsiInteractionProcessor /// Execute a group of interactions. Called on the GUI/execute/main thread. /// The action is either a group of definitions or a group of hash-references. let ExecuteInteractionGroup (ctok, istate, action: InteractionGroup, diagnosticsLogger: DiagnosticsLogger) = - istate |> InteractiveCatch diagnosticsLogger (fun istate -> + istate + |> InteractiveCatch diagnosticsLogger (fun istate -> let rec loop istate action = // These following actions terminate a dependency manager and/or references group // - nothing left to do @@ -2895,48 +3807,47 @@ type FsiInteractionProcessor // - a #load match action with | InteractionGroup.Definitions _ - | InteractionGroup.HashDirectives [] - | InteractionGroup.HashDirectives (ParsedHashDirective("load", _, _) :: _) -> + | InteractionGroup.HashDirectives [] + | InteractionGroup.HashDirectives (ParsedHashDirective ("load", _, _) :: _) -> if fsiDynamicCompiler.HasDelayedDependencyManagerText then - let istate = fsiDynamicCompiler.ProcessDelayedDependencyManagerText(ctok, istate, lexResourceManager, diagnosticsLogger) + let istate = + fsiDynamicCompiler.ProcessDelayedDependencyManagerText(ctok, istate, lexResourceManager, diagnosticsLogger) + loop istate action elif fsiDynamicCompiler.HasDelayedReferences then - let istate = fsiDynamicCompiler.ProcessDelayedReferences (ctok, istate) + let istate = fsiDynamicCompiler.ProcessDelayedReferences(ctok, istate) loop istate action else match action with | InteractionGroup.Definitions ([], _) - | InteractionGroup.HashDirectives [] -> - istate,Completed None + | InteractionGroup.HashDirectives [] -> istate, Completed None - | InteractionGroup.Definitions ([SynModuleDecl.Expr(expr, _)], _) -> + | InteractionGroup.Definitions ([ SynModuleDecl.Expr (expr, _) ], _) -> fsiDynamicCompiler.EvalParsedExpression(ctok, diagnosticsLogger, istate, expr) - | InteractionGroup.Definitions (defs,_) -> - fsiDynamicCompiler.EvalParsedDefinitions (ctok, diagnosticsLogger, istate, true, false, defs) + | InteractionGroup.Definitions (defs, _) -> + fsiDynamicCompiler.EvalParsedDefinitions(ctok, diagnosticsLogger, istate, true, false, defs) | InteractionGroup.HashDirectives (hash :: rest) -> - let status = PartiallyProcessHashDirective (ctok, istate, hash, diagnosticsLogger) - ProcessStepStatus status None (fun _ istate -> - loop istate (InteractionGroup.HashDirectives rest) - ) + let status = PartiallyProcessHashDirective(ctok, istate, hash, diagnosticsLogger) + ProcessStepStatus status None (fun _ istate -> loop istate (InteractionGroup.HashDirectives rest)) // Other hash directives do not terminate a dependency manager and/or references group | InteractionGroup.HashDirectives (hash :: rest) -> - let status = PartiallyProcessHashDirective (ctok, istate, hash, diagnosticsLogger) - ProcessStepStatus status None (fun _ istate -> - loop istate (InteractionGroup.HashDirectives rest) - ) + let status = PartiallyProcessHashDirective(ctok, istate, hash, diagnosticsLogger) + ProcessStepStatus status None (fun _ istate -> loop istate (InteractionGroup.HashDirectives rest)) - loop istate action - ) + loop istate action) - let isDefHash = function SynModuleDecl.HashDirective _ -> true | _ -> false + let isDefHash = + function + | SynModuleDecl.HashDirective _ -> true + | _ -> false // Only add automatic debugger breaks before 'let' or 'do' expressions with sequence points let isBreakable def = match def with - | SynModuleDecl.Let (bindings=SynBinding(debugPoint=DebugPointAtBinding.Yes _) :: _) -> true + | SynModuleDecl.Let(bindings = SynBinding(debugPoint = DebugPointAtBinding.Yes _) :: _) -> true | _ -> false /// Execute a single parsed interaction which may contain multiple items to be executed @@ -2944,19 +3855,32 @@ type FsiInteractionProcessor /// /// #directive comes through with other definitions as a SynModuleDecl.HashDirective. /// We split these out for individual processing. - let rec ExecuteParsedInteractionInGroups (ctok, istate, synInteraction, diagnosticsLogger: DiagnosticsLogger, lastResult: FsiValue option, cancellationToken: CancellationToken) = + let rec ExecuteParsedInteractionInGroups + ( + ctok, + istate, + synInteraction, + diagnosticsLogger: DiagnosticsLogger, + lastResult: FsiValue option, + cancellationToken: CancellationToken + ) = cancellationToken.ThrowIfCancellationRequested() + let group, others, istate = match synInteraction with - | None -> None,None,istate + | None -> None, None, istate - | Some (ParsedScriptInteraction.Definitions (defs,m)) -> + | Some (ParsedScriptInteraction.Definitions (defs, m)) -> match defs with - | [] -> - None, None, istate + | [] -> None, None, istate | SynModuleDecl.HashDirective _ :: _ -> - let hashes = List.takeWhile isDefHash defs |> List.choose (function (SynModuleDecl.HashDirective(hash, _))-> Some(hash) | _ -> None) + let hashes = + List.takeWhile isDefHash defs + |> List.choose (function + | (SynModuleDecl.HashDirective (hash, _)) -> Some(hash) + | _ -> None) + let defsB = List.skipWhile isDefHash defs let group = InteractionGroup.HashDirectives(hashes) @@ -2971,113 +3895,140 @@ type FsiInteractionProcessor // If user is debugging their script interactively, inject call // to Debugger.Break() at the first "breakable" line. // Update istate so that more Break() calls aren't injected when recursing - let defsA,istate = + let defsA, istate = if istate.debugBreak then let preBreak = Seq.takeWhile (isBreakable >> not) defsA |> Seq.toList let postBreak = Seq.skipWhile (isBreakable >> not) defsA |> Seq.toList + match postBreak with - | h :: _ -> preBreak @ (fsiDynamicCompiler.CreateDebuggerBreak(h.Range) :: postBreak), { istate with debugBreak = false } + | h :: _ -> + preBreak @ (fsiDynamicCompiler.CreateDebuggerBreak(h.Range) :: postBreak), + { istate with debugBreak = false } | _ -> defsA, istate - else defsA,istate + else + defsA, istate // When the last declaration has a shape of DoExp (i.e., non-binding), // transform it to a shape of "let it = ", so we can refer it. let defsA = - if not (isNil defsB) then defsA else - match defsA with - | [] -> defsA - | [_] -> defsA - | _ -> - match List.rev defsA with - | SynModuleDecl.Expr(expr, _) :: rest -> (rest |> List.rev) @ (fsiDynamicCompiler.BuildItBinding expr) - | _ -> defsA - - let group = InteractionGroup.Definitions(defsA,m) - let others = ParsedScriptInteraction.Definitions(defsB,m) - Some group,Some others, istate + if not (isNil defsB) then + defsA + else + match defsA with + | [] -> defsA + | [ _ ] -> defsA + | _ -> + match List.rev defsA with + | SynModuleDecl.Expr (expr, _) :: rest -> (rest |> List.rev) @ (fsiDynamicCompiler.BuildItBinding expr) + | _ -> defsA + + let group = InteractionGroup.Definitions(defsA, m) + let others = ParsedScriptInteraction.Definitions(defsB, m) + Some group, Some others, istate match group with - | None -> - istate, Completed lastResult + | None -> istate, Completed lastResult | Some group -> - let status = ExecuteInteractionGroup (ctok, istate, group, diagnosticsLogger) - ProcessStepStatus status lastResult (fun lastResult istate -> - ExecuteParsedInteractionInGroups (ctok, istate, others, diagnosticsLogger, lastResult, cancellationToken)) + let status = ExecuteInteractionGroup(ctok, istate, group, diagnosticsLogger) + + ProcessStepStatus status lastResult (fun lastResult istate -> + ExecuteParsedInteractionInGroups(ctok, istate, others, diagnosticsLogger, lastResult, cancellationToken)) /// Execute a single parsed interaction which may contain multiple items to be executed /// independently - let ExecuteParsedInteraction (ctok, istate, synInteraction, diagnosticsLogger: DiagnosticsLogger, lastResult: FsiValue option, cancellationToken: CancellationToken) = - let status = ExecuteParsedInteractionInGroups (ctok, istate, synInteraction, diagnosticsLogger, lastResult, cancellationToken) - ProcessStepStatus status lastResult (fun lastResult istate -> + let ExecuteParsedInteraction + ( + ctok, + istate, + synInteraction, + diagnosticsLogger: DiagnosticsLogger, + lastResult: FsiValue option, + cancellationToken: CancellationToken + ) = + let status = + ExecuteParsedInteractionInGroups(ctok, istate, synInteraction, diagnosticsLogger, lastResult, cancellationToken) + + ProcessStepStatus status lastResult (fun lastResult istate -> let rec loop istate = if fsiDynamicCompiler.HasDelayedDependencyManagerText then - let istate = fsiDynamicCompiler.ProcessDelayedDependencyManagerText(ctok, istate, lexResourceManager, diagnosticsLogger) + let istate = + fsiDynamicCompiler.ProcessDelayedDependencyManagerText(ctok, istate, lexResourceManager, diagnosticsLogger) + loop istate elif fsiDynamicCompiler.HasDelayedReferences then - let istate = fsiDynamicCompiler.ProcessDelayedReferences (ctok, istate) + let istate = fsiDynamicCompiler.ProcessDelayedReferences(ctok, istate) loop istate else istate, Completed lastResult + loop istate) /// Execute a single parsed interaction on the parser/execute thread. let mainThreadProcessAction ctok action istate = try let mutable result = Unchecked.defaultof<'a * FsiInteractionStepStatus> - fsiInterruptController.ControlledExecution().Run( - fun () -> - if progress then fprintfn fsiConsoleOutput.Out "In mainThreadProcessAction..." - fsiInterruptController.InterruptAllowed <- InterruptCanRaiseException; - let res = action ctok istate - fsiInterruptController.ClearInterruptRequest() - fsiInterruptController.InterruptAllowed <- InterruptIgnored - result <- res) + + fsiInterruptController + .ControlledExecution() + .Run(fun () -> + if progress then + fprintfn fsiConsoleOutput.Out "In mainThreadProcessAction..." + + fsiInterruptController.InterruptAllowed <- InterruptCanRaiseException + let res = action ctok istate + fsiInterruptController.ClearInterruptRequest() + fsiInterruptController.InterruptAllowed <- InterruptIgnored + result <- res) + result with | :? ThreadAbortException -> fsiInterruptController.ClearInterruptRequest() fsiInterruptController.InterruptAllowed <- InterruptIgnored fsiInterruptController.ControlledExecution().ResetAbort() - (istate,CtrlC) + (istate, CtrlC) - | :? TargetInvocationException as e when (ControlledExecution.StripTargetInvocationException(e)).GetType().Name = "ThreadAbortException" || - (ControlledExecution.StripTargetInvocationException(e)).GetType().Name = "OperationCanceledException" -> + | :? TargetInvocationException as e when + (ControlledExecution.StripTargetInvocationException(e)).GetType().Name = "ThreadAbortException" + || (ControlledExecution.StripTargetInvocationException(e)).GetType().Name = "OperationCanceledException" + -> fsiInterruptController.ClearInterruptRequest() fsiInterruptController.InterruptAllowed <- InterruptIgnored fsiInterruptController.ControlledExecution().ResetAbort() - (istate,CtrlC) + (istate, CtrlC) - | e -> + | e -> fsiInterruptController.ClearInterruptRequest() - fsiInterruptController.InterruptAllowed <- InterruptIgnored; - stopProcessingRecovery e range0; + fsiInterruptController.InterruptAllowed <- InterruptIgnored + stopProcessingRecovery e range0 istate, CompletedWithReportedError e let ExecuteParsedInteractionOnMainThread (ctok, diagnosticsLogger, synInteraction, istate, cancellationToken) = - istate |> mainThreadProcessAction ctok (fun ctok istate -> - ExecuteParsedInteraction (ctok, istate, synInteraction, diagnosticsLogger, None, cancellationToken)) + istate + |> mainThreadProcessAction ctok (fun ctok istate -> + ExecuteParsedInteraction(ctok, istate, synInteraction, diagnosticsLogger, None, cancellationToken)) - let ParseExpression (tokenizer:LexFilter.LexFilter) = + let ParseExpression (tokenizer: LexFilter.LexFilter) = reusingLexbufForParsing tokenizer.LexBuffer (fun () -> Parser.typedSequentialExprEOF (fun _ -> tokenizer.GetToken()) tokenizer.LexBuffer) let ExecuteParsedExpressionOnMainThread (ctok, diagnosticsLogger, expr, istate) = - istate |> InteractiveCatch diagnosticsLogger (fun istate -> - istate |> mainThreadProcessAction ctok (fun ctok istate -> - fsiDynamicCompiler.EvalParsedExpression(ctok, diagnosticsLogger, istate, expr) )) + istate + |> InteractiveCatch diagnosticsLogger (fun istate -> + istate + |> mainThreadProcessAction ctok (fun ctok istate -> + fsiDynamicCompiler.EvalParsedExpression(ctok, diagnosticsLogger, istate, expr))) let commitResult (istate, result) = match result with - | FsiInteractionStepStatus.CtrlC -> Choice2Of2 (Some (OperationCanceledException() :> exn)) - | FsiInteractionStepStatus.EndOfFile -> Choice2Of2 (Some (System.Exception "End of input")) + | FsiInteractionStepStatus.CtrlC -> Choice2Of2(Some(OperationCanceledException() :> exn)) + | FsiInteractionStepStatus.EndOfFile -> Choice2Of2(Some(System.Exception "End of input")) | FsiInteractionStepStatus.Completed res -> setCurrState istate Choice1Of2 res - | FsiInteractionStepStatus.CompletedWithReportedError (StopProcessingExn userExnOpt) -> - Choice2Of2 userExnOpt + | FsiInteractionStepStatus.CompletedWithReportedError (StopProcessingExn userExnOpt) -> Choice2Of2 userExnOpt | FsiInteractionStepStatus.CompletedWithReportedError _ - | FsiInteractionStepStatus.CompletedWithAlreadyReportedError -> - Choice2Of2 None + | FsiInteractionStepStatus.CompletedWithAlreadyReportedError -> Choice2Of2 None /// Parse then process one parsed interaction. /// @@ -3089,95 +4040,140 @@ type FsiInteractionProcessor /// During processing of startup scripts, this runs on the main thread. /// /// This is blocking: it reads until one chunk of input have been received, unless IsPastEndOfStream is true - member _.ParseAndExecuteInteractionFromLexbuf (runCodeOnMainThread, istate:FsiDynamicCompilerState, tokenizer:LexFilter.LexFilter, diagnosticsLogger, ?cancellationToken: CancellationToken) = + member _.ParseAndExecuteInteractionFromLexbuf + ( + runCodeOnMainThread, + istate: FsiDynamicCompilerState, + tokenizer: LexFilter.LexFilter, + diagnosticsLogger, + ?cancellationToken: CancellationToken + ) = let cancellationToken = defaultArg cancellationToken CancellationToken.None + if tokenizer.LexBuffer.IsPastEndOfStream then let stepStatus = if fsiInterruptController.FsiInterruptStdinState = StdinEOFPermittedBecauseCtrlCRecentlyPressed then - fsiInterruptController.FsiInterruptStdinState <- StdinNormal; + fsiInterruptController.FsiInterruptStdinState <- StdinNormal CtrlC else EndOfFile - istate,stepStatus + + istate, stepStatus else fsiConsolePrompt.Print() - istate |> InteractiveCatch diagnosticsLogger (fun istate -> - if progress then fprintfn fsiConsoleOutput.Out "entering ParseInteraction..." + + istate + |> InteractiveCatch diagnosticsLogger (fun istate -> + if progress then + fprintfn fsiConsoleOutput.Out "entering ParseInteraction..." // Parse the interaction. When FSI.EXE is waiting for input from the console the // parser thread is blocked somewhere deep this call. let action = ParseInteraction tokenizer - if progress then fprintfn fsiConsoleOutput.Out "returned from ParseInteraction...calling runCodeOnMainThread..." + if progress then + fprintfn fsiConsoleOutput.Out "returned from ParseInteraction...calling runCodeOnMainThread..." // After we've unblocked and got something to run we switch // over to the run-thread (e.g. the GUI thread) - let res = istate |> runCodeOnMainThread (fun ctok istate -> ExecuteParsedInteractionOnMainThread (ctok, diagnosticsLogger, action, istate, cancellationToken)) + let res = + istate + |> runCodeOnMainThread (fun ctok istate -> + ExecuteParsedInteractionOnMainThread(ctok, diagnosticsLogger, action, istate, cancellationToken)) + + if progress then + fprintfn fsiConsoleOutput.Out "Just called runCodeOnMainThread, res = %O..." res - if progress then fprintfn fsiConsoleOutput.Out "Just called runCodeOnMainThread, res = %O..." res res) member _.CurrentState = currState /// Perform an "include" on a script file (i.e. a script file specified on the command line) - member processor.EvalIncludedScript (ctok, istate, sourceFile, m, diagnosticsLogger) = - let tcConfig = TcConfig.Create(tcConfigB, validate=false) + member processor.EvalIncludedScript(ctok, istate, sourceFile, m, diagnosticsLogger) = + let tcConfig = TcConfig.Create(tcConfigB, validate = false) // Resolve the file name to an absolute file name - let sourceFile = tcConfig.ResolveSourceFile(m, sourceFile, tcConfig.implicitIncludeDir) + let sourceFile = + tcConfig.ResolveSourceFile(m, sourceFile, tcConfig.implicitIncludeDir) // During the processing of the file, further filenames are // resolved relative to the home directory of the loaded file. - WithImplicitHome (tcConfigB, directoryName sourceFile) (fun () -> + WithImplicitHome (tcConfigB, directoryName sourceFile) (fun () -> // An included script file may parse several interaction blocks. // We repeatedly parse and process these, until an error occurs. use fileStream = FileSystem.OpenFileForReadShim(sourceFile) use reader = fileStream.GetReader(tcConfigB.inputCodePage, false) - let tokenizer = fsiStdinLexerProvider.CreateIncludedScriptLexer (sourceFile, reader, diagnosticsLogger) + let tokenizer = + fsiStdinLexerProvider.CreateIncludedScriptLexer(sourceFile, reader, diagnosticsLogger) let rec run istate = - let status = processor.ParseAndExecuteInteractionFromLexbuf ((fun f istate -> f ctok istate), istate, tokenizer, diagnosticsLogger) - ProcessStepStatus status None (fun _ istate -> - run istate) + let status = + processor.ParseAndExecuteInteractionFromLexbuf((fun f istate -> f ctok istate), istate, tokenizer, diagnosticsLogger) - run istate - ) + ProcessStepStatus status None (fun _ istate -> run istate) + + run istate) /// Load the source files, one by one. Called on the main thread. - member processor.EvalIncludedScripts (ctok, istate, sourceFiles, diagnosticsLogger) = + member processor.EvalIncludedScripts(ctok, istate, sourceFiles, diagnosticsLogger) = match sourceFiles with | [] -> istate, Completed None | sourceFile :: moreSourceFiles -> // Catch errors on a per-file basis, so results/bindings from pre-error files can be kept. - let status = InteractiveCatch diagnosticsLogger (fun istate -> processor.EvalIncludedScript (ctok, istate, sourceFile, rangeStdin0, diagnosticsLogger)) istate - ProcessStepStatus status None (fun _ istate -> - processor.EvalIncludedScripts (ctok, istate, moreSourceFiles, diagnosticsLogger)) + let status = + InteractiveCatch + diagnosticsLogger + (fun istate -> processor.EvalIncludedScript(ctok, istate, sourceFile, rangeStdin0, diagnosticsLogger)) + istate + + ProcessStepStatus status None (fun _ istate -> processor.EvalIncludedScripts(ctok, istate, moreSourceFiles, diagnosticsLogger)) - member processor.LoadInitialFiles (ctok, diagnosticsLogger) = + member processor.LoadInitialFiles(ctok, diagnosticsLogger) = /// Consume initial source files in chunks of scripts or non-scripts let rec consume istate sourceFiles = match sourceFiles with | [] -> istate - | (_,isScript1) :: _ -> - let sourceFiles,rest = List.takeUntil (fun (_,isScript2) -> isScript1 <> isScript2) sourceFiles + | (_, isScript1) :: _ -> + let sourceFiles, rest = + List.takeUntil (fun (_, isScript2) -> isScript1 <> isScript2) sourceFiles + let sourceFiles = List.map fst sourceFiles + let istate, _ = if isScript1 then - processor.EvalIncludedScripts (ctok, istate, sourceFiles, diagnosticsLogger) + processor.EvalIncludedScripts(ctok, istate, sourceFiles, diagnosticsLogger) else - istate |> InteractiveCatch diagnosticsLogger (fun istate -> fsiDynamicCompiler.EvalSourceFiles(ctok, istate, rangeStdin0, sourceFiles, lexResourceManager, diagnosticsLogger), Completed None) + istate + |> InteractiveCatch diagnosticsLogger (fun istate -> + fsiDynamicCompiler.EvalSourceFiles( + ctok, + istate, + rangeStdin0, + sourceFiles, + lexResourceManager, + diagnosticsLogger + ), + Completed None) + consume istate rest setCurrState (consume currState fsiOptions.SourceFiles) if not (List.isEmpty fsiOptions.SourceFiles) then - fsiConsolePrompt.PrintAhead(); // Seems required. I expected this could be deleted. Why not? + fsiConsolePrompt.PrintAhead() // Seems required. I expected this could be deleted. Why not? /// Send a dummy interaction through F# Interactive, to ensure all the most common code generation paths are /// JIT'ed and ready for use. member _.LoadDummyInteraction(ctok, diagnosticsLogger) = - setCurrState (currState |> InteractiveCatch diagnosticsLogger (fun istate -> fsiDynamicCompiler.EvalParsedDefinitions (ctok, diagnosticsLogger, istate, true, false, []) |> fst, Completed None) |> fst) + setCurrState ( + currState + |> InteractiveCatch diagnosticsLogger (fun istate -> + fsiDynamicCompiler.EvalParsedDefinitions(ctok, diagnosticsLogger, istate, true, false, []) + |> fst, + Completed None) + |> fst + ) member _.EvalInteraction(ctok, sourceText, scriptFileName, diagnosticsLogger, ?cancellationToken) = let cancellationToken = defaultArg cancellationToken CancellationToken.None @@ -3185,37 +4181,44 @@ type FsiInteractionProcessor use _ = UseDiagnosticsLogger diagnosticsLogger use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID let lexbuf = UnicodeLexing.StringAsLexbuf(true, tcConfigB.langVersion, sourceText) - let tokenizer = fsiStdinLexerProvider.CreateBufferLexer(scriptFileName, lexbuf, diagnosticsLogger) + + let tokenizer = + fsiStdinLexerProvider.CreateBufferLexer(scriptFileName, lexbuf, diagnosticsLogger) + currState |> InteractiveCatch diagnosticsLogger (fun istate -> let expr = ParseInteraction tokenizer - ExecuteParsedInteractionOnMainThread (ctok, diagnosticsLogger, expr, istate, cancellationToken)) + ExecuteParsedInteractionOnMainThread(ctok, diagnosticsLogger, expr, istate, cancellationToken)) |> commitResult - member this.EvalScript (ctok, scriptPath, diagnosticsLogger) = + member this.EvalScript(ctok, scriptPath, diagnosticsLogger) = // Todo: this runs the script as expected but errors are displayed one line to far in debugger let sourceText = sprintf "#load @\"%s\" " scriptPath - this.EvalInteraction (ctok, sourceText, scriptPath, diagnosticsLogger) + this.EvalInteraction(ctok, sourceText, scriptPath, diagnosticsLogger) - member _.EvalExpression (ctok, sourceText, scriptFileName, diagnosticsLogger) = + member _.EvalExpression(ctok, sourceText, scriptFileName, diagnosticsLogger) = use _unwind1 = UseBuildPhase BuildPhase.Interactive use _unwind2 = UseDiagnosticsLogger diagnosticsLogger use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID let lexbuf = UnicodeLexing.StringAsLexbuf(true, tcConfigB.langVersion, sourceText) - let tokenizer = fsiStdinLexerProvider.CreateBufferLexer(scriptFileName, lexbuf, diagnosticsLogger) + + let tokenizer = + fsiStdinLexerProvider.CreateBufferLexer(scriptFileName, lexbuf, diagnosticsLogger) + currState |> InteractiveCatch diagnosticsLogger (fun istate -> let expr = ParseExpression tokenizer let m = expr.Range // Make this into "(); expr" to suppress generalization and compilation-as-function - let exprWithSeq = SynExpr.Sequential (DebugPointAtSequential.SuppressExpr, true, SynExpr.Const (SynConst.Unit,m.StartRange), expr, m) - ExecuteParsedExpressionOnMainThread (ctok, diagnosticsLogger, exprWithSeq, istate)) + let exprWithSeq = + SynExpr.Sequential(DebugPointAtSequential.SuppressExpr, true, SynExpr.Const(SynConst.Unit, m.StartRange), expr, m) + + ExecuteParsedExpressionOnMainThread(ctok, diagnosticsLogger, exprWithSeq, istate)) |> commitResult member _.AddBoundValue(ctok, diagnosticsLogger, name, value: obj) = currState - |> InteractiveCatch diagnosticsLogger (fun istate -> - fsiDynamicCompiler.AddBoundValue(ctok, diagnosticsLogger, istate, name, value)) + |> InteractiveCatch diagnosticsLogger (fun istate -> fsiDynamicCompiler.AddBoundValue(ctok, diagnosticsLogger, istate, name, value)) |> commitResult member _.PartialAssemblySignatureUpdated = event.Publish @@ -3230,78 +4233,109 @@ type FsiInteractionProcessor // member processor.StartStdinReadAndProcessThread diagnosticsLogger = - if progress then fprintfn fsiConsoleOutput.Out "creating stdinReaderThread"; + if progress then + fprintfn fsiConsoleOutput.Out "creating stdinReaderThread" - let stdinReaderThread = - Thread(ThreadStart(fun () -> - InstallErrorLoggingOnThisThread diagnosticsLogger // FSI error logging on stdinReaderThread, e.g. parse errors. - use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID - try - try - let initialTokenizer = fsiStdinLexerProvider.CreateStdinLexer(diagnosticsLogger) - if progress then fprintfn fsiConsoleOutput.Out "READER: stdin thread started..."; + let stdinReaderThread = + Thread( + ThreadStart(fun () -> + InstallErrorLoggingOnThisThread diagnosticsLogger // FSI error logging on stdinReaderThread, e.g. parse errors. + use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID - // Delay until we've peeked the input or read the entire first line - fsiStdinLexerProvider.ConsoleInput.WaitForInitialConsoleInput() + try + try + let initialTokenizer = fsiStdinLexerProvider.CreateStdinLexer(diagnosticsLogger) - if progress then fprintfn fsiConsoleOutput.Out "READER: stdin thread got first line..."; + if progress then + fprintfn fsiConsoleOutput.Out "READER: stdin thread started..." - let runCodeOnMainThread = runCodeOnEventLoop diagnosticsLogger + // Delay until we've peeked the input or read the entire first line + fsiStdinLexerProvider.ConsoleInput.WaitForInitialConsoleInput() - // Keep going until EndOfFile on the inReader or console - let rec loop currTokenizer = + if progress then + fprintfn fsiConsoleOutput.Out "READER: stdin thread got first line..." - let istateNew, cont = - processor.ParseAndExecuteInteractionFromLexbuf (runCodeOnMainThread, currState, currTokenizer, diagnosticsLogger) + let runCodeOnMainThread = runCodeOnEventLoop diagnosticsLogger - setCurrState istateNew + // Keep going until EndOfFile on the inReader or console + let rec loop currTokenizer = - match cont with - | EndOfFile -> () - | CtrlC -> loop (fsiStdinLexerProvider.CreateStdinLexer(diagnosticsLogger)) // After each interrupt, restart to a brand new tokenizer - | CompletedWithAlreadyReportedError - | CompletedWithReportedError _ - | Completed _ -> loop currTokenizer + let istateNew, cont = + processor.ParseAndExecuteInteractionFromLexbuf( + runCodeOnMainThread, + currState, + currTokenizer, + diagnosticsLogger + ) - loop initialTokenizer + setCurrState istateNew - if progress then fprintfn fsiConsoleOutput.Out "- READER: Exiting stdinReaderThread"; + match cont with + | EndOfFile -> () + | CtrlC -> loop (fsiStdinLexerProvider.CreateStdinLexer(diagnosticsLogger)) // After each interrupt, restart to a brand new tokenizer + | CompletedWithAlreadyReportedError + | CompletedWithReportedError _ + | Completed _ -> loop currTokenizer - with e -> stopProcessingRecovery e range0; + loop initialTokenizer - finally - exit 1 + if progress then + fprintfn fsiConsoleOutput.Out "- READER: Exiting stdinReaderThread" + + with e -> + stopProcessingRecovery e range0 + + finally + exit 1 - ),Name="StdinReaderThread") + ), + Name = "StdinReaderThread" + ) + + if progress then + fprintfn fsiConsoleOutput.Out "MAIN: starting stdin thread..." - if progress then fprintfn fsiConsoleOutput.Out "MAIN: starting stdin thread..." - stdinReaderThread.Start() + stdinReaderThread.Start() - member _.CompletionsForPartialLID (istate, prefix:string) = - let lid,stem = - if prefix.IndexOf(".",StringComparison.Ordinal) >= 0 then + member _.CompletionsForPartialLID(istate, prefix: string) = + let lid, stem = + if prefix.IndexOf(".", StringComparison.Ordinal) >= 0 then let parts = prefix.Split('.') let n = parts.Length - Array.sub parts 0 (n-1) |> Array.toList,parts[n-1] + Array.sub parts 0 (n - 1) |> Array.toList, parts[n - 1] else - [],prefix + [], prefix let tcState = istate.tcState let amap = istate.tcImports.GetImportMap() - let infoReader = InfoReader(istate.tcGlobals,amap) - let ncenv = NameResolver(istate.tcGlobals,amap,infoReader,FakeInstantiationGenerator) + let infoReader = InfoReader(istate.tcGlobals, amap) + + let ncenv = + NameResolver(istate.tcGlobals, amap, infoReader, FakeInstantiationGenerator) + let ad = tcState.TcEnvFromImpls.AccessRights let nenv = tcState.TcEnvFromImpls.NameEnv - let nItems = ResolvePartialLongIdent ncenv nenv (ConstraintSolver.IsApplicableMethApprox istate.tcGlobals amap rangeStdin0) rangeStdin0 ad lid false + let nItems = + ResolvePartialLongIdent + ncenv + nenv + (ConstraintSolver.IsApplicableMethApprox istate.tcGlobals amap rangeStdin0) + rangeStdin0 + ad + lid + false + let names = nItems |> List.map (fun d -> d.DisplayName) let names = names |> List.filter (fun name -> name.StartsWithOrdinal(stem)) names - member _.ParseAndCheckInteraction (legacyReferenceResolver, istate, text:string) = - let tcConfig = TcConfig.Create(tcConfigB,validate=false) + member _.ParseAndCheckInteraction(legacyReferenceResolver, istate, text: string) = + let tcConfig = TcConfig.Create(tcConfigB, validate = false) + + let fsiInteractiveChecker = + FsiInteractiveChecker(legacyReferenceResolver, tcConfig, istate.tcGlobals, istate.tcImports, istate.tcState) - let fsiInteractiveChecker = FsiInteractiveChecker(legacyReferenceResolver, tcConfig, istate.tcGlobals, istate.tcImports, istate.tcState) fsiInteractiveChecker.ParseAndCheckInteraction(SourceText.ofString text) //---------------------------------------------------------------------------- @@ -3309,54 +4343,69 @@ type FsiInteractionProcessor //---------------------------------------------------------------------------- let internal SpawnThread name f = - let th = Thread(ThreadStart(f),Name=name) - th.IsBackground <- true; + let th = Thread(ThreadStart(f), Name = name) + th.IsBackground <- true th.Start() let internal SpawnInteractiveServer - (fsi: FsiEvaluationSessionHostConfig, - fsiOptions : FsiCommandLineOptions, - fsiConsoleOutput: FsiConsoleOutput) = + ( + fsi: FsiEvaluationSessionHostConfig, + fsiOptions: FsiCommandLineOptions, + fsiConsoleOutput: FsiConsoleOutput + ) = //printf "Spawning fsi server on channel '%s'" !fsiServerName; SpawnThread "ServerThread" (fun () -> - use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID - try - fsi.StartServer(fsiOptions.FsiServerName) - with e -> - fprintfn fsiConsoleOutput.Error "%s" (FSIstrings.SR.fsiExceptionRaisedStartingServer(e.ToString()))) + use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID + + try + fsi.StartServer(fsiOptions.FsiServerName) + with e -> + fprintfn fsiConsoleOutput.Error "%s" (FSIstrings.SR.fsiExceptionRaisedStartingServer (e.ToString()))) /// Repeatedly drive the event loop (e.g. Application.Run()) but catching ThreadAbortException and re-running. /// /// This gives us a last chance to catch an abort on the main execution thread. -let internal DriveFsiEventLoop (fsi: FsiEvaluationSessionHostConfig, fsiInterruptController: FsiInterruptController, fsiConsoleOutput: FsiConsoleOutput) = +let internal DriveFsiEventLoop + ( + fsi: FsiEvaluationSessionHostConfig, + fsiInterruptController: FsiInterruptController, + fsiConsoleOutput: FsiConsoleOutput + ) = + + if progress then + fprintfn fsiConsoleOutput.Out "GUI thread runLoop" - if progress then fprintfn fsiConsoleOutput.Out "GUI thread runLoop" fsiInterruptController.InstallKillThread() - let rec runLoop() = + let rec runLoop () = let restart = try fsi.EventLoopRun() with - | :? TargetInvocationException as e when (ControlledExecution.StripTargetInvocationException(e)).GetType().Name = "ThreadAbortException" -> - // If this TAE handler kicks it's almost certainly too late to save the - // state of the process - the state of the message loop may have been corrupted - fsiInterruptController.ControlledExecution().ResetAbort() - true + | :? TargetInvocationException as e when + (ControlledExecution.StripTargetInvocationException(e)).GetType().Name = "ThreadAbortException" + -> + // If this TAE handler kicks it's almost certainly too late to save the + // state of the process - the state of the message loop may have been corrupted + fsiInterruptController.ControlledExecution().ResetAbort() + true | :? ThreadAbortException -> - // If this TAE handler kicks it's almost certainly too late to save the - // state of the process - the state of the message loop may have been corrupted - fsiInterruptController.ControlledExecution().ResetAbort() - true + // If this TAE handler kicks it's almost certainly too late to save the + // state of the process - the state of the message loop may have been corrupted + fsiInterruptController.ControlledExecution().ResetAbort() + true | e -> stopProcessingRecovery e range0 true // Try again, just case we can restart - if progress then fprintfn fsiConsoleOutput.Out "MAIN: exited event loop..." - if restart then runLoop() + if progress then + fprintfn fsiConsoleOutput.Out "MAIN: exited event loop..." + + if restart then + runLoop () - runLoop(); + runLoop () /// Thrown when there was an error compiling the given code in FSI. type FsiCompilationException(message: string, errorInfos: FSharpDiagnostic[] option) = @@ -3365,7 +4414,16 @@ type FsiCompilationException(message: string, errorInfos: FSharpDiagnostic[] opt /// The primary type, representing a full F# Interactive session, reading from the given /// text input, writing to the given text output and error writers. -type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], inReader:TextReader, outWriter:TextWriter, errorWriter: TextWriter, fsiCollectible: bool, legacyReferenceResolver: LegacyReferenceResolver option) = +type FsiEvaluationSession + ( + fsi: FsiEvaluationSessionHostConfig, + argv: string[], + inReader: TextReader, + outWriter: TextWriter, + errorWriter: TextWriter, + fsiCollectible: bool, + legacyReferenceResolver: LegacyReferenceResolver option + ) = do UnmanagedProcessExecutionOptions.EnableHeapTerminationOnCorruption() (* SDL recommendation *) @@ -3375,7 +4433,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i // the object is not accessed concurrently during startup preparation. // // We later switch to doing interaction-by-interaction processing on the "event loop" thread. - let ctokStartup = AssumeCompilationThreadWithoutEvidence () + let ctokStartup = AssumeCompilationThreadWithoutEvidence() let timeReporter = FsiTimeReporter(outWriter) @@ -3390,34 +4448,38 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i let legacyReferenceResolver = match legacyReferenceResolver with - | None -> SimulatedMSBuildReferenceResolver.getResolver() + | None -> SimulatedMSBuildReferenceResolver.getResolver () | Some rr -> rr let tcConfigB = - TcConfigBuilder.CreateNew(legacyReferenceResolver, - defaultFSharpBinariesDir=defaultFSharpBinariesDir, - reduceMemoryUsage=ReduceMemoryFlag.Yes, - implicitIncludeDir=currentDirectory, - isInteractive=true, - isInvalidationSupported=false, - defaultCopyFSharpCore=CopyFSharpCoreFlag.No, - tryGetMetadataSnapshot=tryGetMetadataSnapshot, - sdkDirOverride=None, - rangeForErrors=range0) + TcConfigBuilder.CreateNew( + legacyReferenceResolver, + defaultFSharpBinariesDir = defaultFSharpBinariesDir, + reduceMemoryUsage = ReduceMemoryFlag.Yes, + implicitIncludeDir = currentDirectory, + isInteractive = true, + isInvalidationSupported = false, + defaultCopyFSharpCore = CopyFSharpCoreFlag.No, + tryGetMetadataSnapshot = tryGetMetadataSnapshot, + sdkDirOverride = None, + rangeForErrors = range0 + ) let tcConfigP = TcConfigProvider.BasedOnMutableBuilder(tcConfigB) do tcConfigB.resolutionEnvironment <- LegacyResolutionEnvironment.CompilationAndEvaluation // See Bug 3608 do tcConfigB.useFsiAuxLib <- fsi.UseFsiAuxLib do tcConfigB.conditionalDefines <- "INTERACTIVE" :: tcConfigB.conditionalDefines - do tcConfigB.SetUseSdkRefs true do tcConfigB.useSimpleResolution <- true - do if isRunningOnCoreClr then SetTargetProfile tcConfigB "netcore" // always assume System.Runtime codegen + + do + if isRunningOnCoreClr then + SetTargetProfile tcConfigB "netcore" // always assume System.Runtime codegen // Preset: --optimize+ -g --tailcalls+ (see 4505) do SetOptimizeSwitch tcConfigB OptionSwitch.On - do SetDebugSwitch tcConfigB (Some "pdbonly") OptionSwitch.On + do SetDebugSwitch tcConfigB (Some "pdbonly") OptionSwitch.On do SetTailcallSwitch tcConfigB OptionSwitch.On // set platform depending on whether the current process is a 64-bit process. @@ -3427,73 +4489,87 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i let fsiStdinSyphon = FsiStdinSyphon(errorWriter) let fsiConsoleOutput = FsiConsoleOutput(tcConfigB, outWriter, errorWriter) - let diagnosticsLogger = DiagnosticsLoggerThatStopsOnFirstError(tcConfigB, fsiStdinSyphon, fsiConsoleOutput) + let diagnosticsLogger = + DiagnosticsLoggerThatStopsOnFirstError(tcConfigB, fsiStdinSyphon, fsiConsoleOutput) do InstallErrorLoggingOnThisThread diagnosticsLogger // FSI error logging on main thread. - let updateBannerText() = - tcConfigB.productNameForBannerText <- FSIstrings.SR.fsiProductName(FSharpBannerVersion) + let updateBannerText () = + tcConfigB.productNameForBannerText <- FSIstrings.SR.fsiProductName (FSharpBannerVersion) - do updateBannerText() // setting the correct banner so that 'fsi -?' display the right thing + do updateBannerText () // setting the correct banner so that 'fsi -?' display the right thing let fsiOptions = FsiCommandLineOptions(fsi, argv, tcConfigB, fsiConsoleOutput) do - match fsiOptions.WriteReferencesAndExit with - | Some outFile -> - let tcConfig = tcConfigP.Get(ctokStartup) - let references, _unresolvedReferences = TcAssemblyResolutions.GetAssemblyResolutionInformation(tcConfig) - let lines = [ for r in references -> r.resolvedPath ] - FileSystem.OpenFileForWriteShim(outFile).WriteAllLines(lines) - exit 0 - | _ -> () + match fsiOptions.WriteReferencesAndExit with + | Some outFile -> + let tcConfig = tcConfigP.Get(ctokStartup) + + let references, _unresolvedReferences = + TcAssemblyResolutions.GetAssemblyResolutionInformation(tcConfig) + + let lines = [ for r in references -> r.resolvedPath ] + FileSystem.OpenFileForWriteShim(outFile).WriteAllLines(lines) + exit 0 + | _ -> () let fsiConsolePrompt = FsiConsolePrompt(fsiOptions, fsiConsoleOutput) do - match tcConfigB.preferredUiLang with - | Some s -> Thread.CurrentThread.CurrentUICulture <- CultureInfo(s) - | None -> () + match tcConfigB.preferredUiLang with + | Some s -> Thread.CurrentThread.CurrentUICulture <- CultureInfo(s) + | None -> () do - try - SetServerCodePages fsiOptions - with e -> - warning(e) + try + SetServerCodePages fsiOptions + with e -> + warning (e) do - updateBannerText() // resetting banner text after parsing options + updateBannerText () // resetting banner text after parsing options - if tcConfigB.showBanner then - fsiOptions.ShowBanner() + if tcConfigB.showBanner then + fsiOptions.ShowBanner() do fsiConsoleOutput.uprintfn "" // When no source files to load, print ahead prompt here - do if List.isEmpty fsiOptions.SourceFiles then - fsiConsolePrompt.PrintAhead() - + do + if List.isEmpty fsiOptions.SourceFiles then + fsiConsolePrompt.PrintAhead() let fsiConsoleInput = FsiConsoleInput(fsi, fsiOptions, inReader, outWriter) /// The single, global interactive checker that can be safely used in conjunction with other operations /// on the FsiEvaluationSession. - let checker = FSharpChecker.Create(legacyReferenceResolver=legacyReferenceResolver) + let checker = + FSharpChecker.Create(legacyReferenceResolver = legacyReferenceResolver) - let tcGlobals,frameworkTcImports,nonFrameworkResolutions,unresolvedReferences = + let tcGlobals, frameworkTcImports, nonFrameworkResolutions, unresolvedReferences = try let tcConfig = tcConfigP.Get(ctokStartup) + checker.FrameworkImportsCache.Get tcConfig |> NodeCode.RunImmediateWithoutCancellation with e -> - stopProcessingRecovery e range0; failwithf "Error creating evaluation session: %A" e + stopProcessingRecovery e range0 + failwithf "Error creating evaluation session: %A" e let tcImports = - try - TcImports.BuildNonFrameworkTcImports(tcConfigP, frameworkTcImports, nonFrameworkResolutions, unresolvedReferences, fsiOptions.DependencyProvider) - |> NodeCode.RunImmediateWithoutCancellation - with e -> - stopProcessingRecovery e range0; failwithf "Error creating evaluation session: %A" e + try + TcImports.BuildNonFrameworkTcImports( + tcConfigP, + frameworkTcImports, + nonFrameworkResolutions, + unresolvedReferences, + fsiOptions.DependencyProvider + ) + |> NodeCode.RunImmediateWithoutCancellation + with e -> + stopProcessingRecovery e range0 + failwithf "Error creating evaluation session: %A" e // Share intern'd strings across all lexing/parsing let lexResourceManager = LexResourceManager() @@ -3505,29 +4581,58 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i // Explanation: This callback is invoked during compilation to resolve assembly references // We don't yet propagate the ctok through these calls (though it looks plausible to do so). #if !NO_TYPEPROVIDERS - let ctok = AssumeCompilationThreadWithoutEvidence () - match tcImports.TryFindProviderGeneratedAssemblyByName (ctok, aref.Name) with - | Some assembly -> Some (Choice2Of2 assembly) + let ctok = AssumeCompilationThreadWithoutEvidence() + + match tcImports.TryFindProviderGeneratedAssemblyByName(ctok, aref.Name) with + | Some assembly -> Some(Choice2Of2 assembly) | None -> #endif - match tcImports.TryFindExistingFullyQualifiedPathByExactAssemblyRef aref with - | Some resolvedPath -> Some (Choice1Of2 resolvedPath) - | None -> None + match tcImports.TryFindExistingFullyQualifiedPathByExactAssemblyRef aref with + | Some resolvedPath -> Some(Choice1Of2 resolvedPath) + | None -> None - let fsiDynamicCompiler = FsiDynamicCompiler(fsi, timeReporter, tcConfigB, tcLockObject, outWriter, tcImports, tcGlobals, fsiOptions, fsiConsoleOutput, fsiCollectible, resolveAssemblyRef) + let fsiDynamicCompiler = + FsiDynamicCompiler( + fsi, + timeReporter, + tcConfigB, + tcLockObject, + outWriter, + tcImports, + tcGlobals, + fsiOptions, + fsiConsoleOutput, + fsiCollectible, + resolveAssemblyRef + ) let controlledExecution = ControlledExecution() - let fsiInterruptController = FsiInterruptController(fsiOptions, controlledExecution, fsiConsoleOutput) + let fsiInterruptController = + FsiInterruptController(fsiOptions, controlledExecution, fsiConsoleOutput) - let uninstallMagicAssemblyResolution = MagicAssemblyResolution.Install(tcConfigB, tcImports, fsiDynamicCompiler, fsiConsoleOutput) + let uninstallMagicAssemblyResolution = + MagicAssemblyResolution.Install(tcConfigB, tcImports, fsiDynamicCompiler, fsiConsoleOutput) /// This reference cell holds the most recent interactive state - let initialInteractiveState = fsiDynamicCompiler.GetInitialInteractiveState () - - let fsiStdinLexerProvider = FsiStdinLexerProvider(tcConfigB, fsiStdinSyphon, fsiConsoleInput, fsiConsoleOutput, fsiOptions, lexResourceManager) - - let fsiInteractionProcessor = FsiInteractionProcessor(fsi, tcConfigB, fsiOptions, fsiDynamicCompiler, fsiConsolePrompt, fsiConsoleOutput, fsiInterruptController, fsiStdinLexerProvider, lexResourceManager, initialInteractiveState) + let initialInteractiveState = fsiDynamicCompiler.GetInitialInteractiveState() + + let fsiStdinLexerProvider = + FsiStdinLexerProvider(tcConfigB, fsiStdinSyphon, fsiConsoleInput, fsiConsoleOutput, fsiOptions, lexResourceManager) + + let fsiInteractionProcessor = + FsiInteractionProcessor( + fsi, + tcConfigB, + fsiOptions, + fsiDynamicCompiler, + fsiConsolePrompt, + fsiConsoleOutput, + fsiInterruptController, + fsiStdinLexerProvider, + lexResourceManager, + initialInteractiveState + ) // Raising an exception throws away the exception stack making diagnosis hard // this wraps the existing exception as the inner exception @@ -3539,16 +4644,20 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i let commitResult res = match res with | Choice1Of2 r -> r - | Choice2Of2 None -> raise (FsiCompilationException(FSIstrings.SR.fsiOperationFailed(), None)) + | Choice2Of2 None -> raise (FsiCompilationException(FSIstrings.SR.fsiOperationFailed (), None)) | Choice2Of2 (Some userExn) -> raise (makeNestedException userExn) let commitResultNonThrowing errorOptions scriptFile (diagnosticsLogger: CompilationDiagnosticLogger) res = let errs = diagnosticsLogger.GetDiagnostics() - let errorInfos = DiagnosticHelpers.CreateDiagnostics (errorOptions, true, scriptFile, errs, true) + + let errorInfos = + DiagnosticHelpers.CreateDiagnostics(errorOptions, true, scriptFile, errs, true) + let userRes = match res with | Choice1Of2 r -> Choice1Of2 r - | Choice2Of2 None -> Choice2Of2 (FsiCompilationException(FSIstrings.SR.fsiOperationCouldNotBeCompleted(), Some errorInfos) :> exn) + | Choice2Of2 None -> + Choice2Of2(FsiCompilationException(FSIstrings.SR.fsiOperationCouldNotBeCompleted (), Some errorInfos) :> exn) | Choice2Of2 (Some userExn) -> Choice2Of2 userExn // 'true' is passed for "suggestNames" because we want the FSI session to suggest names for misspellings and it won't affect IDE perf much @@ -3556,7 +4665,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i let dummyScriptFileName = "input.fsx" - let eagerFormat (diag : PhasedDiagnostic) = diag.EagerlyFormatCore true + let eagerFormat (diag: PhasedDiagnostic) = diag.EagerlyFormatCore true interface IDisposable with member _.Dispose() = @@ -3569,10 +4678,11 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i /// A host calls this to get the completions for a long identifier, e.g. in the console member _.GetCompletions(longIdent) = - fsiInteractionProcessor.CompletionsForPartialLID (fsiInteractionProcessor.CurrentState, longIdent) |> Seq.ofList + fsiInteractionProcessor.CompletionsForPartialLID(fsiInteractionProcessor.CurrentState, longIdent) + |> Seq.ofList member _.ParseAndCheckInteraction(code) = - fsiInteractionProcessor.ParseAndCheckInteraction (legacyReferenceResolver, fsiInteractionProcessor.CurrentState, code) + fsiInteractionProcessor.ParseAndCheckInteraction(legacyReferenceResolver, fsiInteractionProcessor.CurrentState, code) |> Cancellable.runWithoutCancellation member _.InteractiveChecker = checker @@ -3580,8 +4690,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i member _.CurrentPartialAssemblySignature = fsiDynamicCompiler.CurrentPartialAssemblySignature fsiInteractionProcessor.CurrentState - member _.DynamicAssemblies = - fsiDynamicCompiler.DynamicAssemblies + member _.DynamicAssemblies = fsiDynamicCompiler.DynamicAssemblies /// A host calls this to determine if the --gui parameter is active member _.IsGui = fsiOptions.Gui @@ -3592,71 +4701,73 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i /// A host calls this to report an unhandled exception in a standard way, e.g. an exception on the GUI thread gets printed to stderr member x.ReportUnhandledException exn = x.ReportUnhandledExceptionSafe true exn - member _.ReportUnhandledExceptionSafe isFromThreadException (exn:exn) = - fsi.EventLoopInvoke ( - fun () -> - fprintfn fsiConsoleOutput.Error "%s" (exn.ToString()) - diagnosticsLogger.SetError() - try - diagnosticsLogger.AbortOnError(fsiConsoleOutput) - with StopProcessing -> - // BUG 664864 some window that use System.Windows.Forms.DataVisualization types (possible FSCharts) was created in FSI. - // at some moment one chart has raised InvalidArgumentException from OnPaint, this exception was intercepted by the code in higher layer and - // passed to Application.OnThreadException. FSI has already attached its own ThreadException handler, inside it will log the original error - // and then raise StopProcessing exception to unwind the stack (and possibly shut down current Application) and get to DriveFsiEventLoop. - // DriveFsiEventLoop handles StopProcessing by suppressing it and restarting event loop from the beginning. - // This schema works almost always except when FSI is started as 64 bit process (FsiAnyCpu) on Windows 7. - - // http://msdn.microsoft.com/en-us/library/windows/desktop/ms633573(v=vs.85).aspx - // Remarks: - // If your application runs on a 32-bit version of Windows operating system, uncaught exceptions from the callback - // will be passed onto higher-level exception handlers of your application when available. - // The system then calls the unhandled exception filter to handle the exception prior to terminating the process. - // If the PCA is enabled, it will offer to fix the problem the next time you run the application. - // However, if your application runs on a 64-bit version of Windows operating system or WOW64, - // you should be aware that a 64-bit operating system handles uncaught exceptions differently based on its 64-bit processor architecture, - // exception architecture, and calling convention. - // The following table summarizes all possible ways that a 64-bit Windows operating system or WOW64 handles uncaught exceptions. - // 1. The system suppresses any uncaught exceptions. - // 2. The system first terminates the process, and then the Program Compatibility Assistant (PCA) offers to fix it the next time - // you run the application. You can disable the PCA mitigation by adding a Compatibility section to the application manifest. - // 3. The system calls the exception filters but suppresses any uncaught exceptions when it leaves the callback scope, - // without invoking the associated handlers. - // Behavior type 2 only applies to the 64-bit version of the Windows 7 operating system. - - // NOTE: tests on Win8 box showed that 64 bit version of the Windows 8 always apply type 2 behavior - - // Effectively this means that when StopProcessing exception is raised from ThreadException callback - it won't be intercepted in DriveFsiEventLoop. - // Instead it will be interpreted as unhandled exception and crash the whole process. - - // FIX: detect if current process in 64 bit running on Windows 7 or Windows 8 and if yes - swallow the StopProcessing and ScheduleRestart instead. - // Visible behavior should not be different, previously exception unwinds the stack and aborts currently running Application. - // After that it will be intercepted and suppressed in DriveFsiEventLoop. - // Now we explicitly shut down Application so after execution of callback will be completed the control flow - // will also go out of WinFormsEventLoop.Run and again get to DriveFsiEventLoop => restart the loop. I'd like the fix to be as conservative as possible - // so we use special case for problematic case instead of just always scheduling restart. - - // http://msdn.microsoft.com/en-us/library/windows/desktop/ms724832(v=vs.85).aspx - let os = Environment.OSVersion - // Win7 6.1 - let isWindows7 = os.Version.Major = 6 && os.Version.Minor = 1 - // Win8 6.2 - let isWindows8Plus = os.Version >= Version(6, 2, 0, 0) - if isFromThreadException && ((isWindows7 && (IntPtr.Size = 8) && isWindows8Plus)) + member _.ReportUnhandledExceptionSafe isFromThreadException (exn: exn) = + fsi.EventLoopInvoke(fun () -> + fprintfn fsiConsoleOutput.Error "%s" (exn.ToString()) + diagnosticsLogger.SetError() + + try + diagnosticsLogger.AbortOnError(fsiConsoleOutput) + with StopProcessing -> + // BUG 664864 some window that use System.Windows.Forms.DataVisualization types (possible FSCharts) was created in FSI. + // at some moment one chart has raised InvalidArgumentException from OnPaint, this exception was intercepted by the code in higher layer and + // passed to Application.OnThreadException. FSI has already attached its own ThreadException handler, inside it will log the original error + // and then raise StopProcessing exception to unwind the stack (and possibly shut down current Application) and get to DriveFsiEventLoop. + // DriveFsiEventLoop handles StopProcessing by suppressing it and restarting event loop from the beginning. + // This schema works almost always except when FSI is started as 64 bit process (FsiAnyCpu) on Windows 7. + + // http://msdn.microsoft.com/en-us/library/windows/desktop/ms633573(v=vs.85).aspx + // Remarks: + // If your application runs on a 32-bit version of Windows operating system, uncaught exceptions from the callback + // will be passed onto higher-level exception handlers of your application when available. + // The system then calls the unhandled exception filter to handle the exception prior to terminating the process. + // If the PCA is enabled, it will offer to fix the problem the next time you run the application. + // However, if your application runs on a 64-bit version of Windows operating system or WOW64, + // you should be aware that a 64-bit operating system handles uncaught exceptions differently based on its 64-bit processor architecture, + // exception architecture, and calling convention. + // The following table summarizes all possible ways that a 64-bit Windows operating system or WOW64 handles uncaught exceptions. + // 1. The system suppresses any uncaught exceptions. + // 2. The system first terminates the process, and then the Program Compatibility Assistant (PCA) offers to fix it the next time + // you run the application. You can disable the PCA mitigation by adding a Compatibility section to the application manifest. + // 3. The system calls the exception filters but suppresses any uncaught exceptions when it leaves the callback scope, + // without invoking the associated handlers. + // Behavior type 2 only applies to the 64-bit version of the Windows 7 operating system. + + // NOTE: tests on Win8 box showed that 64 bit version of the Windows 8 always apply type 2 behavior + + // Effectively this means that when StopProcessing exception is raised from ThreadException callback - it won't be intercepted in DriveFsiEventLoop. + // Instead it will be interpreted as unhandled exception and crash the whole process. + + // FIX: detect if current process in 64 bit running on Windows 7 or Windows 8 and if yes - swallow the StopProcessing and ScheduleRestart instead. + // Visible behavior should not be different, previously exception unwinds the stack and aborts currently running Application. + // After that it will be intercepted and suppressed in DriveFsiEventLoop. + // Now we explicitly shut down Application so after execution of callback will be completed the control flow + // will also go out of WinFormsEventLoop.Run and again get to DriveFsiEventLoop => restart the loop. I'd like the fix to be as conservative as possible + // so we use special case for problematic case instead of just always scheduling restart. + + // http://msdn.microsoft.com/en-us/library/windows/desktop/ms724832(v=vs.85).aspx + let os = Environment.OSVersion + // Win7 6.1 + let isWindows7 = os.Version.Major = 6 && os.Version.Minor = 1 + // Win8 6.2 + let isWindows8Plus = os.Version >= Version(6, 2, 0, 0) + + if + isFromThreadException + && ((isWindows7 && (IntPtr.Size = 8) && isWindows8Plus)) #if DEBUG - // for debug purposes - && Environment.GetEnvironmentVariable("FSI_SCHEDULE_RESTART_WITH_ERRORS") = null + // for debug purposes + && Environment.GetEnvironmentVariable("FSI_SCHEDULE_RESTART_WITH_ERRORS") = null #endif - then - fsi.EventLoopScheduleRestart() - else - reraise() - ) - - member _.PartialAssemblySignatureUpdated = fsiInteractionProcessor.PartialAssemblySignatureUpdated + then + fsi.EventLoopScheduleRestart() + else + reraise ()) + member _.PartialAssemblySignatureUpdated = + fsiInteractionProcessor.PartialAssemblySignatureUpdated - member _.FormatValue(reflectionValue:obj, reflectionType) = + member _.FormatValue(reflectionValue: obj, reflectionType) = fsiDynamicCompiler.FormatValue(reflectionValue, reflectionType) member this.EvalExpression(code) = @@ -3681,8 +4792,11 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i // is not safe to call concurrently. let ctok = AssumeCompilationThreadWithoutEvidence() - let errorOptions = TcConfig.Create(tcConfigB,validate = false).diagnosticsOptions - let diagnosticsLogger = CompilationDiagnosticLogger("EvalInteraction", errorOptions, eagerFormat) + let errorOptions = TcConfig.Create(tcConfigB, validate = false).diagnosticsOptions + + let diagnosticsLogger = + CompilationDiagnosticLogger("EvalInteraction", errorOptions, eagerFormat) + fsiInteractionProcessor.EvalExpression(ctok, code, scriptFileName, diagnosticsLogger) |> commitResultNonThrowing errorOptions scriptFileName diagnosticsLogger @@ -3696,6 +4810,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i // is not safe to call concurrently. let ctok = AssumeCompilationThreadWithoutEvidence() let cancellationToken = defaultArg cancellationToken CancellationToken.None + fsiInteractionProcessor.EvalInteraction(ctok, code, scriptFileName, diagnosticsLogger, cancellationToken) |> commitResult |> ignore @@ -3703,7 +4818,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i member this.EvalInteractionNonThrowing(code, ?cancellationToken) = let cancellationToken = defaultArg cancellationToken CancellationToken.None this.EvalInteractionNonThrowing(code, dummyScriptFileName, cancellationToken) - + member this.EvalInteractionNonThrowing(code, scriptFileName, ?cancellationToken) = // Explanation: When the user of the FsiInteractiveSession object calls this method, the // code is parsed, checked and evaluated on the calling thread. This means EvalExpression @@ -3711,8 +4826,11 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i let ctok = AssumeCompilationThreadWithoutEvidence() let cancellationToken = defaultArg cancellationToken CancellationToken.None - let errorOptions = TcConfig.Create(tcConfigB,validate = false).diagnosticsOptions - let diagnosticsLogger = CompilationDiagnosticLogger("EvalInteraction", errorOptions, eagerFormat) + let errorOptions = TcConfig.Create(tcConfigB, validate = false).diagnosticsOptions + + let diagnosticsLogger = + CompilationDiagnosticLogger("EvalInteraction", errorOptions, eagerFormat) + fsiInteractionProcessor.EvalInteraction(ctok, code, scriptFileName, diagnosticsLogger, cancellationToken) |> commitResultNonThrowing errorOptions scriptFileName diagnosticsLogger @@ -3733,10 +4851,15 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i let ctok = AssumeCompilationThreadWithoutEvidence() let errorOptions = TcConfig.Create(tcConfigB, validate = false).diagnosticsOptions - let diagnosticsLogger = CompilationDiagnosticLogger("EvalInteraction", errorOptions, eagerFormat) + + let diagnosticsLogger = + CompilationDiagnosticLogger("EvalInteraction", errorOptions, eagerFormat) + fsiInteractionProcessor.EvalScript(ctok, filePath, diagnosticsLogger) |> commitResultNonThrowing errorOptions filePath diagnosticsLogger - |> function Choice1Of2 _, errs -> Choice1Of2 (), errs | Choice2Of2 exn, errs -> Choice2Of2 exn, errs + |> function + | Choice1Of2 _, errs -> Choice1Of2(), errs + | Choice2Of2 exn, errs -> Choice2Of2 exn, errs /// Event fires when a root-level value is bound to an identifier, e.g., via `let x = ...`. member _.ValueBound = fsiDynamicCompiler.ValueBound @@ -3779,20 +4902,22 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i // the object is not accessed concurrently during startup preparation. // // We later switch to doing interaction-by-interaction processing on the "event loop" thread - let ctokRun = AssumeCompilationThreadWithoutEvidence () + let ctokRun = AssumeCompilationThreadWithoutEvidence() if fsiOptions.IsInteractiveServer then - SpawnInteractiveServer (fsi, fsiOptions, fsiConsoleOutput) + SpawnInteractiveServer(fsi, fsiOptions, fsiConsoleOutput) use _ = UseBuildPhase BuildPhase.Interactive if fsiOptions.Interact then // page in the type check env fsiInteractionProcessor.LoadDummyInteraction(ctokStartup, diagnosticsLogger) - if progress then fprintfn fsiConsoleOutput.Out "MAIN: got initial state, creating form"; + + if progress then + fprintfn fsiConsoleOutput.Out "MAIN: got initial state, creating form" // Route background exceptions to the exception handlers - AppDomain.CurrentDomain.UnhandledException.Add (fun args -> + AppDomain.CurrentDomain.UnhandledException.Add(fun args -> match args.ExceptionObject with | :? System.Exception as err -> x.ReportUnhandledExceptionSafe false err | _ -> ()) @@ -3800,13 +4925,17 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i fsiInteractionProcessor.LoadInitialFiles(ctokRun, diagnosticsLogger) fsiInteractionProcessor.StartStdinReadAndProcessThread(diagnosticsLogger) - DriveFsiEventLoop (fsi, fsiInterruptController, fsiConsoleOutput) + DriveFsiEventLoop(fsi, fsiInterruptController, fsiConsoleOutput) else // not interact - if progress then fprintfn fsiConsoleOutput.Out "Run: not interact, loading initial files..." + if progress then + fprintfn fsiConsoleOutput.Out "Run: not interact, loading initial files..." + fsiInteractionProcessor.LoadInitialFiles(ctokRun, diagnosticsLogger) - if progress then fprintfn fsiConsoleOutput.Out "Run: done..." + if progress then + fprintfn fsiConsoleOutput.Out "Run: done..." + exit (min diagnosticsLogger.ErrorCount 1) // The Ctrl-C exception handler that we've passed to native code has @@ -3816,39 +4945,51 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i static member Create(fsiConfig, argv, inReader, outWriter, errorWriter, ?collectible, ?legacyReferenceResolver) = new FsiEvaluationSession(fsiConfig, argv, inReader, outWriter, errorWriter, defaultArg collectible false, legacyReferenceResolver) - static member GetDefaultConfiguration(fsiObj:obj) = FsiEvaluationSession.GetDefaultConfiguration(fsiObj, true) + static member GetDefaultConfiguration(fsiObj: obj) = + FsiEvaluationSession.GetDefaultConfiguration(fsiObj, true) - static member GetDefaultConfiguration(fsiObj:obj, useFsiAuxLib: bool) = + static member GetDefaultConfiguration(fsiObj: obj, useFsiAuxLib: bool) = // We want to avoid modifying FSharp.Compiler.Interactive.Settings to avoid republishing that DLL. // So we access these via reflection - { // Connect the configuration through to the 'fsi' object from FSharp.Compiler.Interactive.Settings - new FsiEvaluationSessionHostConfig () with - member _.FormatProvider = getInstanceProperty fsiObj "FormatProvider" - member _.FloatingPointFormat = getInstanceProperty fsiObj "FloatingPointFormat" - member _.AddedPrinters = getInstanceProperty fsiObj "AddedPrinters" - member _.ShowDeclarationValues = getInstanceProperty fsiObj "ShowDeclarationValues" - member _.ShowIEnumerable = getInstanceProperty fsiObj "ShowIEnumerable" - member _.ShowProperties = getInstanceProperty fsiObj "ShowProperties" - member _.PrintSize = getInstanceProperty fsiObj "PrintSize" - member _.PrintDepth = getInstanceProperty fsiObj "PrintDepth" - member _.PrintWidth = getInstanceProperty fsiObj "PrintWidth" - member _.PrintLength = getInstanceProperty fsiObj "PrintLength" - member _.ReportUserCommandLineArgs args = setInstanceProperty fsiObj "CommandLineArgs" args - member _.StartServer(fsiServerName) = failwith "--fsi-server not implemented in the default configuration" - member _.EventLoopRun() = callInstanceMethod0 (getInstanceProperty fsiObj "EventLoop") [||] "Run" - member _.EventLoopInvoke(f : unit -> 'T) = callInstanceMethod1 (getInstanceProperty fsiObj "EventLoop") [|typeof<'T>|] "Invoke" f - member _.EventLoopScheduleRestart() = callInstanceMethod0 (getInstanceProperty fsiObj "EventLoop") [||] "ScheduleRestart" - member _.UseFsiAuxLib = useFsiAuxLib - member _.GetOptionalConsoleReadLine(_probe) = None } + { new FsiEvaluationSessionHostConfig() with + member _.FormatProvider = getInstanceProperty fsiObj "FormatProvider" + member _.FloatingPointFormat = getInstanceProperty fsiObj "FloatingPointFormat" + member _.AddedPrinters = getInstanceProperty fsiObj "AddedPrinters" + member _.ShowDeclarationValues = getInstanceProperty fsiObj "ShowDeclarationValues" + member _.ShowIEnumerable = getInstanceProperty fsiObj "ShowIEnumerable" + member _.ShowProperties = getInstanceProperty fsiObj "ShowProperties" + member _.PrintSize = getInstanceProperty fsiObj "PrintSize" + member _.PrintDepth = getInstanceProperty fsiObj "PrintDepth" + member _.PrintWidth = getInstanceProperty fsiObj "PrintWidth" + member _.PrintLength = getInstanceProperty fsiObj "PrintLength" + + member _.ReportUserCommandLineArgs args = + setInstanceProperty fsiObj "CommandLineArgs" args + + member _.StartServer(fsiServerName) = + failwith "--fsi-server not implemented in the default configuration" + + member _.EventLoopRun() = + callInstanceMethod0 (getInstanceProperty fsiObj "EventLoop") [||] "Run" + + member _.EventLoopInvoke(f: unit -> 'T) = + callInstanceMethod1 (getInstanceProperty fsiObj "EventLoop") [| typeof<'T> |] "Invoke" f + + member _.EventLoopScheduleRestart() = + callInstanceMethod0 (getInstanceProperty fsiObj "EventLoop") [||] "ScheduleRestart" + + member _.UseFsiAuxLib = useFsiAuxLib + member _.GetOptionalConsoleReadLine(_probe) = None + } //------------------------------------------------------------------------------- // If no "fsi" object for the configuration is specified, make the default // configuration one which stores the settings in-process module Settings = type IEventLoop = - abstract Run : unit -> bool - abstract Invoke : (unit -> 'T) -> 'T - abstract ScheduleRestart : unit -> unit + abstract Run: unit -> bool + abstract Invoke: (unit -> 'T) -> 'T + abstract ScheduleRestart: unit -> unit // fsi.fs in FSHarp.Compiler.Service.dll avoids a hard dependency on FSharp.Compiler.Interactive.Settings.dll // by providing an optional reimplementation of the functionality @@ -3859,46 +5000,65 @@ module Settings = let runSignal = new AutoResetEvent(false) let exitSignal = new AutoResetEvent(false) let doneSignal = new AutoResetEvent(false) - let mutable queue = ([] : (unit -> obj) list) - let mutable result = (None : obj option) - let setSignal(signal : AutoResetEvent) = while not (signal.Set()) do Thread.Sleep(1); done - let waitSignal signal = WaitHandle.WaitAll([| (signal :> WaitHandle) |]) |> ignore + let mutable queue = ([]: (unit -> obj) list) + let mutable result = (None: obj option) + + let setSignal (signal: AutoResetEvent) = + while not (signal.Set()) do + Thread.Sleep(1) + + let waitSignal signal = + WaitHandle.WaitAll([| (signal :> WaitHandle) |]) |> ignore + let waitSignal2 signal1 signal2 = WaitHandle.WaitAny([| (signal1 :> WaitHandle); (signal2 :> WaitHandle) |]) + let mutable running = false let mutable restart = false + interface IEventLoop with - member x.Run() = - running <- true - let rec run() = - match waitSignal2 runSignal exitSignal with - | 0 -> - queue |> List.iter (fun f -> result <- try Some(f()) with _ -> None); - setSignal doneSignal - run() - | 1 -> - running <- false; - restart - | _ -> run() - run(); - member _.Invoke(f : unit -> 'T) : 'T = - queue <- [f >> box] - setSignal runSignal - waitSignal doneSignal - result.Value |> unbox - member _.ScheduleRestart() = - if running then - restart <- true - setSignal exitSignal - interface IDisposable with - member _.Dispose() = - runSignal.Dispose() - exitSignal.Dispose() - doneSignal.Dispose() + member x.Run() = + running <- true + + let rec run () = + match waitSignal2 runSignal exitSignal with + | 0 -> + queue + |> List.iter (fun f -> + result <- + try + Some(f ()) + with _ -> + None) + + setSignal doneSignal + run () + | 1 -> + running <- false + restart + | _ -> run () + + run () + + member _.Invoke(f: unit -> 'T) : 'T = + queue <- [ f >> box ] + setSignal runSignal + waitSignal doneSignal + result.Value |> unbox + + member _.ScheduleRestart() = + if running then + restart <- true + setSignal exitSignal + interface IDisposable with + member _.Dispose() = + runSignal.Dispose() + exitSignal.Dispose() + doneSignal.Dispose() [] - type InteractiveSettings() = + type InteractiveSettings() = let mutable evLoop = (new SimpleEventLoop() :> IEventLoop) let mutable showIDictionary = true let mutable showDeclarationValues = true @@ -3913,31 +5073,70 @@ module Settings = let mutable showProperties = true let mutable addedPrinters = [] - member _.FloatingPointFormat with get() = fpfmt and set v = fpfmt <- v - member _.FormatProvider with get() = fp and set v = fp <- v - member _.PrintWidth with get() = printWidth and set v = printWidth <- v - member _.PrintDepth with get() = printDepth and set v = printDepth <- v - member _.PrintLength with get() = printLength and set v = printLength <- v - member _.PrintSize with get() = printSize and set v = printSize <- v - member _.ShowDeclarationValues with get() = showDeclarationValues and set v = showDeclarationValues <- v - member _.ShowProperties with get() = showProperties and set v = showProperties <- v - member _.ShowIEnumerable with get() = showIEnumerable and set v = showIEnumerable <- v - member _.ShowIDictionary with get() = showIDictionary and set v = showIDictionary <- v - member _.AddedPrinters with get() = addedPrinters and set v = addedPrinters <- v - member _.CommandLineArgs with get() = args and set v = args <- v - member _.AddPrinter(printer : 'T -> string) = - addedPrinters <- Choice1Of2 (typeof<'T>, (fun (x:obj) -> printer (unbox x))) :: addedPrinters + member _.FloatingPointFormat + with get () = fpfmt + and set v = fpfmt <- v + + member _.FormatProvider + with get () = fp + and set v = fp <- v + + member _.PrintWidth + with get () = printWidth + and set v = printWidth <- v + + member _.PrintDepth + with get () = printDepth + and set v = printDepth <- v + + member _.PrintLength + with get () = printLength + and set v = printLength <- v + + member _.PrintSize + with get () = printSize + and set v = printSize <- v + + member _.ShowDeclarationValues + with get () = showDeclarationValues + and set v = showDeclarationValues <- v + + member _.ShowProperties + with get () = showProperties + and set v = showProperties <- v + + member _.ShowIEnumerable + with get () = showIEnumerable + and set v = showIEnumerable <- v + + member _.ShowIDictionary + with get () = showIDictionary + and set v = showIDictionary <- v + + member _.AddedPrinters + with get () = addedPrinters + and set v = addedPrinters <- v + + member _.CommandLineArgs + with get () = args + and set v = args <- v + + member _.AddPrinter(printer: 'T -> string) = + addedPrinters <- Choice1Of2(typeof<'T>, (fun (x: obj) -> printer (unbox x))) :: addedPrinters member _.EventLoop - with get () = evLoop - and set (x:IEventLoop) = evLoop.ScheduleRestart(); evLoop <- x + with get () = evLoop + and set (x: IEventLoop) = + evLoop.ScheduleRestart() + evLoop <- x - member _.AddPrintTransformer(printer : 'T -> obj) = - addedPrinters <- Choice2Of2 (typeof<'T>, (fun (x:obj) -> printer (unbox x))) :: addedPrinters + member _.AddPrintTransformer(printer: 'T -> obj) = + addedPrinters <- Choice2Of2(typeof<'T>, (fun (x: obj) -> printer (unbox x))) :: addedPrinters let fsi = InteractiveSettings() type FsiEvaluationSession with + static member GetDefaultConfiguration() = FsiEvaluationSession.GetDefaultConfiguration(Settings.fsi, false) @@ -3951,67 +5150,93 @@ type CompilerInputStream() = // Queue of characters waiting to be read. let readQueue = Queue() - let waitForAtLeastOneByte(count : int) = - let rec loop() = + let waitForAtLeastOneByte (count: int) = + let rec loop () = let attempt = lock readQueue (fun () -> let n = readQueue.Count + if (n >= 1) then let lengthToRead = if (n < count) then n else count let ret = Array.zeroCreate lengthToRead + for i in 0 .. lengthToRead - 1 do ret[i] <- readQueue.Dequeue() + Some ret else None) + match attempt with - | None -> Thread.Sleep(pauseDuration); loop() + | None -> + Thread.Sleep(pauseDuration) + loop () | Some res -> res - loop() + + loop () override x.CanRead = true override x.CanWrite = false override x.CanSeek = false - override x.Position with get() = raise (NotSupportedException()) and set _v = raise (NotSupportedException()) + + override x.Position + with get () = raise (NotSupportedException()) + and set _v = raise (NotSupportedException()) + override x.Length = raise (NotSupportedException()) override x.Flush() = () override x.Seek(_offset, _origin) = raise (NotSupportedException()) override x.SetLength(_value) = raise (NotSupportedException()) - override x.Write(_buffer, _offset, _count) = raise (NotSupportedException("Cannot write to input stream")) + + override x.Write(_buffer, _offset, _count) = + raise (NotSupportedException("Cannot write to input stream")) + override x.Read(buffer, offset, count) = let bytes = waitForAtLeastOneByte count Array.Copy(bytes, 0, buffer, offset, bytes.Length) bytes.Length /// Feeds content into the stream. - member _.Add(str:string) = - if (String.IsNullOrEmpty(str)) then () else + member _.Add(str: string) = + if (String.IsNullOrEmpty(str)) then + () + else + + lock readQueue (fun () -> + let bytes = Encoding.UTF8.GetBytes(str) - lock readQueue (fun () -> - let bytes = Encoding.UTF8.GetBytes(str) - for i in 0 .. bytes.Length - 1 do - readQueue.Enqueue(bytes[i])) + for i in 0 .. bytes.Length - 1 do + readQueue.Enqueue(bytes[i])) /// Defines a write-only stream used to capture output of the hosted F# Interactive dynamic compiler. [] -type CompilerOutputStream() = +type CompilerOutputStream() = inherit Stream() // Queue of characters waiting to be read. let contentQueue = Queue() - let nyi() = raise (NotSupportedException()) + let nyi () = raise (NotSupportedException()) override x.CanRead = false override x.CanWrite = true override x.CanSeek = false - override x.Position with get() = nyi() and set _v = nyi() - override x.Length = nyi() + + override x.Position + with get () = nyi () + and set _v = nyi () + + override x.Length = nyi () override x.Flush() = () - override x.Seek(_offset, _origin) = nyi() - override x.SetLength(_value) = nyi() - override x.Read(_buffer, _offset, _count) = raise (NotSupportedException("Cannot write to input stream")) + override x.Seek(_offset, _origin) = nyi () + override x.SetLength(_value) = nyi () + + override x.Read(_buffer, _offset, _count) = + raise (NotSupportedException("Cannot write to input stream")) + override x.Write(buffer, offset, count) = let stop = offset + count - if (stop > buffer.Length) then raise (ArgumentException("offset,count")) + + if (stop > buffer.Length) then + raise (ArgumentException("offset,count")) lock contentQueue (fun () -> for i in offset .. stop - 1 do @@ -4020,9 +5245,11 @@ type CompilerOutputStream() = member _.Read() = lock contentQueue (fun () -> let n = contentQueue.Count + if (n > 0) then let bytes = Array.zeroCreate n - for i in 0 .. n-1 do + + for i in 0 .. n - 1 do bytes[i] <- contentQueue.Dequeue() Encoding.UTF8.GetString(bytes, 0, n) diff --git a/src/Compiler/Legacy/LegacyHostedCompilerForTesting.fs b/src/Compiler/Legacy/LegacyHostedCompilerForTesting.fs index b4af719fa39..87ec46483fe 100644 --- a/src/Compiler/Legacy/LegacyHostedCompilerForTesting.fs +++ b/src/Compiler/Legacy/LegacyHostedCompilerForTesting.fs @@ -1,6 +1,6 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -// This component is used by the 'fsharpqa' tests for faster in-memory compilation. It should be removed and the +// This component is used by the 'fsharpqa' tests for faster in-memory compilation. It should be removed and the // proper compiler service API used instead. namespace FSharp.Compiler.CodeAnalysis.Hosted @@ -14,7 +14,7 @@ open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.CompilerConfig open FSharp.Compiler.CompilerDiagnostics open FSharp.Compiler.AbstractIL.ILBinaryReader -open Internal.Utilities.Library +open Internal.Utilities.Library /// Part of LegacyHostedCompilerForTesting /// @@ -35,14 +35,15 @@ type internal InProcDiagnosticsLoggerProvider() = member _.HandleIssue(tcConfig, err, severity) = // 'true' is passed for "suggestNames", since we want to suggest names with fsc.exe runs and this doesn't affect IDE perf - let diagnostics = CollectFormattedDiagnostics (tcConfig, severity, err, true) + let diagnostics = CollectFormattedDiagnostics(tcConfig, severity, err, true) + match severity with - | FSharpDiagnosticSeverity.Error -> - errors.AddRange(diagnostics) - | FSharpDiagnosticSeverity.Warning -> - warnings.AddRange(diagnostics) - | _ -> ()} - :> DiagnosticsLogger } + | FSharpDiagnosticSeverity.Error -> errors.AddRange(diagnostics) + | FSharpDiagnosticSeverity.Warning -> warnings.AddRange(diagnostics) + | _ -> () + } + :> DiagnosticsLogger + } member _.CapturedErrors = errors.ToArray() @@ -57,60 +58,73 @@ type internal Location = EndColumn: int } -type internal CompilationIssueType = Warning | Error +type internal CompilationIssueType = + | Warning + | Error /// build issue details -type internal CompilationIssue = - { +type internal CompilationIssue = + { Location: Location Subcategory: string Code: string File: string - Text: string + Text: string Type: CompilationIssueType } /// combined warning and error details -type internal FailureDetails = +type internal FailureDetails = { Warnings: CompilationIssue list Errors: CompilationIssue list } -type internal CompilationResult = +type internal CompilationResult = | Success of CompilationIssue list | Failure of FailureDetails [] -type internal CompilationOutput = - { Errors: FormattedDiagnostic[] - Warnings: FormattedDiagnostic[] } +type internal CompilationOutput = + { + Errors: FormattedDiagnostic[] + Warnings: FormattedDiagnostic[] + } -type internal InProcCompiler(legacyReferenceResolver) = - member _.Compile(argv) = +type internal InProcCompiler(legacyReferenceResolver) = + member _.Compile(argv) = // Explanation: Compilation happens on whichever thread calls this function. - let ctok = AssumeCompilationThreadWithoutEvidence () + let ctok = AssumeCompilationThreadWithoutEvidence() let loggerProvider = InProcDiagnosticsLoggerProvider() let exiter = StopProcessingExiter() - try - CompileFromCommandLineArguments ( - ctok, argv, legacyReferenceResolver, - false, ReduceMemoryFlag.Yes, - CopyFSharpCoreFlag.Yes, exiter, - loggerProvider.Provider, None, None + + try + CompileFromCommandLineArguments( + ctok, + argv, + legacyReferenceResolver, + false, + ReduceMemoryFlag.Yes, + CopyFSharpCoreFlag.Yes, + exiter, + loggerProvider.Provider, + None, + None ) - with - | StopProcessing -> () - | ReportedError _ - | WrappedError(ReportedError _,_) -> - exiter.ExitCode <- 1 - () + with + | StopProcessing -> () + | ReportedError _ + | WrappedError (ReportedError _, _) -> + exiter.ExitCode <- 1 + () let output: CompilationOutput = - { Warnings = loggerProvider.CapturedWarnings - Errors = loggerProvider.CapturedErrors } + { + Warnings = loggerProvider.CapturedWarnings + Errors = loggerProvider.CapturedErrors + } (exiter.ExitCode = 0), output @@ -118,8 +132,8 @@ type internal InProcCompiler(legacyReferenceResolver) = type internal FscCompiler(legacyReferenceResolver) = let compiler = InProcCompiler(legacyReferenceResolver) - let emptyLocation = - { + let emptyLocation = + { StartColumn = 0 EndColumn = 0 StartLine = 0 @@ -127,50 +141,66 @@ type internal FscCompiler(legacyReferenceResolver) = } /// Converts short and long issue types to the same CompilationIssue representation - let convert issue = + let convert issue = match issue with - | FormattedDiagnostic.Short(severity, text) -> + | FormattedDiagnostic.Short (severity, text) -> { Location = emptyLocation Code = "" Subcategory = "" File = "" Text = text - Type = if (severity = FSharpDiagnosticSeverity.Error) then CompilationIssueType.Error else CompilationIssueType.Warning + Type = + if (severity = FSharpDiagnosticSeverity.Error) then + CompilationIssueType.Error + else + CompilationIssueType.Warning } - | FormattedDiagnostic.Long(severity, details) -> - let loc, file = + | FormattedDiagnostic.Long (severity, details) -> + let loc, file = match details.Location with - | Some l when not l.IsEmpty -> - { + | Some l when not l.IsEmpty -> + { StartColumn = l.Range.StartColumn EndColumn = l.Range.EndColumn StartLine = l.Range.StartLine EndLine = l.Range.EndLine - }, l.File + }, + l.File | _ -> emptyLocation, "" + { Location = loc Code = sprintf "FS%04d" details.Canonical.ErrorNumber Subcategory = details.Canonical.Subcategory File = file Text = details.Message - Type = if (severity = FSharpDiagnosticSeverity.Error) then CompilationIssueType.Error else CompilationIssueType.Warning + Type = + if (severity = FSharpDiagnosticSeverity.Error) then + CompilationIssueType.Error + else + CompilationIssueType.Warning } /// test if --test:ErrorRanges flag is set let errorRangesArg = - let regex = Regex(@"^(/|--)test:ErrorRanges$", RegexOptions.Compiled ||| RegexOptions.IgnoreCase) + let regex = + Regex(@"^(/|--)test:ErrorRanges$", RegexOptions.Compiled ||| RegexOptions.IgnoreCase) + fun arg -> regex.IsMatch(arg) /// test if --vserrors flag is set let vsErrorsArg = - let regex = Regex(@"^(/|--)vserrors$", RegexOptions.Compiled ||| RegexOptions.IgnoreCase) + let regex = + Regex(@"^(/|--)vserrors$", RegexOptions.Compiled ||| RegexOptions.IgnoreCase) + fun arg -> regex.IsMatch(arg) /// test if an arg is a path to fsc.exe - let fscExeArg = - let regex = Regex(@"fsc(\.exe)?$", RegexOptions.Compiled ||| RegexOptions.IgnoreCase) + let fscExeArg = + let regex = + Regex(@"fsc(\.exe)?$", RegexOptions.Compiled ||| RegexOptions.IgnoreCase) + fun arg -> regex.IsMatch(arg) /// do compilation as if args was argv to fsc.exe @@ -179,8 +209,9 @@ type internal FscCompiler(legacyReferenceResolver) = // compensate for this in case caller didn't know let args = match args with - | [||] | null -> [|"fsc"|] - | a when not <| fscExeArg a[0] -> Array.append [|"fsc"|] a + | [||] + | null -> [| "fsc" |] + | a when not <| fscExeArg a[0] -> Array.append [| "fsc" |] a | _ -> args let errorRanges = args |> Seq.exists errorRangesArg @@ -188,27 +219,45 @@ type internal FscCompiler(legacyReferenceResolver) = let ok, result = compiler.Compile(args) let exitCode = if ok then 0 else 1 - + let lines = Seq.append result.Errors result.Warnings |> Seq.map convert |> Seq.map (fun issue -> - let issueTypeStr = + let issueTypeStr = match issue.Type with - | Error -> if vsErrors then sprintf "%s error" issue.Subcategory else "error" - | Warning -> if vsErrors then sprintf "%s warning" issue.Subcategory else "warning" + | Error -> + if vsErrors then + sprintf "%s error" issue.Subcategory + else + "error" + | Warning -> + if vsErrors then + sprintf "%s warning" issue.Subcategory + else + "warning" let locationStr = if vsErrors then - sprintf "(%d,%d,%d,%d)" issue.Location.StartLine issue.Location.StartColumn issue.Location.EndLine issue.Location.EndColumn + sprintf + "(%d,%d,%d,%d)" + issue.Location.StartLine + issue.Location.StartColumn + issue.Location.EndLine + issue.Location.EndColumn elif errorRanges then - sprintf "(%d,%d-%d,%d)" issue.Location.StartLine issue.Location.StartColumn issue.Location.EndLine issue.Location.EndColumn + sprintf + "(%d,%d-%d,%d)" + issue.Location.StartLine + issue.Location.StartColumn + issue.Location.EndLine + issue.Location.EndColumn else sprintf "(%d,%d)" issue.Location.StartLine issue.Location.StartColumn - sprintf "%s: %s %s: %s" locationStr issueTypeStr issue.Code issue.Text - ) + sprintf "%s: %s %s: %s" locationStr issueTypeStr issue.Code issue.Text) |> Array.ofSeq + (exitCode, lines) module internal CompilerHelpers = @@ -218,15 +267,18 @@ module internal CompilerHelpers = let parseCommandLine (commandLine: string) = let folder (inQuote: bool, currArg: string, argLst: string list) ch = match (ch, inQuote) with - | '"', _ -> - (not inQuote, currArg, argLst) + | '"', _ -> (not inQuote, currArg, argLst) | ' ', false -> - if currArg.Length > 0 then (inQuote, "", currArg :: argLst) - else (inQuote, "", argLst) - | _ -> - (inQuote, currArg + (string ch), argLst) - - seq { yield! commandLine.ToCharArray(); yield ' ' } + if currArg.Length > 0 then + (inQuote, "", currArg :: argLst) + else + (inQuote, "", argLst) + | _ -> (inQuote, currArg + (string ch), argLst) + + seq { + yield! commandLine.ToCharArray() + yield ' ' + } |> Seq.fold folder (false, "", []) |> (fun (_, _, args) -> args) |> List.rev @@ -241,17 +293,26 @@ module internal CompilerHelpers = Console.SetOut(sw) let ew = new StringWriter() Console.SetError(ew) + try try Directory.SetCurrentDirectory directory let exitCode, output = FscCompiler(legacyReferenceResolver).Compile(args) - let consoleOut = sw.ToString().Split([|'\r'; '\n'|], StringSplitOptions.RemoveEmptyEntries) - let consoleError = ew.ToString().Split([|'\r'; '\n'|], StringSplitOptions.RemoveEmptyEntries) + + let consoleOut = + sw.ToString().Split([| '\r'; '\n' |], StringSplitOptions.RemoveEmptyEntries) + + let consoleError = + ew.ToString().Split([| '\r'; '\n' |], StringSplitOptions.RemoveEmptyEntries) + exitCode, [| yield! consoleOut; yield! output |], consoleError with e -> - 1, [| "Internal compiler error"; e.ToString().Replace('\n', ' ').Replace('\r', ' ') |], [| |] + 1, + [| + "Internal compiler error" + e.ToString().Replace('\n', ' ').Replace('\r', ' ') + |], + [||] finally Console.SetOut(origOut) Console.SetError(origError) - - diff --git a/src/Compiler/Optimize/DetupleArgs.fs b/src/Compiler/Optimize/DetupleArgs.fs index 4f749a689c1..0021357366c 100644 --- a/src/Compiler/Optimize/DetupleArgs.fs +++ b/src/Compiler/Optimize/DetupleArgs.fs @@ -1,9 +1,9 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -module internal FSharp.Compiler.Detuple +module internal FSharp.Compiler.Detuple open Internal.Utilities.Collections -open Internal.Utilities.Library +open Internal.Utilities.Library open Internal.Utilities.Library.Extras open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.Syntax @@ -23,8 +23,8 @@ let DetupleRewriteStackGuardDepth = StackGuard.GetDepthOption "DetupleRewrite" // Private, non-top-level functions fOrig which had explicit tuples at all callsites, // have been replaced by transformedVal taking the individual tuple fields, // subject to the type of the fOrig formal permitting the split. -// -// The decisions are based on call site analysis +// +// The decisions are based on call site analysis // //---------- // TUPLE COLLAPSE SIMPLIFIED. @@ -51,7 +51,7 @@ let DetupleRewriteStackGuardDepth = StackGuard.GetDepthOption "DetupleRewrite" // -> // let rec transformedVal p1 p2 = let p = p1, p2 // ... (transformedVal a b) ... -// +// // transformedVal x y // // Q: What about cases where some calls to fOrig provide just a tuple? @@ -147,27 +147,30 @@ let DetupleRewriteStackGuardDepth = StackGuard.GetDepthOption "DetupleRewrite" // Note: now considering defn projection requirements in decision. // no longer can assume that all call sites have explicit tuples if collapsing. // in these new cases, take care to have let binding sequence (eval order...) - + // Merge a tyapp node and and app node. -let (|TyappAndApp|_|) e = - match e with - | Expr.App (f, fty, tys, args, m) -> +let (|TyappAndApp|_|) e = + match e with + | Expr.App(f, fty, tys, args, m) -> match stripDebugPoints (stripExpr f) with - | Expr.App (f2, fty2, tys2, [], m2) -> Some(f2, fty2, tys2 @ tys, args, m2) - | Expr.App _ -> Some(f, fty, tys, args, m) (* has args, so not combine ty args *) - | f -> Some(f, fty, tys, args, m) + | Expr.App(f2, fty2, tys2, [], m2) -> Some(f2, fty2, tys2 @ tys, args, m2) + | Expr.App _ -> Some(f, fty, tys, args, m) (* has args, so not combine ty args *) + | f -> Some(f, fty, tys, args, m) | _ -> None [] -module GlobalUsageAnalysis = - let bindAccBounds vals (_isInDTree, v) = Zset.add v vals +module GlobalUsageAnalysis = + let bindAccBounds vals (_isInDTree, v) = Zset.add v vals let GetValsBoundInExpr expr = - let folder = {ExprFolder0 with valBindingSiteIntercept = bindAccBounds} - let z0 = Zset.empty valOrder - let z = FoldExpr folder z0 expr - z + let folder = + { ExprFolder0 with + valBindingSiteIntercept = bindAccBounds } + + let z0 = Zset.empty valOrder + let z = FoldExpr folder z0 expr + z type accessor = TupleGet of int * TType list @@ -177,65 +180,86 @@ module GlobalUsageAnalysis = /// where first accessor in list applies first to the v/app. /// (b) log it's binding site representation. type Results = - { - /// v -> context / APP inst args - Uses : Zmap + { + /// v -> context / APP inst args + Uses: Zmap - /// v -> binding repr - Defns : Zmap + /// v -> binding repr + Defns: Zmap - /// bound in a decision tree? - DecisionTreeBindings: Zset + /// bound in a decision tree? + DecisionTreeBindings: Zset - /// v -> v list * recursive? -- the others in the mutual binding - RecursiveBindings: Zmap + /// v -> v list * recursive? -- the others in the mutual binding + RecursiveBindings: Zmap - TopLevelBindings: Zset + TopLevelBindings: Zset - IterationIsAtTopLevel: bool - } + IterationIsAtTopLevel: bool + } let z0 = - { Uses = Zmap.empty valOrder - Defns = Zmap.empty valOrder - RecursiveBindings = Zmap.empty valOrder - DecisionTreeBindings = Zset.empty valOrder - TopLevelBindings = Zset.empty valOrder - IterationIsAtTopLevel = true } + { Uses = Zmap.empty valOrder + Defns = Zmap.empty valOrder + RecursiveBindings = Zmap.empty valOrder + DecisionTreeBindings = Zset.empty valOrder + TopLevelBindings = Zset.empty valOrder + IterationIsAtTopLevel = true } /// Log the use of a value with a particular tuple shape at a callsite /// Note: this routine is called very frequently let logUse (f: Val) tup z = - {z with Uses = - match Zmap.tryFind f z.Uses with - | Some sites -> Zmap.add f (tup :: sites) z.Uses - | None -> Zmap.add f [tup] z.Uses } + { z with + Uses = + match Zmap.tryFind f z.Uses with + | Some sites -> Zmap.add f (tup :: sites) z.Uses + | None -> Zmap.add f [ tup ] z.Uses } /// Log the definition of a binding let logBinding z (isInDTree, v) = - let z = if isInDTree then {z with DecisionTreeBindings = Zset.add v z.DecisionTreeBindings} else z - let z = if z.IterationIsAtTopLevel then {z with TopLevelBindings = Zset.add v z.TopLevelBindings} else z + let z = + if isInDTree then + { z with + DecisionTreeBindings = Zset.add v z.DecisionTreeBindings } + else + z + + let z = + if z.IterationIsAtTopLevel then + { z with + TopLevelBindings = Zset.add v z.TopLevelBindings } + else + z + z /// Log the definition of a non-recursive binding let logNonRecBinding z (bind: Binding) = let v = bind.Var - let vs = [v] - {z with RecursiveBindings = Zmap.add v (false, vs) z.RecursiveBindings - Defns = Zmap.add v bind.Expr z.Defns } + let vs = [ v ] + + { z with + RecursiveBindings = Zmap.add v (false, vs) z.RecursiveBindings + Defns = Zmap.add v bind.Expr z.Defns } /// Log the definition of a recursive binding let logRecBindings z binds = let vs = valsOfBinds binds - {z with RecursiveBindings = (z.RecursiveBindings, vs) ||> List.fold (fun mubinds v -> Zmap.add v (true, vs) mubinds) - Defns = (z.Defns, binds) ||> List.fold (fun eqns bind -> Zmap.add bind.Var bind.Expr eqns) } + + { z with + RecursiveBindings = + (z.RecursiveBindings, vs) + ||> List.fold (fun mubinds v -> Zmap.add v (true, vs) mubinds) + Defns = + (z.Defns, binds) + ||> List.fold (fun eqns bind -> Zmap.add bind.Var bind.Expr eqns) } /// Work locally under a lambda of some kind let foldUnderLambda f z x = let saved = z.IterationIsAtTopLevel - let z = {z with IterationIsAtTopLevel=false} + let z = { z with IterationIsAtTopLevel = false } let z = f z x - let z = {z with IterationIsAtTopLevel=saved} + let z = { z with IterationIsAtTopLevel = saved } z //------------------------------------------------------------------------- @@ -256,59 +280,62 @@ module GlobalUsageAnalysis = // - match targets // - tmethods let UsageFolders (g: TcGlobals) = - let foldLocalVal f z (vref: ValRef) = - if valRefInThisAssembly g.compilingFSharpCore vref then f z vref.Deref - else z - - let exprUsageIntercept exprF noInterceptF z origExpr = - - let rec recognise context expr = - match expr with - | Expr.Val (v, _, _) -> - // YES: count free occurrence - foldLocalVal (fun z v -> logUse v (context, [], []) z) z v - - | TyappAndApp(f, _, tys, args, _) -> - match f with - | Expr.Val (fOrig, _, _) -> - // app where function is val - // YES: count instance/app (app when have term args), and then - // collect from args (have intercepted this node) - let collect z f = logUse f (context, tys, args) z - let z = foldLocalVal collect z fOrig - List.fold exprF z args - | _ -> - // NO: app but function is not val - noInterceptF z origExpr - - | Expr.Op (TOp.TupleFieldGet (tupInfo, n), ts, [x], _) when not (evalTupInfoIsStruct tupInfo) -> - let context = TupleGet (n, ts) :: context - recognise context x - - // lambdas end top-level status - | Expr.Lambda (_id, _ctorThisValOpt, _baseValOpt, _vs, body, _, _) -> - foldUnderLambda exprF z body - - | Expr.TyLambda (_id, _tps, body, _, _) -> - foldUnderLambda exprF z body - - | _ -> - noInterceptF z origExpr - - let context = [] - recognise context origExpr - - let targetIntercept exprF z = function TTarget(_argvs, body, _) -> Some (foldUnderLambda exprF z body) - let tmethodIntercept exprF z = function TObjExprMethod(_, _, _, _, e, _m) -> Some (foldUnderLambda exprF z e) - - {ExprFolder0 with - exprIntercept = exprUsageIntercept - nonRecBindingsIntercept = logNonRecBinding - recBindingsIntercept = logRecBindings - valBindingSiteIntercept = logBinding - targetIntercept = targetIntercept - tmethodIntercept = tmethodIntercept - } + let foldLocalVal f z (vref: ValRef) = + if valRefInThisAssembly g.compilingFSharpCore vref then + f z vref.Deref + else + z + + let exprUsageIntercept exprF noInterceptF z origExpr = + + let rec recognise context expr = + match expr with + | Expr.Val(v, _, _) -> + // YES: count free occurrence + foldLocalVal (fun z v -> logUse v (context, [], []) z) z v + + | TyappAndApp(f, _, tys, args, _) -> + match f with + | Expr.Val(fOrig, _, _) -> + // app where function is val + // YES: count instance/app (app when have term args), and then + // collect from args (have intercepted this node) + let collect z f = logUse f (context, tys, args) z + let z = foldLocalVal collect z fOrig + List.fold exprF z args + | _ -> + // NO: app but function is not val + noInterceptF z origExpr + + | Expr.Op(TOp.TupleFieldGet(tupInfo, n), ts, [ x ], _) when not (evalTupInfoIsStruct tupInfo) -> + let context = TupleGet(n, ts) :: context + recognise context x + + // lambdas end top-level status + | Expr.Lambda(_id, _ctorThisValOpt, _baseValOpt, _vs, body, _, _) -> foldUnderLambda exprF z body + + | Expr.TyLambda(_id, _tps, body, _, _) -> foldUnderLambda exprF z body + + | _ -> noInterceptF z origExpr + + let context = [] + recognise context origExpr + + let targetIntercept exprF z = + function + | TTarget(_argvs, body, _) -> Some(foldUnderLambda exprF z body) + + let tmethodIntercept exprF z = + function + | TObjExprMethod(_, _, _, _, e, _m) -> Some(foldUnderLambda exprF z e) + + { ExprFolder0 with + exprIntercept = exprUsageIntercept + nonRecBindingsIntercept = logNonRecBinding + recBindingsIntercept = logRecBindings + valBindingSiteIntercept = logBinding + targetIntercept = targetIntercept + tmethodIntercept = tmethodIntercept } //------------------------------------------------------------------------- // GlobalUsageAnalysis - entry point @@ -319,96 +346,125 @@ module GlobalUsageAnalysis = let z = FoldImplFile folder z0 expr z -let internalError str = raise(Failure(str)) +let internalError str = raise (Failure(str)) let mkLocalVal m name ty valReprInfo = let compgen = false - Construct.NewVal(name, m, None, ty, Immutable, compgen, valReprInfo, taccessPublic, ValNotInRecScope, None, NormalVal, [], ValInline.Optional, XmlDoc.Empty, false, false, false, false, false, false, None, ParentNone) + + Construct.NewVal( + name, + m, + None, + ty, + Immutable, + compgen, + valReprInfo, + taccessPublic, + ValNotInRecScope, + None, + NormalVal, + [], + ValInline.Optional, + XmlDoc.Empty, + false, + false, + false, + false, + false, + false, + None, + ParentNone + ) /// Represents inferred information about a tuple value -type TupleStructure = +type TupleStructure = | UnknownTS - | TupleTS of TupleStructure list + | TupleTS of TupleStructure list -let rec ValReprInfoForTS ts = - match ts with - | UnknownTS -> [ValReprInfo.unnamedTopArg] - | TupleTS ts -> ts |> List.collect ValReprInfoForTS +let rec ValReprInfoForTS ts = + match ts with + | UnknownTS -> [ ValReprInfo.unnamedTopArg ] + | TupleTS ts -> ts |> List.collect ValReprInfoForTS let rec andTS ts tsB = match ts, tsB with | _, UnknownTS -> UnknownTS | UnknownTS, _ -> UnknownTS - | TupleTS ss, TupleTS ssB -> - if ss.Length <> ssB.Length then UnknownTS (* different tuple instances *) - else TupleTS (List.map2 andTS ss ssB) - -let checkTS = function + | TupleTS ss, TupleTS ssB -> + if ss.Length <> ssB.Length then + UnknownTS (* different tuple instances *) + else + TupleTS(List.map2 andTS ss ssB) + +let checkTS = + function | TupleTS [] -> internalError "exprTS: Tuple[] not expected. (units not done that way)." - | TupleTS [_] -> internalError "exprTS: Tuple[x] not expected. (singleton tuples should not exist." - | ts -> ts - -/// explicit tuple-structure in expr -let rec uncheckedExprTS expr = - match expr with - | Expr.Op (TOp.Tuple tupInfo, _tys, args, _) when not (evalTupInfoIsStruct tupInfo) -> - TupleTS (List.map uncheckedExprTS args) - | _ -> - UnknownTS + | TupleTS [ _ ] -> internalError "exprTS: Tuple[x] not expected. (singleton tuples should not exist." + | ts -> ts + +/// explicit tuple-structure in expr +let rec uncheckedExprTS expr = + match expr with + | Expr.Op(TOp.Tuple tupInfo, _tys, args, _) when not (evalTupInfoIsStruct tupInfo) -> + TupleTS(List.map uncheckedExprTS args) + | _ -> UnknownTS let rec uncheckedTypeTS g ty = - if isRefTupleTy g ty then - let tys = destRefTupleTy g ty - TupleTS (List.map (uncheckedTypeTS g) tys) - else + if isRefTupleTy g ty then + let tys = destRefTupleTy g ty + TupleTS(List.map (uncheckedTypeTS g) tys) + else UnknownTS let exprTS exprs = exprs |> uncheckedExprTS |> checkTS let typeTS g tys = tys |> uncheckedTypeTS g |> checkTS let rebuildTS g m ts vs = - let rec rebuild vs ts = - match vs, ts with - | [], UnknownTS -> internalError "rebuildTS: not enough fringe to build tuple" - | v :: vs, UnknownTS -> (exprForVal m v, v.Type), vs - | vs, TupleTS tss -> - let xtys, vs = List.mapFold rebuild vs tss - let xs, tys = List.unzip xtys - let x = mkRefTupled g m xs tys - let ty = mkRefTupledTy g tys - (x, ty), vs - + let rec rebuild vs ts = + match vs, ts with + | [], UnknownTS -> internalError "rebuildTS: not enough fringe to build tuple" + | v :: vs, UnknownTS -> (exprForVal m v, v.Type), vs + | vs, TupleTS tss -> + let xtys, vs = List.mapFold rebuild vs tss + let xs, tys = List.unzip xtys + let x = mkRefTupled g m xs tys + let ty = mkRefTupledTy g tys + (x, ty), vs + let (x, _ty), vs = rebuild vs ts - if vs.Length <> 0 then internalError "rebuildTS: had more fringe vars than fringe. REPORT BUG" + + if vs.Length <> 0 then + internalError "rebuildTS: had more fringe vars than fringe. REPORT BUG" + x /// CallPattern is tuple-structure for each argument position. /// - callsites have a CallPattern (possibly instancing fOrig at tuple types...). /// - the definition lambdas may imply a one-level CallPattern /// - the definition formal projection info suggests a CallPattern -type CallPattern = TupleStructure list - +type CallPattern = TupleStructure list + let argsCP exprs = List.map exprTS exprs let inline isTrivialCP xs = isNil xs let rec minimalCallPattern callPattern = - match callPattern with - | [] -> [] - | UnknownTS :: tss -> + match callPattern with + | [] -> [] + | UnknownTS :: tss -> match minimalCallPattern tss with - | [] -> [] (* drop trailing UnknownTS *) + | [] -> [] (* drop trailing UnknownTS *) | tss -> UnknownTS :: tss (* non triv tss tail *) | TupleTS ts :: tss -> TupleTS ts :: minimalCallPattern tss /// Combines a list of callpatterns into one common callpattern. let commonCallPattern callPatterns = let rec andCPs cpA cpB = - match cpA, cpB with - | [], [] -> [] - | tsA :: tsAs, tsB :: tsBs -> andTS tsA tsB :: andCPs tsAs tsBs - | _tsA :: _tsAs, [] -> [] (* now trim to shortest - UnknownTS :: andCPs tsAs [] *) - | [], _tsB :: _tsBs -> [] (* now trim to shortest - UnknownTS :: andCPs [] tsBs *) - + match cpA, cpB with + | [], [] -> [] + | tsA :: tsAs, tsB :: tsBs -> andTS tsA tsB :: andCPs tsAs tsBs + | _tsA :: _tsAs, [] -> [] (* now trim to shortest - UnknownTS :: andCPs tsAs [] *) + | [], _tsB :: _tsBs -> [] (* now trim to shortest - UnknownTS :: andCPs [] tsBs *) + List.reduce andCPs callPatterns let siteCP (_accessors, _inst, args) = argsCP args @@ -419,23 +475,23 @@ let sitesCPs sites = List.map siteCP sites //------------------------------------------------------------------------- type TransformedFormal = - // Indicates that - // - the actual arg in this position is unchanged - // - also means that we keep the original formal arg - | SameArg + // Indicates that + // - the actual arg in this position is unchanged + // - also means that we keep the original formal arg + | SameArg - // Indicates - // - the new formals for the transform - // - expr is tuple of the formals - | NewArgs of Val list * Expr + // Indicates + // - the new formals for the transform + // - expr is tuple of the formals + | NewArgs of Val list * Expr /// Info needed to convert f to curried form. /// - yb1..ybp - replacement formal choices for x1...xp. /// - transformedVal - replaces f. type Transform = - { transformCallPattern : CallPattern - transformedFormals : TransformedFormal list - transformedVal : Val } + { transformCallPattern: CallPattern + transformedFormals: TransformedFormal list + transformedVal: Val } //------------------------------------------------------------------------- @@ -443,41 +499,65 @@ type Transform = //------------------------------------------------------------------------- let mkTransform g (f: Val) m tps x1Ntys retTy (callPattern, tyfringes: (TType list * Val list) list) = - // Create formal choices for x1...xp under callPattern - let transformedFormals = - (callPattern, tyfringes) ||> List.map2 (fun cpi (tyfringe, vs) -> + // Create formal choices for x1...xp under callPattern + let transformedFormals = + (callPattern, tyfringes) + ||> List.map2 (fun cpi (tyfringe, vs) -> match cpi with - | UnknownTS -> SameArg - | TupleTS [] -> SameArg - | TupleTS _ -> + | UnknownTS -> SameArg + | TupleTS [] -> SameArg + | TupleTS _ -> // Try to keep the same names for the arguments if possible - let vs = - if vs.Length = tyfringe.Length then + let vs = + if vs.Length = tyfringe.Length then vs |> List.map (fun v -> mkCompGenLocal v.Range v.LogicalName v.Type |> fst) else - let baseName = match vs with [v] -> v.LogicalName | _ -> "arg" - let baseRange = match vs with [v] -> v.Range | _ -> m - tyfringe |> List.mapi (fun i ty -> + let baseName = + match vs with + | [ v ] -> v.LogicalName + | _ -> "arg" + + let baseRange = + match vs with + | [ v ] -> v.Range + | _ -> m + + tyfringe + |> List.mapi (fun i ty -> let name = baseName + string i mkCompGenLocal baseRange name ty |> fst) - - NewArgs (vs, rebuildTS g m cpi vs)) - - // Create transformedVal replacement for f - // Mark the arity of the value - let valReprInfo = - match f.ValReprInfo with - | None -> None - | _ -> Some(ValReprInfo (ValReprInfo.InferTyparInfo tps, List.collect ValReprInfoForTS callPattern, ValReprInfo.unnamedRetVal)) + + NewArgs(vs, rebuildTS g m cpi vs)) + + // Create transformedVal replacement for f + // Mark the arity of the value + let valReprInfo = + match f.ValReprInfo with + | None -> None + | _ -> + Some( + ValReprInfo( + ValReprInfo.InferTyparInfo tps, + List.collect ValReprInfoForTS callPattern, + ValReprInfo.unnamedRetVal + ) + ) (* type(transformedVal) tyfringes types replace initial arg types of f *) - let tys1r = List.collect fst tyfringes (* types for collapsed initial r args *) - let tysrN = List.skip tyfringes.Length x1Ntys (* types for remaining args *) + let tys1r = List.collect fst tyfringes (* types for collapsed initial r args *) + let tysrN = List.skip tyfringes.Length x1Ntys (* types for remaining args *) let argTys = tys1r @ tysrN let fCty = mkLambdaTy g tps argTys retTy + let transformedVal = // Ensure that we have an g.CompilerGlobalState - assert(g.CompilerGlobalState |> Option.isSome) - mkLocalVal f.Range (g.CompilerGlobalState.Value.NiceNameGenerator.FreshCompilerGeneratedName (f.LogicalName, f.Range)) fCty valReprInfo + assert (g.CompilerGlobalState |> Option.isSome) + + mkLocalVal + f.Range + (g.CompilerGlobalState.Value.NiceNameGenerator.FreshCompilerGeneratedName(f.LogicalName, f.Range)) + fCty + valReprInfo + { transformCallPattern = callPattern transformedFormals = transformedFormals transformedVal = transformedVal } @@ -493,22 +573,27 @@ let rec zipTupleStructureAndType g ts ty = // (b) type fringe for each arg position. match ts with | TupleTS tss when isRefTupleTy g ty -> - let tys = destRefTupleTy g ty + let tys = destRefTupleTy g ty let tss, tyfringe = zipTupleStructuresAndTypes g tss tys TupleTS tss, tyfringe - | _ -> - UnknownTS, [ty] (* trim back CallPattern, function more general *) + | _ -> UnknownTS, [ ty ] (* trim back CallPattern, function more general *) and zipTupleStructuresAndTypes g tss tys = - let tstys = List.map2 (zipTupleStructureAndType g) tss tys // assumes tss tys same length - let tss = List.map fst tstys - let tys = List.collect snd tstys // link fringes + let tstys = List.map2 (zipTupleStructureAndType g) tss tys // assumes tss tys same length + let tss = List.map fst tstys + let tys = List.collect snd tstys // link fringes tss, tys -let zipCallPatternArgTys m g (callPattern : TupleStructure list) (vss : Val list list) = - let vss = List.take callPattern.Length vss // drop excessive tys if callPattern shorter - let tstys = List.map2 (fun ts vs -> let ts, tyfringe = zipTupleStructureAndType g ts (typeOfLambdaArg m vs) in ts, (tyfringe, vs)) callPattern vss - List.unzip tstys +let zipCallPatternArgTys m g (callPattern: TupleStructure list) (vss: Val list list) = + let vss = List.take callPattern.Length vss // drop excessive tys if callPattern shorter + + let tstys = + List.map2 + (fun ts vs -> let ts, tyfringe = zipTupleStructureAndType g ts (typeOfLambdaArg m vs) in ts, (tyfringe, vs)) + callPattern + vss + + List.unzip tstys //------------------------------------------------------------------------- // transform - vTransforms - defnSuggestedCP @@ -522,24 +607,28 @@ let decideFormalSuggestedCP g z tys vss = let rec trimTsByAccess accessors ts = match ts, accessors with - | UnknownTS, _ -> UnknownTS - | TupleTS _tss, [] -> UnknownTS (* trim it, require the val at this point *) - | TupleTS tss, TupleGet (i, _ty) :: accessors -> + | UnknownTS, _ -> UnknownTS + | TupleTS _tss, [] -> UnknownTS (* trim it, require the val at this point *) + | TupleTS tss, TupleGet(i, _ty) :: accessors -> let tss = List.mapNth i (trimTsByAccess accessors) tss TupleTS tss let trimTsByVal z ts v = match Zmap.tryFind v z.Uses with - | None -> UnknownTS (* formal has no usage info, it is unused *) - | Some sites -> + | None -> UnknownTS (* formal has no usage info, it is unused *) + | Some sites -> let trim ts (accessors, _inst, _args) = trimTsByAccess accessors ts List.fold trim ts sites - let trimTsByFormal z ts vss = - match vss with - | [v] -> trimTsByVal z ts v - | vs -> - let tss = match ts with TupleTS tss -> tss | _ -> internalError "trimByFormal: ts must be tuple?? PLEASE REPORT\n" + let trimTsByFormal z ts vss = + match vss with + | [ v ] -> trimTsByVal z ts v + | vs -> + let tss = + match ts with + | TupleTS tss -> tss + | _ -> internalError "trimByFormal: ts must be tuple?? PLEASE REPORT\n" + let tss = List.map2 (trimTsByVal z) tss vs TupleTS tss @@ -554,77 +643,82 @@ let decideFormalSuggestedCP g z tys vss = let decideTransform g z v callPatterns (m, tps, vss: Val list list, retTy) = let tys = List.map (typeOfLambdaArg m) vss - // NOTE: 'a in arg types may have been instanced at different tuples... + // NOTE: 'a in arg types may have been instanced at different tuples... // commonCallPattern has to handle those cases. - let callPattern = commonCallPattern callPatterns + let callPattern = commonCallPattern callPatterns - // Restrict to max nArgs + // Restrict to max nArgs let callPattern = List.truncate vss.Length callPattern - // Get formal callPattern by defn usage of formals - let formalCallPattern = decideFormalSuggestedCP g z tys vss + // Get formal callPattern by defn usage of formals + let formalCallPattern = decideFormalSuggestedCP g z tys vss let callPattern = List.truncate callPattern.Length formalCallPattern - // Zip with information about known args + // Zip with information about known args let callPattern, tyfringes = zipCallPatternArgTys m g callPattern vss - // Drop trivial tail AND - let callPattern = minimalCallPattern callPattern + // Drop trivial tail AND + let callPattern = minimalCallPattern callPattern + + // Shorten tyfringes (zippable) + let tyfringes = List.truncate callPattern.Length tyfringes - // Shorten tyfringes (zippable) - let tyfringes = List.truncate callPattern.Length tyfringes if isTrivialCP callPattern then - None // no transform + None // no transform else - Some (v, mkTransform g v m tps tys retTy (callPattern, tyfringes)) + Some(v, mkTransform g v m tps tys retTy (callPattern, tyfringes)) //------------------------------------------------------------------------- // transform - determineTransforms //------------------------------------------------------------------------- - + // Public f could be used beyond assembly. // For now, suppressing any transforms on these. -// Later, could transform f and fix up local calls and provide an f wrapper for beyond. +// Later, could transform f and fix up local calls and provide an f wrapper for beyond. let eligibleVal g m (v: Val) = let dllImportStubOrOtherNeverInline = (v.InlineInfo = ValInline.Never) let mutableVal = v.IsMutable let byrefVal = isByrefLikeTy g m v.Type - not dllImportStubOrOtherNeverInline && - not byrefVal && - not mutableVal && - not v.IsMemberOrModuleBinding && // .IsCompiledAsTopLevel && - not v.IsCompiledAsTopLevel - -let determineTransforms g (z : GlobalUsageAnalysis.Results) = - let selectTransform (f: Val) sites = - if not (eligibleVal g f.Range f) then None else - // Consider f, if it has top-level lambda (meaning has term args) - match Zmap.tryFind f z.Defns with - | None -> None // no binding site, so no transform - | Some e -> - let tps, vss, _b, retTy = stripTopLambda (e, f.Type) - match List.concat vss with - | [] -> None // defn has no term args - | arg1 :: _ -> // consider f - let m = arg1.Range // mark of first arg, mostly for error reporting - let callPatterns = sitesCPs sites // callPatterns from sites - decideTransform g z f callPatterns (m, tps, vss, retTy) // make transform (if required) - - let vtransforms = Zmap.chooseL selectTransform z.Uses - let vtransforms = Zmap.ofList valOrder vtransforms - vtransforms + + not dllImportStubOrOtherNeverInline + && not byrefVal + && not mutableVal + && not v.IsMemberOrModuleBinding + && not // .IsCompiledAsTopLevel && + v.IsCompiledAsTopLevel + +let determineTransforms g (z: GlobalUsageAnalysis.Results) = + let selectTransform (f: Val) sites = + if not (eligibleVal g f.Range f) then + None + else + // Consider f, if it has top-level lambda (meaning has term args) + match Zmap.tryFind f z.Defns with + | None -> None // no binding site, so no transform + | Some e -> + let tps, vss, _b, retTy = stripTopLambda (e, f.Type) + + match List.concat vss with + | [] -> None // defn has no term args + | arg1 :: _ -> // consider f + let m = arg1.Range // mark of first arg, mostly for error reporting + let callPatterns = sitesCPs sites // callPatterns from sites + decideTransform g z f callPatterns (m, tps, vss, retTy) // make transform (if required) + + let vtransforms = Zmap.chooseL selectTransform z.Uses + let vtransforms = Zmap.ofList valOrder vtransforms + vtransforms //------------------------------------------------------------------------- // pass - penv - env of pass //------------------------------------------------------------------------- type penv = - { // The planned transforms + { // The planned transforms transforms: Zmap ccu: CcuThunk - g: TcGlobals - } + g: TcGlobals } let hasTransfrom penv f = Zmap.tryFind f penv.transforms @@ -638,47 +732,49 @@ let hasTransfrom penv f = Zmap.tryFind f penv.transforms - also factor buildProjections, so they share common tmps. *) -type env = - { - eg: TcGlobals +type env = + { eg: TcGlobals prefix: string - m: range - } + m: range } override _.ToString() = "" -let suffixE env s = {env with prefix = env.prefix + s} +let suffixE env s = { env with prefix = env.prefix + s } -let rangeE env m = {env with m = m} +let rangeE env m = { env with m = m } -let push b bs = b :: bs +let push b bs = b :: bs -let pushL xs bs = xs@bs +let pushL xs bs = xs @ bs -let newLocal env ty = mkCompGenLocal env.m env.prefix ty +let newLocal env ty = mkCompGenLocal env.m env.prefix ty -let newLocalN env i ty = mkCompGenLocal env.m (env.prefix + string i) ty +let newLocalN env i ty = + mkCompGenLocal env.m (env.prefix + string i) ty let noEffectExpr env bindings x = match x with - | Expr.Val (_v, _, _m) -> bindings, x - | x -> + | Expr.Val(_v, _, _m) -> bindings, x + | x -> let tmp, xtmp = newLocal env (tyOfExpr env.eg x) let bind = mkCompGenBind tmp x push bind bindings, xtmp -// Given 'e', build +// Given 'e', build // let v1 = e#1 // let v2 = e#N let buildProjections env bindings x xtys = - let binds, vixs = - xtys + let binds, vixs = + xtys |> List.mapi (fun i xty -> let vi, vix = newLocalN env i xty - let bind = mkBind DebugPointAtBinding.NoneAtInvisible vi (mkTupleFieldGet env.eg (tupInfoRef, x, xtys, i, env.m)) + + let bind = + mkBind DebugPointAtBinding.NoneAtInvisible vi (mkTupleFieldGet env.eg (tupInfoRef, x, xtys, i, env.m)) + bind, vix) |> List.unzip @@ -689,17 +785,18 @@ let buildProjections env bindings x xtys = let rec collapseArg env bindings ts (x: Expr) = let m = x.Range let env = rangeE env m + match ts, x with - | UnknownTS, x -> + | UnknownTS, x -> let bindings, vx = noEffectExpr env bindings x - bindings, [vx] - | TupleTS tss, Expr.Op (TOp.Tuple tupInfo, _xtys, xs, _) when not (evalTupInfoIsStruct tupInfo) -> + bindings, [ vx ] + | TupleTS tss, Expr.Op(TOp.Tuple tupInfo, _xtys, xs, _) when not (evalTupInfoIsStruct tupInfo) -> let env = suffixE env "'" collapseArgs env bindings 1 tss xs - | TupleTS tss, x -> - // project components + | TupleTS tss, x -> + // project components let bindings, x = noEffectExpr env bindings x - let env = suffixE env "_p" + let env = suffixE env "_p" let xty = tyOfExpr env.eg x let xtys = destRefTupleTy env.eg xty let bindings, xs = buildProjections env bindings x xtys @@ -707,46 +804,44 @@ let rec collapseArg env bindings ts (x: Expr) = and collapseArgs env bindings n callPattern args = match callPattern, args with - | [], args -> bindings, args - | ts :: tss, arg :: args -> + | [], args -> bindings, args + | ts :: tss, arg :: args -> let env1 = suffixE env (string n) - let bindings, xty = collapseArg env1 bindings ts arg - let bindings, xtys = collapseArgs env bindings (n+1) tss args + let bindings, xty = collapseArg env1 bindings ts arg + let bindings, xtys = collapseArgs env bindings (n + 1) tss args bindings, xty @ xtys - | _ts :: _tss, [] -> - internalError "collapseArgs: CallPattern longer than callsite args. REPORT BUG" + | _ts :: _tss, [] -> internalError "collapseArgs: CallPattern longer than callsite args. REPORT BUG" //------------------------------------------------------------------------- // pass - app fixup //------------------------------------------------------------------------- -// REVIEW: use mkLet etc. -let mkLets binds (body: Expr) = - (binds, body) ||> List.foldBack (fun b acc -> mkLetBind acc.Range b acc) +// REVIEW: use mkLet etc. +let mkLets binds (body: Expr) = + (binds, body) ||> List.foldBack (fun b acc -> mkLetBind acc.Range b acc) let fixupApp (penv: penv) (fx, fty, tys, args, m) = - // Is it a val app, where the val has a transform? + // Is it a val app, where the val has a transform? match fx with - | Expr.Val (vref, _, vm) -> + | Expr.Val(vref, _, vm) -> let f = vref.Deref + match hasTransfrom penv f with - | Some trans -> - // fix it - let callPattern = trans.transformCallPattern - let transformedVal = trans.transformedVal + | Some trans -> + // fix it + let callPattern = trans.transformCallPattern + let transformedVal = trans.transformedVal let fCty = transformedVal.Type let fCx = exprForVal vm transformedVal (* [[f tps args ]] -> transformedVal tps [[COLLAPSED: args]] *) - let env = {prefix = "arg";m = m;eg=penv.g} + let env = { prefix = "arg"; m = m; eg = penv.g } let bindings = [] let bindings, args = collapseArgs env bindings 0 callPattern args let bindings = List.rev bindings - mkLets bindings (Expr.App (fCx, fCty, tys, args, m)) - | None -> - Expr.App (fx, fty, tys, args, m) (* no change, f untransformed val *) - | _ -> - Expr.App (fx, fty, tys, args, m) (* no change, f is expr *) + mkLets bindings (Expr.App(fCx, fCty, tys, args, m)) + | None -> Expr.App(fx, fty, tys, args, m) (* no change, f untransformed val *) + | _ -> Expr.App(fx, fty, tys, args, m) (* no change, f is expr *) //------------------------------------------------------------------------- // pass - mubinds - translation support @@ -754,14 +849,14 @@ let fixupApp (penv: penv) (fx, fty, tys, args, m) = let transFormal ybi xi = match ybi with - | SameArg -> [xi] // one arg - where arg=vpsecs - | NewArgs (vs, _x) -> vs |> List.map List.singleton // many args + | SameArg -> [ xi ] // one arg - where arg=vpsecs + | NewArgs(vs, _x) -> vs |> List.map List.singleton // many args let transRebind ybi xi = match xi, ybi with - | _, SameArg -> [] (* no rebinding, reused original formal *) - | [u], NewArgs (_vs, x) -> [mkCompGenBind u x] - | us, NewArgs (_vs, x) -> List.map2 mkCompGenBind us (tryDestRefTupleExpr x) + | _, SameArg -> [] (* no rebinding, reused original formal *) + | [ u ], NewArgs(_vs, x) -> [ mkCompGenBind u x ] + | us, NewArgs(_vs, x) -> List.map2 mkCompGenBind us (tryDestRefTupleExpr x) //------------------------------------------------------------------------- @@ -783,35 +878,39 @@ let transRebind ybi xi = // let passBind penv (TBind(fOrig, repr, letSeqPtOpt) as bind) = - let g = penv.g - let m = fOrig.Range - match hasTransfrom penv fOrig with - | None -> - // fOrig no transform - bind - | Some trans -> - // fOrig has transform - let tps, vss, body, retTy = stripTopLambda (repr, fOrig.Type) - // transformedVal is curried version of fOrig - let transformedVal = trans.transformedVal - // fCBody - parts - formals - let transformedFormals = trans.transformedFormals - let p = transformedFormals.Length - if (vss.Length < p) then internalError "passBinds: |vss|

List.map (passBind penv) + let g = penv.g + let m = fOrig.Range + + match hasTransfrom penv fOrig with + | None -> + // fOrig no transform + bind + | Some trans -> + // fOrig has transform + let tps, vss, body, retTy = stripTopLambda (repr, fOrig.Type) + // transformedVal is curried version of fOrig + let transformedVal = trans.transformedVal + // fCBody - parts - formals + let transformedFormals = trans.transformedFormals + let p = transformedFormals.Length + + if (vss.Length < p) then + internalError "passBinds: |vss|

List.map (passBind penv) //------------------------------------------------------------------------- // pass - passBindRhs @@ -826,24 +925,25 @@ let passBinds penv binds = binds |> List.map (passBind penv) let postTransformExpr (penv: penv) expr = match expr with - | Expr.LetRec (binds, e, m, _) -> + | Expr.LetRec(binds, e, m, _) -> let binds = passBinds penv binds - Some (mkLetRecBinds m binds e) - | Expr.Let (bind, e, m, _) -> + Some(mkLetRecBinds m binds e) + | Expr.Let(bind, e, m, _) -> let bind = passBind penv bind - Some (mkLetBind m bind e) + Some(mkLetBind m bind e) | TyappAndApp(f, fty, tys, args, m) -> - // match app, and fixup if needed - Some (fixupApp penv (f, fty, tys, args, m) ) + // match app, and fixup if needed + Some(fixupApp penv (f, fty, tys, args, m)) | _ -> None - -let passImplFile penv assembly = + +let passImplFile penv assembly = let rwenv = { PreIntercept = None PreInterceptBinding = None PostTransform = postTransformExpr penv RewriteQuotations = false - StackGuard = StackGuard(DetupleRewriteStackGuardDepth, "RewriteImplFile") } + StackGuard = StackGuard(DetupleRewriteStackGuardDepth, "RewriteImplFile") } + assembly |> RewriteImplFile rwenv //------------------------------------------------------------------------- @@ -851,13 +951,17 @@ let passImplFile penv assembly = //------------------------------------------------------------------------- let DetupleImplFile ccu g expr = - // Collect expr info - wanting usage contexts and bindings - let z = GetUsageInfoOfImplFile g expr + // Collect expr info - wanting usage contexts and bindings + let z = GetUsageInfoOfImplFile g expr + + // For each Val, decide Some "transform", or None if not changing + let vtrans = determineTransforms g z - // For each Val, decide Some "transform", or None if not changing - let vtrans = determineTransforms g z + // Pass over term, rewriting bindings and fixing up call sites, under penv + let penv = + { g = g + transforms = vtrans + ccu = ccu } - // Pass over term, rewriting bindings and fixing up call sites, under penv - let penv = {g=g; transforms = vtrans; ccu = ccu} - let expr = passImplFile penv expr - expr + let expr = passImplFile penv expr + expr