diff --git a/FSharp.sln b/FSharp.sln index 3cac84673ce..d2067090b8e 100644 --- a/FSharp.sln +++ b/FSharp.sln @@ -1,7 +1,7 @@  Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 14 -VisualStudioVersion = 14.0.25420.1 +# Visual Studio 15 +VisualStudioVersion = 15.0.26403.7 MinimumVisualStudioVersion = 10.0.40219.1 Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Compiler", "src\fsharp\FSharp.Compiler\FSharp.Compiler.fsproj", "{2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}" EndProject @@ -127,17 +127,18 @@ Global {649FA588-F02E-457C-9FCF-87E46407481E}.Release|Any CPU.Build.0 = Release|Any CPU {649FA588-F02E-457C-9FCF-87E46407481E}.Release|x86.ActiveCfg = Release|Any CPU {649FA588-F02E-457C-9FCF-87E46407481E}.Release|x86.Build.0 = Release|Any CPU - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|Any CPU.ActiveCfg = Debug|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|Any CPU.Build.0 = Debug|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|x86.ActiveCfg = Debug|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|x86.Build.0 = Debug|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|Any CPU.ActiveCfg = Proto|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|x86.ActiveCfg = Proto|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|x86.Build.0 = Proto|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|Any CPU.ActiveCfg = Release|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|Any CPU.Build.0 = Release|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|x86.ActiveCfg = Release|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|x86.Build.0 = Release|x86 + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|Any CPU.Build.0 = Debug|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|x86.ActiveCfg = Debug|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|x86.Build.0 = Debug|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|Any CPU.ActiveCfg = Proto|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|Any CPU.Build.0 = Proto|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|x86.ActiveCfg = Proto|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|x86.Build.0 = Proto|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|Any CPU.ActiveCfg = Release|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|Any CPU.Build.0 = Release|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|x86.ActiveCfg = Release|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|x86.Build.0 = Release|Any CPU {D0E98C0D-490B-4C61-9329-0862F6E87645}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {D0E98C0D-490B-4C61-9329-0862F6E87645}.Debug|Any CPU.Build.0 = Debug|Any CPU {D0E98C0D-490B-4C61-9329-0862F6E87645}.Debug|x86.ActiveCfg = Debug|Any CPU diff --git a/VisualFSharp.sln b/VisualFSharp.sln index ffe89f9f788..b2cd4ee00cb 100644 --- a/VisualFSharp.sln +++ b/VisualFSharp.sln @@ -1,7 +1,7 @@  Microsoft Visual Studio Solution File, Format Version 12.00 # Visual Studio 15 -VisualStudioVersion = 15.0.26403.0 +VisualStudioVersion = 15.0.26403.7 MinimumVisualStudioVersion = 10.0.40219.1 Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Compiler", "src\fsharp\FSharp.Compiler\FSharp.Compiler.fsproj", "{2E4D67B4-522D-4CF7-97E4-BA940F0B18F3}" EndProject @@ -138,6 +138,12 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "LanguageServiceProfiling", EndProject Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "FSharp.UIResources", "vsintegration\src\FSharp.UIResources\FSharp.UIResources.csproj", "{C4586A06-1402-48BC-8E35-A1B8642F895B}" EndProject +Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "CSharp_Analysis", "tests\service\data\CSharp_Analysis\CSharp_Analysis.csproj", "{887630A3-4B1D-40EA-B8B3-2D842E9C40DB}" +EndProject +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "FSharp.Compiler.Service.tests Support", "FSharp.Compiler.Service.tests Support", "{35636A82-401A-4C3A-B2AB-EB7DC5E9C268}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "TestTP", "tests\service\data\TestTP\TestTP.fsproj", "{FF76BD3C-5E0A-4752-B6C3-044F6E15719B}" +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -484,17 +490,18 @@ Global {649FA588-F02E-457C-9FCF-87E46407481E}.Release|Any CPU.Build.0 = Release|Any CPU {649FA588-F02E-457C-9FCF-87E46407481E}.Release|x86.ActiveCfg = Release|Any CPU {649FA588-F02E-457C-9FCF-87E46407481E}.Release|x86.Build.0 = Release|Any CPU - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|Any CPU.ActiveCfg = Debug|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|Any CPU.Build.0 = Debug|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|x86.ActiveCfg = Debug|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|x86.Build.0 = Debug|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|Any CPU.ActiveCfg = Proto|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|x86.ActiveCfg = Proto|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|x86.Build.0 = Proto|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|Any CPU.ActiveCfg = Release|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|Any CPU.Build.0 = Release|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|x86.ActiveCfg = Release|x86 - {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|x86.Build.0 = Release|x86 + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|Any CPU.Build.0 = Debug|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|x86.ActiveCfg = Debug|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Debug|x86.Build.0 = Debug|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|Any CPU.ActiveCfg = Proto|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|Any CPU.Build.0 = Proto|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|x86.ActiveCfg = Proto|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Proto|x86.Build.0 = Proto|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|Any CPU.ActiveCfg = Release|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|Any CPU.Build.0 = Release|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|x86.ActiveCfg = Release|Any CPU + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B}.Release|x86.Build.0 = Release|Any CPU {D0E98C0D-490B-4C61-9329-0862F6E87645}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {D0E98C0D-490B-4C61-9329-0862F6E87645}.Debug|Any CPU.Build.0 = Debug|Any CPU {D0E98C0D-490B-4C61-9329-0862F6E87645}.Debug|x86.ActiveCfg = Debug|Any CPU @@ -763,6 +770,30 @@ Global {C4586A06-1402-48BC-8E35-A1B8642F895B}.Release|Any CPU.Build.0 = Release|Any CPU {C4586A06-1402-48BC-8E35-A1B8642F895B}.Release|x86.ActiveCfg = Release|Any CPU {C4586A06-1402-48BC-8E35-A1B8642F895B}.Release|x86.Build.0 = Release|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Debug|Any CPU.Build.0 = Debug|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Debug|x86.ActiveCfg = Debug|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Debug|x86.Build.0 = Debug|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Proto|Any CPU.ActiveCfg = Release|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Proto|Any CPU.Build.0 = Release|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Proto|x86.ActiveCfg = Release|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Proto|x86.Build.0 = Release|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Release|Any CPU.ActiveCfg = Release|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Release|Any CPU.Build.0 = Release|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Release|x86.ActiveCfg = Release|Any CPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}.Release|x86.Build.0 = Release|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Debug|Any CPU.Build.0 = Debug|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Debug|x86.ActiveCfg = Debug|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Debug|x86.Build.0 = Debug|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Proto|Any CPU.ActiveCfg = Release|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Proto|Any CPU.Build.0 = Release|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Proto|x86.ActiveCfg = Release|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Proto|x86.Build.0 = Release|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Release|Any CPU.ActiveCfg = Release|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Release|Any CPU.Build.0 = Release|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Release|x86.ActiveCfg = Release|Any CPU + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}.Release|x86.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE @@ -826,5 +857,8 @@ Global {D086C8C6-D00D-4C3B-9AB2-A4286C9F5922} = {4C7B48D7-19AF-4AE7-9D1D-3BB289D5480D} {E7FA3A71-51AF-4FCA-9C2F-7C853E515903} = {D086C8C6-D00D-4C3B-9AB2-A4286C9F5922} {C4586A06-1402-48BC-8E35-A1B8642F895B} = {4C7B48D7-19AF-4AE7-9D1D-3BB289D5480D} + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB} = {35636A82-401A-4C3A-B2AB-EB7DC5E9C268} + {35636A82-401A-4C3A-B2AB-EB7DC5E9C268} = {F7876C9B-FB6A-4EFB-B058-D6967DB75FB2} + {FF76BD3C-5E0A-4752-B6C3-044F6E15719B} = {35636A82-401A-4C3A-B2AB-EB7DC5E9C268} EndGlobalSection EndGlobal diff --git a/build.cmd b/build.cmd index 8a772a1ade8..761d153a7af 100644 --- a/build.cmd +++ b/build.cmd @@ -22,7 +22,7 @@ echo ^ echo ^ echo ^ echo ^ -echo ^ +echo ^ echo ^ echo ^ echo. @@ -307,6 +307,13 @@ if /i "%ARG%" == "test-compiler-unit" ( set TEST_NET40_COMPILERUNIT_SUITE=1 ) +if /i "%ARG%" == "test-net40-ideunit" ( + set BUILD_NET40=1 + set BUILD_VS=1 + set BUILD_PORTABLE=1 + set TEST_VS_IDEUNIT_SUITE=1 +) + if /i "%ARG%" == "test-net40-coreunit" ( set BUILD_NET40=1 set TEST_NET40_COREUNIT_SUITE=1 diff --git a/fcs/FSharp.Compiler.Service.MSBuild.v12/FSharp.Compiler.Service.MSBuild.v12.fsproj b/fcs/FSharp.Compiler.Service.MSBuild.v12/FSharp.Compiler.Service.MSBuild.v12.fsproj new file mode 100644 index 00000000000..7aaaf51efc5 --- /dev/null +++ b/fcs/FSharp.Compiler.Service.MSBuild.v12/FSharp.Compiler.Service.MSBuild.v12.fsproj @@ -0,0 +1,102 @@ + + + + + Debug + AnyCPU + $(MSBuildProjectDirectory)\..\..\..\ + Library + FSharp.Compiler.Service.MSBuild.v12 + $(NoWarn);44;62;9 + {8157b50e-397d-4232-a4e0-1977afc7076d} + true + v4.5 + 0x06800000 + $(OtherFlags) /warnon:1182 + true + true + $(OtherFlags) --times + $(NoWarn);69;65;54;61;75 + true + ..\..\..\bin\$(TargetFrameworkVersion) + $(OutputPath)\$(AssemblyName).xml + $(DefineConstants);CROSS_PLATFORM_COMPILER + $(DefineConstants);ENABLE_MONO_SUPPORT + $(DefineConstants);FX_ATLEAST_45 + $(DefineConstants);FX_ATLEAST_40 + $(DefineConstants);FX_MSBUILDRESOLVER_RUNTIMELIKE + 4.4.0.0 + + false + true + AnyCPU + + + + DEBUG; $(DefineConstants) + false + $(OtherFlags) --no-jit-optimize --jit-tracking + + + true + + + + AssemblyInfo/assemblyinfo.FSharp.Compiler.Service.MSBuild.v12.dll.fs + + + AssemblyInfo/assemblyinfo.shared.fs + + + Service/MSBuildReferenceResolver.fs + + + + + + + + + + + True + + + True + + + True + + + True + + + True + + + False + + + FSharp.Compiler.Service + {2e4d67b4-522d-4cf7-97e4-ba940f0b18f3} + True + + + + $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets + + + $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets + + + + \ No newline at end of file diff --git a/fcs/FSharp.Compiler.Service.ProjectCracker/FSharp.Compiler.Service.ProjectCracker.fsproj b/fcs/FSharp.Compiler.Service.ProjectCracker/FSharp.Compiler.Service.ProjectCracker.fsproj new file mode 100644 index 00000000000..82d7749b275 --- /dev/null +++ b/fcs/FSharp.Compiler.Service.ProjectCracker/FSharp.Compiler.Service.ProjectCracker.fsproj @@ -0,0 +1,64 @@ + + + + + Debug + AnyCPU + $(MSBuildProjectDirectory)\..\..\..\ + 2.0 + 893c3cd9-5af8-4027-a667-21e62fc2c703 + Library + FSharp.Compiler.Service.ProjectCracker + FSharp.Compiler.Service.ProjectCracker + v4.5 + 4.4.0.0 + FSharp.Compiler.Service.ProjectCracker + ..\..\..\bin\$(TargetFrameworkVersion) + ..\..\..\bin\$(TargetFrameworkVersion)\FSharp.Compiler.Service.ProjectCracker.xml + false + + + true + full + false + false + DEBUG;TRACE + 3 + AnyCPU + true + + + pdbonly + true + true + TRACE + 3 + AnyCPU + true + + + + + False + + + + + + + + + + ProjectCrackerOptions.fs + + + + + + FSharp.Compiler.Service + {2e4d67b4-522d-4cf7-97e4-ba940f0b18f3} + True + + + + \ No newline at end of file diff --git a/fcs/FSharp.Compiler.Service.ProjectCracker/FSharp.Compiler.Service.ProjectCracker.netcore.fsproj b/fcs/FSharp.Compiler.Service.ProjectCracker/FSharp.Compiler.Service.ProjectCracker.netcore.fsproj new file mode 100644 index 00000000000..abbfd952b68 --- /dev/null +++ b/fcs/FSharp.Compiler.Service.ProjectCracker/FSharp.Compiler.Service.ProjectCracker.netcore.fsproj @@ -0,0 +1,36 @@ + + + 12.0.8 + netstandard1.6 + Library + $(DefineConstants);DOTNETCORE; + $(NoWarn);44;2003; + true + true + true + FSharp.Compiler.Service.ProjectCracker + FSharp.Compiler.Service.ProjectCracker + + + + ProjectCrackerOptions.fs + + + ProjectCrackerTool.fs + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/fcs/FSharp.Compiler.Service.ProjectCracker/ProjectCracker.fs b/fcs/FSharp.Compiler.Service.ProjectCracker/ProjectCracker.fs new file mode 100644 index 00000000000..baf81022799 --- /dev/null +++ b/fcs/FSharp.Compiler.Service.ProjectCracker/ProjectCracker.fs @@ -0,0 +1,86 @@ +namespace Microsoft.FSharp.Compiler.SourceCodeServices + +#if !NETSTANDARD1_6 +open System.Runtime.Serialization.Json +open System.Runtime +open System.Diagnostics +#endif +open System.Text +open System.IO +open System + +type ProjectCracker = + static member GetProjectOptionsFromProjectFileLogged(projectFileName : string, ?properties : (string * string) list, ?loadedTimeStamp, ?enableLogging) = + let loadedTimeStamp = defaultArg loadedTimeStamp DateTime.MaxValue // Not 'now', we don't want to force reloading + let properties = defaultArg properties [] + let enableLogging = defaultArg enableLogging true + let logMap = ref Map.empty + + let rec convert (opts: Microsoft.FSharp.Compiler.SourceCodeServices.ProjectCrackerTool.ProjectOptions) : FSharpProjectOptions = + let referencedProjects = Array.map (fun (a, b) -> a, convert b) opts.ReferencedProjectOptions + + let sourceFiles, otherOptions = + opts.Options |> Array.partition (fun x -> x.IndexOfAny(Path.GetInvalidPathChars()) = -1 && Path.GetExtension(x).ToLower() = ".fs") + + let sepChar = Path.DirectorySeparatorChar + + let sourceFiles = sourceFiles |> Array.map (fun x -> + match sepChar with + | '\\' -> x.Replace('/', '\\') + | '/' -> x.Replace('\\', '/') + | _ -> x + ) + + logMap := Map.add opts.ProjectFile opts.LogOutput !logMap + { ProjectFileName = opts.ProjectFile + ProjectFileNames = sourceFiles + OtherOptions = otherOptions + ReferencedProjects = referencedProjects + IsIncompleteTypeCheckEnvironment = false + UseScriptResolutionRules = false + LoadTime = loadedTimeStamp + UnresolvedReferences = None + OriginalLoadReferences = [] + ExtraProjectInfo = None } + +#if NETSTANDARD1_6 + let arguments = [| + yield projectFileName + yield enableLogging.ToString() + for k, v in properties do + yield k + yield v + |] + + let ret, opts = Microsoft.FSharp.Compiler.SourceCodeServices.ProjectCrackerTool.ProjectCrackerTool.crackOpen arguments + ignore ret +#else + let arguments = new StringBuilder() + arguments.Append('"').Append(projectFileName).Append('"') |> ignore + arguments.Append(' ').Append(enableLogging.ToString()) |> ignore + for k, v in properties do + arguments.Append(' ').Append(k).Append(' ').Append(v) |> ignore + let codebase = Path.GetDirectoryName(Uri(typeof.Assembly.CodeBase).LocalPath) + + let crackerFilename = Path.Combine(codebase,"FSharp.Compiler.Service.ProjectCrackerTool.exe") + if not (File.Exists crackerFilename) then failwithf "ProjectCracker exe not found at: %s it must be next to the ProjectCracker dll." crackerFilename + let p = new System.Diagnostics.Process() + p.StartInfo.FileName <- crackerFilename + p.StartInfo.Arguments <- arguments.ToString() + p.StartInfo.UseShellExecute <- false + p.StartInfo.CreateNoWindow <- true + p.StartInfo.RedirectStandardOutput <- true + ignore <| p.Start() + + let ser = new System.Runtime.Serialization.Json.DataContractJsonSerializer(typeof) + let opts = ser.ReadObject(p.StandardOutput.BaseStream) :?> Microsoft.FSharp.Compiler.SourceCodeServices.ProjectCrackerTool.ProjectOptions +#endif + + convert opts, !logMap + + static member GetProjectOptionsFromProjectFile(projectFileName : string, ?properties : (string * string) list, ?loadedTimeStamp) = + fst (ProjectCracker.GetProjectOptionsFromProjectFileLogged( + projectFileName, + ?properties=properties, + ?loadedTimeStamp=loadedTimeStamp, + enableLogging=false)) diff --git a/fcs/FSharp.Compiler.Service.ProjectCracker/paket.references b/fcs/FSharp.Compiler.Service.ProjectCracker/paket.references new file mode 100644 index 00000000000..e69de29bb2d diff --git a/fcs/FSharp.Compiler.Service.ProjectCrackerTool/App.config b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/App.config new file mode 100644 index 00000000000..fdab151af22 --- /dev/null +++ b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/App.config @@ -0,0 +1,22 @@ + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/fcs/FSharp.Compiler.Service.ProjectCrackerTool/FSharp.Compiler.Service.ProjectCracker.targets b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/FSharp.Compiler.Service.ProjectCracker.targets new file mode 100644 index 00000000000..45e62e6f25a --- /dev/null +++ b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/FSharp.Compiler.Service.ProjectCracker.targets @@ -0,0 +1,7 @@ + + + + + + + diff --git a/fcs/FSharp.Compiler.Service.ProjectCrackerTool/FSharp.Compiler.Service.ProjectCrackerTool.fsproj b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/FSharp.Compiler.Service.ProjectCrackerTool.fsproj new file mode 100644 index 00000000000..69c44eb0098 --- /dev/null +++ b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/FSharp.Compiler.Service.ProjectCrackerTool.fsproj @@ -0,0 +1,89 @@ + + + + + Debug + AnyCPU + $(MSBuildProjectDirectory)\..\..\..\ + 2.0 + b1bdd96d-47e1-4e65-8107-fbae23a06db4 + Exe + FSharp.Compiler.Service.ProjectCrackerTool + FSharp.Compiler.Service.ProjectCrackerTool + v4.5 + 4.4.0.0 + FSharp.Compiler.Service.ProjectCrackerTool + $(OtherFlags) --staticlink:FSharp.Core + $(NoWarn);40 + true + FSharp.Compiler.Service.ProjectCrackerTool + $(SolutionDir)bin\$(TargetFrameworkVersion) + $(SolutionDir)bin\$(TargetFrameworkVersion)\FSharp.Compiler.Service.ProjectCrackerTool.xml + false + + + true + full + false + false + DEBUG;TRACE + 3 + AnyCPU + true + + + pdbonly + true + true + TRACE + 3 + AnyCPU + true + + + 11 + + + + + + + + + + + + True + True + + + True + True + + + True + True + + + True + + + + False + + + + + + + + + + + \ No newline at end of file diff --git a/fcs/FSharp.Compiler.Service.ProjectCrackerTool/FSharp.Compiler.Service.ProjectCrackerTool.netcore.fsproj b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/FSharp.Compiler.Service.ProjectCrackerTool.netcore.fsproj new file mode 100644 index 00000000000..9523b6ce12a --- /dev/null +++ b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/FSharp.Compiler.Service.ProjectCrackerTool.netcore.fsproj @@ -0,0 +1,23 @@ + + + netcoreapp1.0 + FSharp.Compiler.Service.ProjectCrackerTool + Exe + $(DefineConstants);DOTNETCORE; + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/fcs/FSharp.Compiler.Service.ProjectCrackerTool/Program.fs b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/Program.fs new file mode 100644 index 00000000000..ed8a8b15992 --- /dev/null +++ b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/Program.fs @@ -0,0 +1,21 @@ +namespace Microsoft.FSharp.Compiler.SourceCodeServices.ProjectCrackerTool + +open System +open System.IO +open System.Runtime.Serialization.Json + +module Program = + + [] + let main argv = + let text = Array.exists (fun (s: string) -> s = "--text") argv + let argv = Array.filter (fun (s: string) -> s <> "--text") argv + + let ret, opts = ProjectCrackerTool.crackOpen argv + + if text then + printfn "%A" opts + else + let ser = new DataContractJsonSerializer(typeof) + ser.WriteObject(Console.OpenStandardOutput(), opts) + ret diff --git a/fcs/FSharp.Compiler.Service.ProjectCrackerTool/ProjectCrackerOptions.fs b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/ProjectCrackerOptions.fs new file mode 100644 index 00000000000..34f3aa16e7a --- /dev/null +++ b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/ProjectCrackerOptions.fs @@ -0,0 +1,10 @@ +namespace Microsoft.FSharp.Compiler.SourceCodeServices.ProjectCrackerTool + +[] +type ProjectOptions = + { + ProjectFile: string + Options: string[] + ReferencedProjectOptions: (string * ProjectOptions)[] + LogOutput: string + } diff --git a/fcs/FSharp.Compiler.Service.ProjectCrackerTool/ProjectCrackerTool.fs b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/ProjectCrackerTool.fs new file mode 100644 index 00000000000..639d4d0c2b7 --- /dev/null +++ b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/ProjectCrackerTool.fs @@ -0,0 +1,473 @@ +namespace Microsoft.FSharp.Compiler.SourceCodeServices.ProjectCrackerTool + +open System +open System.IO +open System.Reflection +open System.Text +open Microsoft.Build.Framework +open Microsoft.Build.Utilities + +module internal ProjectCrackerTool = + + let runningOnMono = +#if DOTNETCORE + false +#else + try match System.Type.GetType("Mono.Runtime") with null -> false | _ -> true + with e -> false +#endif + + type internal BasicStringLogger() = + inherit Logger() + + let sb = new StringBuilder() + + let log (e: BuildEventArgs) = + sb.Append(e.Message) |> ignore + sb.AppendLine() |> ignore + + override x.Initialize(eventSource:IEventSource) = + sb.Clear() |> ignore + eventSource.AnyEventRaised.Add(log) + + member x.Log = sb.ToString() + + type internal HostCompile() = + member th.Compile(_:obj, _:obj, _:obj) = 0 + interface ITaskHost + + //---------------------------------------------------------------------------- + // FSharpProjectFileInfo + // + [] + type FSharpProjectFileInfo (fsprojFileName:string, ?properties, ?enableLogging) = + + let properties = defaultArg properties [] + let enableLogging = defaultArg enableLogging false + let mkAbsolute dir v = + if Path.IsPathRooted v then v + else Path.Combine(dir, v) + + let logOpt = + if enableLogging then + let log = new BasicStringLogger() + do log.Verbosity <- Microsoft.Build.Framework.LoggerVerbosity.Diagnostic + Some log + else + None + +#if !DOTNETCORE + let mkAbsoluteOpt dir v = Option.map (mkAbsolute dir) v + + let CrackProjectUsingOldBuildAPI(fsprojFile:string) = + let engine = new Microsoft.Build.BuildEngine.Engine() + Option.iter (fun l -> engine.RegisterLogger(l)) logOpt + + let bpg = Microsoft.Build.BuildEngine.BuildPropertyGroup() + + bpg.SetProperty("BuildingInsideVisualStudio", "true") + for (prop, value) in properties do + bpg.SetProperty(prop, value) + + engine.GlobalProperties <- bpg + + let projectFromFile (fsprojFile:string) = + // We seem to need to pass 12.0/4.0 in here for some unknown reason + let project = new Microsoft.Build.BuildEngine.Project(engine, engine.DefaultToolsVersion) + do project.Load(fsprojFile) + project + + let project = projectFromFile fsprojFile + project.Build([| "ResolveReferences" |]) |> ignore + let directory = Path.GetDirectoryName project.FullFileName + + let getProp (p: Microsoft.Build.BuildEngine.Project) s = + let v = p.GetEvaluatedProperty s + if String.IsNullOrWhiteSpace v then None + else Some v + + let outFileOpt = + match mkAbsoluteOpt directory (getProp project "OutDir") with + | None -> None + | Some d -> mkAbsoluteOpt d (getProp project "TargetFileName") + + let getItems s = + let fs = project.GetEvaluatedItemsByName(s) + [ for f in fs -> mkAbsolute directory f.FinalItemSpec ] + + let projectReferences = + [ for i in project.GetEvaluatedItemsByName("ProjectReference") do + yield mkAbsolute directory i.FinalItemSpec + ] + + let references = + [ for i in project.GetEvaluatedItemsByName("ReferencePath") do + yield i.FinalItemSpec + for i in project.GetEvaluatedItemsByName("ChildProjectReferences") do + yield i.FinalItemSpec ] + // Duplicate slashes sometimes appear in the output here, which prevents + // them from matching keys used in FSharpProjectOptions.ReferencedProjects + |> List.map (fun (s: string) -> s.Replace("//","/")) + + outFileOpt, directory, getItems, references, projectReferences, getProp project, project.FullFileName +#endif + + let vs = + let programFiles = + let getEnv v = + let result = System.Environment.GetEnvironmentVariable(v) + match result with + | null -> None + | _ -> Some result + + match List.tryPick getEnv [ "ProgramFiles(x86)"; "ProgramFiles" ] with + | Some r -> r + | None -> "C:\\Program Files (x86)" + + let vsVersions = ["14.0"; "12.0"] + let msbuildBin v = IO.Path.Combine(programFiles, "MSBuild", v, "Bin", "MSBuild.exe") + List.tryFind (fun v -> IO.File.Exists(msbuildBin v)) vsVersions + + let CrackProjectUsingNewBuildAPI(fsprojFile) = + let fsprojFullPath = try Path.GetFullPath(fsprojFile) with _ -> fsprojFile + let fsprojAbsDirectory = Path.GetDirectoryName fsprojFullPath + + use _pwd = + let dir = Directory.GetCurrentDirectory() + Directory.SetCurrentDirectory(fsprojAbsDirectory) + { new System.IDisposable with + member x.Dispose() = Directory.SetCurrentDirectory(dir) } + use engine = new Microsoft.Build.Evaluation.ProjectCollection() + let host = new HostCompile() + engine.HostServices.RegisterHostObject(fsprojFullPath, "CoreCompile", "Fsc", host) + + + let projectInstanceFromFullPath (fsprojFullPath: string) = + use file = new FileStream(fsprojFullPath, FileMode.Open, FileAccess.Read, FileShare.Read) + use stream = new StreamReader(file) + use xmlReader = System.Xml.XmlReader.Create(stream) + + let project = engine.LoadProject(xmlReader, FullPath=fsprojFullPath) + + project.SetGlobalProperty("BuildingInsideVisualStudio", "true") |> ignore + if not (List.exists (fun (p,_) -> p = "VisualStudioVersion") properties) then + match vs with + | Some version -> project.SetGlobalProperty("VisualStudioVersion", version) |> ignore + | None -> () + project.SetGlobalProperty("ShouldUnsetParentConfigurationAndPlatform", "false") |> ignore + for (prop, value) in properties do + project.SetGlobalProperty(prop, value) |> ignore + + project.CreateProjectInstance() + + let project = projectInstanceFromFullPath fsprojFullPath + let directory = project.Directory + + let getprop (p: Microsoft.Build.Execution.ProjectInstance) s = + let v = p.GetPropertyValue s + if String.IsNullOrWhiteSpace v then None + else Some v + + let outFileOpt = getprop project "TargetPath" + + let log = match logOpt with + | None -> [] + | Some l -> [l :> ILogger] + + project.Build([| "Build" |], log) |> ignore + + let getItems s = [ for f in project.GetItems(s) -> mkAbsolute directory f.EvaluatedInclude ] + + let projectReferences = + [ for cp in project.GetItems("ProjectReference") do + yield cp.GetMetadataValue("FullPath") + ] + + let references = + [ for i in project.GetItems("ReferencePath") do + yield i.EvaluatedInclude + for i in project.GetItems("ChildProjectReferences") do + yield i.EvaluatedInclude ] + + outFileOpt, directory, getItems, references, projectReferences, getprop project, project.FullPath + + let outFileOpt, directory, getItems, references, projectReferences, getProp, fsprojFullPath = + try +#if DOTNETCORE + CrackProjectUsingNewBuildAPI(fsprojFileName) + with +#else + if runningOnMono then + CrackProjectUsingOldBuildAPI(fsprojFileName) + else + CrackProjectUsingNewBuildAPI(fsprojFileName) + with + | :? Microsoft.Build.BuildEngine.InvalidProjectFileException as e -> + raise (Microsoft.Build.Exceptions.InvalidProjectFileException( + e.ProjectFile, + e.LineNumber, + e.ColumnNumber, + e.EndLineNumber, + e.EndColumnNumber, + e.Message, + e.ErrorSubcategory, + e.ErrorCode, + e.HelpKeyword)) +#endif + | :? ArgumentException as e -> raise (IO.FileNotFoundException(e.Message)) + + let logOutput = match logOpt with None -> "" | Some l -> l.Log + let pages = getItems "Page" + let embeddedResources = getItems "EmbeddedResource" + let files = getItems "Compile" + let resources = getItems "Resource" + let noaction = getItems "None" + let content = getItems "Content" + + let split (s : string option) (cs : char []) = + match s with + | None -> [||] + | Some s -> + if String.IsNullOrWhiteSpace s then [||] + else s.Split(cs, StringSplitOptions.RemoveEmptyEntries) + + let getbool (s : string option) = + match s with + | None -> false + | Some s -> + match (Boolean.TryParse s) with + | (true, result) -> result + | (false, _) -> false + + let fxVer = getProp "TargetFrameworkVersion" + let optimize = getProp "Optimize" |> getbool + let assemblyNameOpt = getProp "AssemblyName" + let tailcalls = getProp "Tailcalls" |> getbool + let outputPathOpt = getProp "OutputPath" + let docFileOpt = getProp "DocumentationFile" + let outputTypeOpt = getProp "OutputType" + let debugTypeOpt = getProp "DebugType" + let baseAddressOpt = getProp "BaseAddress" + let sigFileOpt = getProp "GenerateSignatureFile" + let keyFileOpt = getProp "KeyFile" + let pdbFileOpt = getProp "PdbFile" + let platformOpt = getProp "Platform" + let targetTypeOpt = getProp "TargetType" + let versionFileOpt = getProp "VersionFile" + let targetProfileOpt = getProp "TargetProfile" + let warnLevelOpt = getProp "Warn" + let subsystemVersionOpt = getProp "SubsystemVersion" + let win32ResOpt = getProp "Win32ResourceFile" + let heOpt = getProp "HighEntropyVA" |> getbool + let win32ManifestOpt = getProp "Win32ManifestFile" + let debugSymbols = getProp "DebugSymbols" |> getbool + let prefer32bit = getProp "Prefer32Bit" |> getbool + let warnAsError = getProp "TreatWarningsAsErrors" |> getbool + let defines = split (getProp "DefineConstants") [| ';'; ','; ' ' |] + let nowarn = split (getProp "NoWarn") [| ';'; ','; ' ' |] + let warningsAsError = split (getProp "WarningsAsErrors") [| ';'; ','; ' ' |] + let libPaths = split (getProp "ReferencePath") [| ';'; ',' |] + let otherFlags = split (getProp "OtherFlags") [| ' ' |] + let isLib = (outputTypeOpt = Some "Library") + + let docFileOpt = + match docFileOpt with + | None -> None + | Some docFile -> Some(mkAbsolute directory docFile) + + + let options = + [ yield "--simpleresolution" + yield "--noframework" + match outFileOpt with + | None -> () + | Some outFile -> yield "--out:" + outFile + match docFileOpt with + | None -> () + | Some docFile -> yield "--doc:" + docFile + match baseAddressOpt with + | None -> () + | Some baseAddress -> yield "--baseaddress:" + baseAddress + match keyFileOpt with + | None -> () + | Some keyFile -> yield "--keyfile:" + keyFile + match sigFileOpt with + | None -> () + | Some sigFile -> yield "--sig:" + sigFile + match pdbFileOpt with + | None -> () + | Some pdbFile -> yield "--pdb:" + pdbFile + match versionFileOpt with + | None -> () + | Some versionFile -> yield "--versionfile:" + versionFile + match warnLevelOpt with + | None -> () + | Some warnLevel -> yield "--warn:" + warnLevel + match subsystemVersionOpt with + | None -> () + | Some s -> yield "--subsystemversion:" + s + if heOpt then yield "--highentropyva+" + match win32ResOpt with + | None -> () + | Some win32Res -> yield "--win32res:" + win32Res + match win32ManifestOpt with + | None -> () + | Some win32Manifest -> yield "--win32manifest:" + win32Manifest + match targetProfileOpt with + | None -> () + | Some targetProfile -> yield "--targetprofile:" + targetProfile + yield "--fullpaths" + yield "--flaterrors" + if warnAsError then yield "--warnaserror" + yield + if isLib then "--target:library" + else "--target:exe" + for symbol in defines do + if not (String.IsNullOrWhiteSpace symbol) then yield "--define:" + symbol + for nw in nowarn do + if not (String.IsNullOrWhiteSpace nw) then yield "--nowarn:" + nw + for nw in warningsAsError do + if not (String.IsNullOrWhiteSpace nw) then yield "--warnaserror:" + nw + yield if debugSymbols then "--debug+" + else "--debug-" + yield if optimize then "--optimize+" + else "--optimize-" + yield if tailcalls then "--tailcalls+" + else "--tailcalls-" + match debugTypeOpt with + | None -> () + | Some debugType -> + match debugType.ToUpperInvariant() with + | "NONE" -> () + | "PDBONLY" -> yield "--debug:pdbonly" + | "FULL" -> yield "--debug:full" + | _ -> () + match platformOpt |> Option.map (fun o -> o.ToUpperInvariant()), prefer32bit, + targetTypeOpt |> Option.map (fun o -> o.ToUpperInvariant()) with + | Some "ANYCPU", true, Some "EXE" | Some "ANYCPU", true, Some "WINEXE" -> yield "--platform:anycpu32bitpreferred" + | Some "ANYCPU", _, _ -> yield "--platform:anycpu" + | Some "X86", _, _ -> yield "--platform:x86" + | Some "X64", _, _ -> yield "--platform:x64" + | Some "ITANIUM", _, _ -> yield "--platform:Itanium" + | _ -> () + match targetTypeOpt |> Option.map (fun o -> o.ToUpperInvariant()) with + | Some "LIBRARY" -> yield "--target:library" + | Some "EXE" -> yield "--target:exe" + | Some "WINEXE" -> yield "--target:winexe" + | Some "MODULE" -> yield "--target:module" + | _ -> () + yield! otherFlags + for f in resources do + yield "--resource:" + f + for i in libPaths do + yield "--lib:" + mkAbsolute directory i + for r in references do + yield "-r:" + r + yield! files ] + + member x.Options = options + member x.FrameworkVersion = fxVer + member x.ProjectReferences = projectReferences + member x.References = references + member x.CompileFiles = files + member x.ResourceFiles = resources + member x.EmbeddedResourceFiles = embeddedResources + member x.ContentFiles = content + member x.OtherFiles = noaction + member x.PageFiles = pages + member x.OutputFile = outFileOpt + member x.Directory = directory + member x.AssemblyName = assemblyNameOpt + member x.OutputPath = outputPathOpt + member x.FullPath = fsprojFullPath + member x.LogOutput = logOutput + static member Parse(fsprojFileName:string, ?properties, ?enableLogging) = new FSharpProjectFileInfo(fsprojFileName, ?properties=properties, ?enableLogging=enableLogging) + + let getOptions file enableLogging properties = + let rec getOptions file : Option * ProjectOptions = + let parsedProject = FSharpProjectFileInfo.Parse(file, properties=properties, enableLogging=enableLogging) + let referencedProjectOptions = + [| for file in parsedProject.ProjectReferences do + if Path.GetExtension(file) = ".fsproj" then + match getOptions file with + | Some outFile, opts -> yield outFile, opts + | None, _ -> () |] + + // Workaround for Mono 4.2, which doesn't populate the subproject + // details anymore outside of a solution context. See https://github.com/mono/mono/commit/76c6a08e730393927b6851709cdae1d397cbcc3a#diff-59afd196a55d61d5d1eaaef7bd49d1e5 + // and some explanation from the author at https://github.com/fsharp/FSharp.Compiler.Service/pull/455#issuecomment-154103963 + // + // In particular we want the output path, which we can get from + // fully parsing that project itself. We also have to specially parse + // C# referenced projects, as we don't look at them otherwise. + let referencedProjectOutputs = + if runningOnMono then + [ yield! Array.map (fun (s,_) -> "-r:" + s) referencedProjectOptions + for file in parsedProject.ProjectReferences do + let ext = Path.GetExtension(file) + if ext = ".csproj" || ext = ".vbproj" then + let parsedProject = FSharpProjectFileInfo.Parse(file, properties=properties, enableLogging=false) + match parsedProject.OutputFile with + | None -> () + | Some f -> yield "-r:" + f ] + else + [] + + // On some versions of Mono the referenced projects are already + // correctly included, so we make sure not to introduce duplicates + |> List.filter (fun r -> not (Set.contains r (set parsedProject.Options))) + + let options = { ProjectFile = file + Options = Array.ofSeq (parsedProject.Options @ referencedProjectOutputs) + ReferencedProjectOptions = referencedProjectOptions + LogOutput = parsedProject.LogOutput } + + parsedProject.OutputFile, options + + snd (getOptions file) + +#if !DOTNETCORE + let addMSBuildv14BackupResolution () = + let onResolveEvent = new ResolveEventHandler(fun sender evArgs -> + let requestedAssembly = AssemblyName(evArgs.Name) + if requestedAssembly.Name.StartsWith("Microsoft.Build") && + not (requestedAssembly.Name.EndsWith(".resources")) && + not (requestedAssembly.Version.ToString().Contains("12.0.0.0")) then + // If the version of MSBuild that we're using wasn't present on the machine, then + // just revert back to 12.0.0.0 since that's normally installed as part of the .NET + // Framework. + requestedAssembly.Version <- Version("12.0.0.0") + Assembly.Load (requestedAssembly) + else + null) + AppDomain.CurrentDomain.add_AssemblyResolve(onResolveEvent) +#endif + + let rec pairs l = + match l with + | [] | [_] -> [] + | x::y::rest -> (x,y) :: pairs rest + + let crackOpen (argv: string[])= + if argv.Length >= 2 then + let projectFile = argv.[0] + let enableLogging = match Boolean.TryParse(argv.[1]) with + | true, true -> true + | _ -> false + try +#if !DOTNETCORE + addMSBuildv14BackupResolution () +#endif + let props = pairs (List.ofArray argv.[2..]) + let opts = getOptions argv.[0] enableLogging props + 0, opts + with e -> + 2, { ProjectFile = projectFile; + Options = [||]; + ReferencedProjectOptions = [||]; + LogOutput = e.ToString() } + else + 1, { ProjectFile = ""; + Options = [||]; + ReferencedProjectOptions = [||]; + LogOutput = "At least two arguments required." } diff --git a/fcs/FSharp.Compiler.Service.ProjectCrackerTool/paket.references b/fcs/FSharp.Compiler.Service.ProjectCrackerTool/paket.references new file mode 100644 index 00000000000..e69de29bb2d diff --git a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj new file mode 100644 index 00000000000..1181332aa09 --- /dev/null +++ b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -0,0 +1,617 @@ + + + + + $(MSBuildProjectDirectory)\..\..\src + + + + Debug + AnyCPU + $(MSBuildProjectDirectory)\..\..\ + Library + FSharp.Compiler.Service + $(NoWarn);44;62;9 + {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3} + true + v4.5 + 0x06800000 + true + $(NoWarn);69;65;54;61;75 + true + $(OutputPath)$(AssemblyName).xml + $(DefineConstants);EXTENSIONTYPING + $(DefineConstants);CROSS_PLATFORM_COMPILER + $(DefineConstants);COMPILER + $(DefineConstants);COMPILER_PUBLIC_API + $(DefineConstants);COMPILER_SERVICE + $(DefineConstants);COMPILER_SERVICE_DLL + $(DefineConstants);NO_STRONG_NAMES + 4.4.0.0 + + $(OtherFlags) /warnon:1182 + $(OtherFlags) --times + + + + AssemblyInfo/assemblyinfo.FSharp.Compiler.Service.dll.fs + + + FSComp.txt + + + FSIstrings.txt + + + FSStrings.resx + + + --module Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiParser --open Microsoft.FSharp.Compiler.AbstractIL --internal --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing + ilpars.fsy + + + --module Microsoft.FSharp.Compiler.Parser --open Microsoft.FSharp.Compiler --internal --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing + pars.fsy + + + Reshaped/reshapedreflection.fs + + + ErrorText/sformat.fsi + + + ErrorText/sformat.fs + + + ErrorText/sr.fsi + + + ErrorText/sr.fs + + + LexYaccRuntime/prim-lexing.fsi + + + LexYaccRuntime/prim-lexing.fs + + + LexYaccRuntime/prim-parsing.fsi + + + LexYaccRuntime/prim-parsing.fs + + + Utilities\ResizeArray.fsi + + + Utilities\ResizeArray.fs + + + Utilities/HashMultiMap.fsi + + + Utilities/HashMultiMap.fs + + + Utilities\EditDistance.fs + + + Utilities/TaggedCollections.fsi + + + Utilities/TaggedCollections.fs + + + Utilities/QueueList.fs + + + Utilities/ildiag.fsi + + + Utilities/ildiag.fs + + + Utilities/illib.fs + + + Utilities/filename.fsi + + + Utilities/filename.fs + + + Utilities/zmap.fsi + + + Utilities/zmap.fs + + + Utilities/zset.fsi + + + Utilities/zset.fs + + + Utilities/bytes.fsi + + + Utilities/bytes.fs + + + Utilities/lib.fs + + + Utilities/InternalCollections.fsi + + + Utilities/InternalCollections.fs + + + Utilities/rational.fsi + + + Utilities/rational.fs + + + ErrorLogging/range.fsi + + + ErrorLogging/range.fs + + + ErrorLogging/ErrorLogger.fs + + + ErrorLogging/ErrorResolutionHints.fs + + + ReferenceResolution/ReferenceResolver.fs + + + --unicode --lexlib Internal.Utilities.Text.Lexing + AbsIL/illex.fsl + + + AbsIL/il.fsi + + + AbsIL/il.fs + + + AbsIL/ilx.fsi + + + AbsIL/ilx.fs + + + AbsIL/ilascii.fsi + + + AbsIL/ilascii.fs + + + AbsIL/ilprint.fsi + + + AbsIL/ilprint.fs + + + AbsIL/ilmorph.fsi + + + AbsIL/ilmorph.fs + + + AbsIL/ilsupp.fsi + + + AbsIL/ilsupp.fs + + + AbsIL/ilpars.fs + + + AbsIL/illex.fs + + + AbsIL/ilbinary.fsi + + + AbsIL/ilbinary.fs + + + AbsIL/ilread.fsi + + + AbsIL/ilread.fs + + + AbsIL/ilwritepdb.fsi + + + AbsIL/ilwritepdb.fs + + + AbsIL/ilwrite.fsi + + + AbsIL/ilwrite.fs + + + AbsIL/ilreflect.fs + + + CompilerLocation/CompilerLocationUtils.fs + + + PrettyNaming/PrettyNaming.fs + + + ILXErase/ilxsettings.fs + + + ILXErase/EraseClosures.fsi + + + ILXErase/EraseClosures.fs + + + ILXErase/EraseUnions.fsi + + + ILXErase/EraseUnions.fs + + + --unicode --lexlib Internal.Utilities.Text.Lexing + ParserAndUntypedAST/lex.fsl + + + --unicode --lexlib Internal.Utilities.Text.Lexing + ParserAndUntypedAST/pplex.fsl + + + --module Microsoft.FSharp.Compiler.PPParser --open Microsoft.FSharp.Compiler --internal --lexlib Internal.Utilities.Text.Lexing --parslib Internal.Utilities.Text.Parsing + ParserAndUntypedAST/pppars.fsy + + + ParserAndUntypedAST/UnicodeLexing.fsi + + + ParserAndUntypedAST/UnicodeLexing.fs + + + ParserAndUntypedAST/layout.fsi + + + ParserAndUntypedAST/layout.fs + + + ParserAndUntypedAST/ast.fs + + + ParserAndUntypedAST/pppars.fs + + + ParserAndUntypedAST/pars.fs + + + ParserAndUntypedAST/lexhelp.fsi + + + ParserAndUntypedAST/lexhelp.fs + + + ParserAndUntypedAST/pplex.fs + + + ParserAndUntypedAST/lex.fs + + + ParserAndUntypedAST/LexFilter.fs + + + TypedAST/tainted.fsi + + + TypedAST/tainted.fs + + + TypedAST/ExtensionTyping.fsi + + + TypedAST/ExtensionTyping.fs + + + TypedAST/QuotationPickler.fsi + + + TypedAST/QuotationPickler.fs + + + TypedAST/tast.fs + + + TypedAST/TcGlobals.fs + + + TypedAST/TastOps.fsi + + + TypedAST/TastOps.fs + + + TypedAST/TastPickle.fsi + + + TypedAST/TastPickle.fs + + + Logic/import.fsi + + + Logic/import.fs + + + Logic/infos.fs + + + Logic/AccessibilityLogic.fs + + + Logic/AttributeChecking.fs + + + Logic/InfoReader.fs + + + Logic/NicePrint.fs + + + Logic/AugmentWithHashCompare.fsi + + + Logic/AugmentWithHashCompare.fs + + + Logic/NameResolution.fsi + + + Logic/NameResolution.fs + + + Logic/TypeRelations.fs + + + Logic/SignatureConformance.fs + + + Logic/MethodOverrides.fs + + + Logic/MethodCalls.fs + + + Logic/PatternMatchCompilation.fsi + + + Logic/PatternMatchCompilation.fs + + + Logic/ConstraintSolver.fsi + + + Logic/ConstraintSolver.fs + + + Logic/CheckFormatStrings.fsi + + + Logic/CheckFormatStrings.fs + + + Logic/FindUnsolved.fs + + + Logic/QuotationTranslator.fsi + + + Logic/QuotationTranslator.fs + + + Logic/PostInferenceChecks.fsi + + + Logic/PostInferenceChecks.fs + + + Logic/TypeChecker.fsi + + + Logic/TypeChecker.fs + + + Optimize/Optimizer.fsi + + + Optimize/Optimizer.fs + + + Optimize/DetupleArgs.fsi + + + Optimize/DetupleArgs.fs + + + Optimize/InnerLambdasToTopLevelFuncs.fsi + + + Optimize/InnerLambdasToTopLevelFuncs.fs + + + Optimize/LowerCallsAndSeqs.fs + + + Optimize\autobox.fs + + + CodeGen/IlxGen.fsi + + + CodeGen/IlxGen.fs + + + Driver/CompileOps.fsi + + + Driver/CompileOps.fs + + + Driver/CompileOptions.fsi + + + Driver/CompileOptions.fs + + + Driver/fsc.fsi + + + Driver/fsc.fs + + + Symbols/SymbolHelpers.fsi + + + Symbols/SymbolHelpers.fs + + + Symbols/Symbols.fsi + + + Symbols/Symbols.fs + + + Symbols/Exprs.fsi + + + Symbols/Exprs.fs + + + Service/IncrementalBuild.fsi + + + Service/IncrementalBuild.fs + + + Service/Reactor.fsi + + + Service/Reactor.fs + + + Service/ServiceConstants.fs + + + Service/ServiceLexing.fsi + + + Service/ServiceLexing.fs + + + Service/ServiceParseTreeWalk.fs + + + Service/ServiceNavigation.fsi + + + Service/ServiceNavigation.fs + + + Service/ServiceParamInfoLocations.fsi + + + Service/ServiceParamInfoLocations.fs + + + Service/ServiceUntypedParse.fsi + + + Service/ServiceUntypedParse.fs + + + Service/reshapedmsbuild.fs + + + Service/SimulatedMSBuildReferenceResolver.fs + + + Service/ServiceDeclarationLists.fsi + + + Service/ServiceDeclarationLists.fs + + + Service/ServiceAssemblyContent.fsi + + + Service/ServiceAssemblyContent.fs + + + Service/ServiceXmlDocParser.fsi + + + Service/ServiceXmlDocParser.fs + + + Service/service.fsi + + + Service/service.fs + + + Service/ServiceInterfaceStubGenerator.fsi + + + Service/ServiceInterfaceStubGenerator.fs + + + Service/ServiceStructure.fsi + + + Service/ServiceStructure.fs + + + Service/fsi.fsi + + + Service/fsi.fs + + + + + + + + + + $(FSharpSourcesRoot)\..\..\packages\Microsoft.DiaSymReader.PortablePdb.1.1.0\lib\portable-net45+win8\Microsoft.DiaSymReader.PortablePdb.dll + + + $(FSharpSourcesRoot)\..\..\packages\Microsoft.DiaSymReader.1.1.0\lib\portable-net45+win8\Microsoft.DiaSymReader.dll + + + $(FSharpSourcesRoot)\..\..\packages\System.Reflection.Metadata.1.4.2\lib\portable-net45+win8\System.Reflection.Metadata.dll + + + $(FSharpSourcesRoot)\..\..\packages\System.Collections.Immutable.1.2.0\lib\portable-net45+win8+wp8+wpa81\System.Collections.Immutable.dll + + + + + + {DED3BBD7-53F4-428A-8C9F-27968E768605} + FSharp.Core + + + + + \ No newline at end of file diff --git a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.netcore.fsproj b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.netcore.fsproj new file mode 100644 index 00000000000..f3fc95c42e9 --- /dev/null +++ b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.netcore.fsproj @@ -0,0 +1,603 @@ + + + 12.0.8 + netstandard1.6 + FSharp.Compiler.Service + $(DefineConstants);BUILDING_WITH_LKG + $(DefineConstants);COMPILER + $(DefineConstants);COMPILER_PUBLIC_API + $(DefineConstants);COMPILER_SERVICE + $(DefineConstants);COMPILER_SERVICE_DLL + $(DefineConstants);FX_PORTABLE_OR_NETSTANDARD + $(DefineConstants);FX_ATLEAST_PORTABLE + $(DefineConstants);NETSTANDARD1_6 + $(DefineConstants);PREFERRED_UI_LANG + $(DefineConstants);FX_EVENTWAITHANDLE_NO_IDISPOSABLE + $(DefineConstants);FX_NO_APP_DOMAINS + $(DefineConstants);FX_NO_ARRAY_LONG_LENGTH + $(DefineConstants);FX_NO_BEGINEND_READWRITE + $(DefineConstants);FX_NO_BINARY_SERIALIZATION + $(DefineConstants);FX_NO_CONVERTER + $(DefineConstants);FX_NO_CORHOST_SIGNER + $(DefineConstants);FX_NO_CUSTOMATTRIBUTEDATA + $(DefineConstants);FX_NO_DEFAULT_DEPENDENCY_TYPE + $(DefineConstants);FX_NO_EXIT_CONTEXT_FLAGS + $(DefineConstants);FX_NO_HEAPTERMINATION + $(DefineConstants);FX_NO_LINKEDRESOURCES + $(DefineConstants);FX_NO_PARAMETERIZED_THREAD_START + $(DefineConstants);FX_NO_PDB_READER + $(DefineConstants);FX_NO_PDB_WRITER + $(DefineConstants);FX_NO_REFLECTION_MODULE_HANDLES + $(DefineConstants);FX_NO_RUNTIMEENVIRONMENT + $(DefineConstants);FX_NO_SECURITY_PERMISSIONS + $(DefineConstants);FX_NO_SERVERCODEPAGES + $(DefineConstants);FX_NO_SYMBOLSTORE + $(DefineConstants);FX_NO_SYSTEM_CONFIGURATION + $(DefineConstants);FX_NO_THREAD + $(DefineConstants);FX_NO_THREADABORT + $(DefineConstants);FX_NO_WAITONE_MILLISECONDS + $(DefineConstants);FX_NO_WEB_CLIENT + $(DefineConstants);FX_NO_WINFORMS + $(DefineConstants);FX_NO_WIN_REGISTRY + $(DefineConstants);FX_REDUCED_CONSOLE + $(DefineConstants);FX_REDUCED_EXCEPTIONS + $(DefineConstants);FX_RESHAPED_CONSOLE + $(DefineConstants);FX_RESHAPED_GLOBALIZATION + $(DefineConstants);FX_RESHAPED_REFEMIT + $(DefineConstants);FX_RESHAPED_REFLECTION + $(DefineConstants);FX_RESHAPED_REFLECTION_CORECLR + $(DefineConstants);FSI_TODO_NETCORE + $(DefineConstants);NO_DEBUG_LOG + $(DefineConstants);NO_INLINE_IL_PARSER + $(DefineConstants);NO_LOADER_OPTIMIZATION + $(DefineConstants);NO_LOGGING_GUI + $(DefineConstants);RESHAPED_MSBUILD + $(DefineConstants);SIGNED + $(DefineConstants);STRONG_NAME_AND_DELAY_SIGN_FSHARP_COMPILER_WITH_MSFT_KEY + $(NoWarn);44;69;65;54;61;75;62;9;2003; + true + true + true + + false + + + + AssemblyInfo/assemblyinfo.FSharp.Compiler.Service.dll.fs + + + AssemblyInfo/assemblyinfo.shared.fs + + + FSComp.resx + + + FSStrings.resx + + + FSIstrings.resx + + + + + Reshaped/reshapedreflection.fs + + + ErrorText/sformat.fsi + + + ErrorText/sformat.fs + + + ErrorText/sr.fsi + + + ErrorText/sr.fs + + + LexYaccRuntime/prim-lexing.fsi + + + LexYaccRuntime/prim-lexing.fs + + + LexYaccRuntime/prim-parsing.fsi + + + LexYaccRuntime/prim-parsing.fs + + + Utilities/ResizeArray.fsi + + + Utilities/ResizeArray.fs + + + Utilities/HashMultiMap.fsi + + + Utilities/HashMultiMap.fs + + + Utilities/EditDistance.fs + + + Utilities/TaggedCollections.fsi + + + Utilities/TaggedCollections.fs + + + Utilities/QueueList.fs + + + Utilities/ildiag.fsi + + + Utilities/ildiag.fs + + + Utilities/illib.fs + + + Utilities/filename.fsi + + + Utilities/filename.fs + + + Utilities/zmap.fsi + + + Utilities/zmap.fs + + + Utilities/zset.fsi + + + Utilities/zset.fs + + + Utilities/bytes.fsi + + + Utilities/bytes.fs + + + Utilities/lib.fs + + + Utilities/InternalCollections.fsi + + + Utilities/InternalCollections.fs + + + Utilities/rational.fsi + + + Utilities/rational.fs + + + ErrorLogging/range.fsi + + + ErrorLogging/range.fs + + + ErrorLogging/ErrorLogger.fs + + + ErrorLogging/ErrorResolutionHints.fs + + + ReferenceResolution/ReferenceResolver.fs + + + AbsIL/il.fsi + + + AbsIL/il.fs + + + AbsIL/ilx.fsi + + + AbsIL/ilx.fs + + + AbsIL/ilascii.fsi + + + AbsIL/ilascii.fs + + + AbsIL/ilprint.fsi + + + AbsIL/ilprint.fs + + + AbsIL/ilmorph.fsi + + + AbsIL/ilmorph.fs + + + AbsIL/ilsign.fs + + + AbsIL/ilsupp.fsi + + + AbsIL/ilsupp.fs + + + AbsIL/ilpars.fs + + + AbsIL/illex.fs + + + AbsIL/ilbinary.fsi + + + AbsIL/ilbinary.fs + + + AbsIL/ilread.fsi + + + AbsIL/ilread.fs + + + AbsIL/ilwritepdb.fsi + + + AbsIL/ilwritepdb.fs + + + AbsIL/ilwrite.fsi + + + AbsIL/ilwrite.fs + + + AbsIL/ilreflect.fs + + + CompilerLocation/CompilerLocationUtils.fs + + + PrettyNaming/PrettyNaming.fs + + + ILXErase/ilxsettings.fs + + + ILXErase/EraseClosures.fsi + + + ILXErase/EraseClosures.fs + + + ILXErase/EraseUnions.fsi + + + ILXErase/EraseUnions.fs + + + ParserAndUntypedAST/UnicodeLexing.fsi + + + ParserAndUntypedAST/UnicodeLexing.fs + + + ParserAndUntypedAST/layout.fsi + + + ParserAndUntypedAST/layout.fs + + + ParserAndUntypedAST/ast.fs + + + ParserAndUntypedAST/pppars.fs + + + ParserAndUntypedAST/pars.fs + + + ParserAndUntypedAST/lexhelp.fsi + + + ParserAndUntypedAST/lexhelp.fs + + + ParserAndUntypedAST/pplex.fs + + + ParserAndUntypedAST/lex.fs + + + ParserAndUntypedAST/LexFilter.fs + + + TypedAST/tainted.fsi + + + TypedAST/tainted.fs + + + TypedAST/ExtensionTyping.fsi + + + TypedAST/ExtensionTyping.fs + + + TypedAST/QuotationPickler.fsi + + + TypedAST/QuotationPickler.fs + + + TypedAST/tast.fs + + + TypedAST/TcGlobals.fs + + + TypedAST/TastOps.fsi + + + TypedAST/TastOps.fs + + + TypedAST/TastPickle.fsi + + + TypedAST/TastPickle.fs + + + Logic/import.fsi + + + Logic/import.fs + + + Logic/infos.fs + + + Logic/AccessibilityLogic.fs + + + Logic/AttributeChecking.fs + + + Logic/InfoReader.fs + + + Logic/NicePrint.fs + + + Logic/AugmentWithHashCompare.fsi + + + Logic/AugmentWithHashCompare.fs + + + Logic/NameResolution.fsi + + + Logic/NameResolution.fs + + + Logic/TypeRelations.fs + + + Logic/SignatureConformance.fs + + + Logic/MethodOverrides.fs + + + Logic/MethodCalls.fs + + + Logic/PatternMatchCompilation.fsi + + + Logic/PatternMatchCompilation.fs + + + Logic/ConstraintSolver.fsi + + + Logic/ConstraintSolver.fs + + + Logic/CheckFormatStrings.fsi + + + Logic/CheckFormatStrings.fs + + + Logic/FindUnsolved.fs + + + Logic/QuotationTranslator.fsi + + + Logic/QuotationTranslator.fs + + + Logic/PostInferenceChecks.fsi + + + Logic/PostInferenceChecks.fs + + + Logic/TypeChecker.fsi + + + Logic/TypeChecker.fs + + + Optimize/Optimizer.fsi + + + Optimize/Optimizer.fs + + + Optimize/DetupleArgs.fsi + + + Optimize/DetupleArgs.fs + + + Optimize/InnerLambdasToTopLevelFuncs.fsi + + + Optimize/InnerLambdasToTopLevelFuncs.fs + + + Optimize/LowerCallsAndSeqs.fs + + + Optimize/autobox.fs + + + CodeGen/IlxGen.fsi + + + CodeGen/IlxGen.fs + + + Driver/CompileOps.fsi + + + Driver/CompileOps.fs + + + Driver/CompileOptions.fsi + + + Driver/CompileOptions.fs + + + Driver/fsc.fsi + + + Driver/fsc.fs + + + Service/IncrementalBuild.fsi + + + Service/IncrementalBuild.fs + + + Service/Reactor.fsi + + + Service/Reactor.fs + + + Service/ServiceConstants.fs + + + Symbols/SymbolHelpers.fsi + + + Symbols/SymbolHelpers.fs + + + Symbols/Symbols.fsi + + + Symbols/Symbols.fs + + + Symbols/Exprs.fsi + + + Symbols/Exprs.fs + + + Service/ServiceLexing.fsi + + + Service/ServiceLexing.fs + + + Service/ServiceParseTreeWalk.fs + + + Service/ServiceNavigation.fsi + + + Service/ServiceNavigation.fs + + + Service/ServiceParamInfoLocations.fsi + + + Service/ServiceParamInfoLocations.fs + + + Service/ServiceUntypedParse.fsi + + + Service/ServiceUntypedParse.fs + + + Service/reshapedmsbuild.fs + + + Service/SimulatedMSBuildReferenceResolver.fs + + + Service/ServiceAssemblyContent.fsi + + + Service/ServiceAssemblyContent.fs + + + Service/service.fsi + + + Service/service.fs + + + Service/SimpleServices.fsi + + + Service/SimpleServices.fs + + + Service/fsi.fsi + + + Service/fsi.fs + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/src/FSharpSource.Settings.targets b/src/FSharpSource.Settings.targets index 450bb7ccc3d..2d72ed44902 100644 --- a/src/FSharpSource.Settings.targets +++ b/src/FSharpSource.Settings.targets @@ -72,7 +72,6 @@ true DEBUG;TRACE;CODE_ANALYSIS;$(DefineConstants) DEBUG=True,TRACE=True,CODE_ANALYSIS=True,$(DefineConstants) - false @@ -84,7 +83,6 @@ prompt TRACE;$(DefineConstants) TRACE=True,$(DefineConstants) - false diff --git a/src/FSharpSource.targets b/src/FSharpSource.targets index edcfb50957c..75e8b108a86 100644 --- a/src/FSharpSource.targets +++ b/src/FSharpSource.targets @@ -26,8 +26,8 @@ - - + + $(OtherFlags) --keyfile:"$(FSharpSourcesRoot)\fsharp\test.snk" STRONG_NAME_FSHARP_COMPILER_WITH_TEST_KEY;$(DefineConstants) @@ -36,54 +36,25 @@ fs - - - true - - - $(OtherFlags) --delaysign+ - $(OtherFlags) --publicsign+ - $(OtherFlags) --keyfile:"$(FSharpSourcesRoot)\fsharp\msft.pubkey" - STRONG_NAME_AND_DELAY_SIGN_FSHARP_COMPILER_WITH_MSFT_KEY;$(DefineConstants) - true - $(FSCoreVersion) - fs - - - - - $(OtherFlags) --delaysign+ - $(OtherFlags) --publicsign+ - $(OtherFlags) --keyfile:"$(FSharpSourcesRoot)\fsharp\msft.pubkey" - STRONG_NAME_AND_DELAY_SIGN_FSHARP_COMPILER_WITH_MSFT_KEY;$(DefineConstants) - true - 15.4.1.0 - fs - - - - - - true - false - $(FSCoreVersion) - fs - - + + - + $(OtherFlags) --delaysign+ $(OtherFlags) --publicsign+ $(OtherFlags) --keyfile:"$(FSharpSourcesRoot)\fsharp\msft.pubkey" STRONG_NAME_AND_DELAY_SIGN_FSHARP_COMPILER_WITH_MSFT_KEY;$(DefineConstants) true $(FSCoreVersion) + + 15.4.1.0 fs + true $(FSharpSourcesRoot)\fsharp\msft.pubkey @@ -142,8 +113,6 @@ $(DefineConstants);ENABLE_MONO_SUPPORT $(DefineConstants);BE_SECURITY_TRANSPARENT $(DefineConstants);FX_LCIDFROMCODEPAGE - $(DefineConstants);FSI_SHADOW_COPY_REFERENCES - $(DefineConstants);FSI_SERVER v4.5 diff --git a/src/absil/il.fs b/src/absil/il.fs index f09ae09ac9c..c121b455c7f 100644 --- a/src/absil/il.fs +++ b/src/absil/il.fs @@ -1,6 +1,6 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. -module internal Microsoft.FSharp.Compiler.AbstractIL.IL +module Microsoft.FSharp.Compiler.AbstractIL.IL #nowarn "49" #nowarn "343" // The type 'ILAssemblyRef' implements 'System.IComparable' explicitly but provides no corresponding override for 'Object.Equals'. @@ -768,7 +768,7 @@ type ILFieldSpec = // Debug info. // -------------------------------------------------------------------- -type Guid = byte[] +type ILGuid = byte[] type ILPlatform = | X86 @@ -776,9 +776,9 @@ type ILPlatform = | IA64 type ILSourceDocument = - { sourceLanguage: Guid option; - sourceVendor: Guid option; - sourceDocType: Guid option; + { sourceLanguage: ILGuid option; + sourceVendor: ILGuid option; + sourceDocType: ILGuid option; sourceFile: string; } static member Create(language,vendor,docType,file) = { sourceLanguage=language; @@ -1112,7 +1112,7 @@ type ILFieldInit = [] type ILNativeType = | Empty - | Custom of Guid * string * string * byte[] (* guid,nativeTypeName,custMarshallerName,cookieString *) + | Custom of ILGuid * string * string * byte[] (* guid,nativeTypeName,custMarshallerName,cookieString *) | FixedSysString of int32 | FixedArray of int32 | Currency @@ -3681,6 +3681,31 @@ let compareILVersions (a1,a2,a3,a4) ((b1,b2,b3,b4) : ILVersionInfo) = if c <> 0 then c else 0 +let unscopeILTypeRef (x: ILTypeRef) = ILTypeRef.Create(ILScopeRef.Local,x.Enclosing,x.Name) + +let rec unscopeILTypeSpec (tspec:ILTypeSpec) = + let tref = tspec.TypeRef + let tinst = tspec.GenericArgs + let tref = unscopeILTypeRef tref + ILTypeSpec.Create (tref, unscopeILTypes tinst) + +and unscopeILType typ = + match typ with + | ILType.Ptr t -> ILType.Ptr (unscopeILType t) + | ILType.FunctionPointer t -> ILType.FunctionPointer (unscopeILCallSig t) + | ILType.Byref t -> ILType.Byref (unscopeILType t) + | ILType.Boxed cr -> mkILBoxedType (unscopeILTypeSpec cr) + | ILType.Array (s,ty) -> ILType.Array (s,unscopeILType ty) + | ILType.Value cr -> ILType.Value (unscopeILTypeSpec cr) + | ILType.Modified(b,tref,ty) -> ILType.Modified(b,unscopeILTypeRef tref, unscopeILType ty) + | x -> x + +and unscopeILTypes i = + if List.isEmpty i then i + else List.map unscopeILType i + +and unscopeILCallSig csig = + mkILCallSig (csig.CallingConv,unscopeILTypes csig.ArgTypes,unscopeILType csig.ReturnType) let resolveILMethodRefWithRescope r td (mref:ILMethodRef) = let args = mref.ArgTypes @@ -3688,13 +3713,15 @@ let resolveILMethodRefWithRescope r td (mref:ILMethodRef) = let nm = mref.Name let possibles = td.Methods.FindByNameAndArity (nm,nargs) if isNil possibles then failwith ("no method named " + nm + " found in type " + td.Name) + let argTypes = mref.ArgTypes |> List.map r + let retType : ILType = r mref.ReturnType match possibles |> List.filter (fun md -> mref.CallingConv = md.CallingConv && // REVIEW: this uses equality on ILType. For CMOD_OPTIONAL this is not going to be correct - (md.Parameters,mref.ArgTypes) ||> List.lengthsEqAndForall2 (fun p1 p2 -> r p1.Type = p2) && + (md.Parameters,argTypes) ||> List.lengthsEqAndForall2 (fun p1 p2 -> r p1.Type = p2) && // REVIEW: this uses equality on ILType. For CMOD_OPTIONAL this is not going to be correct - r md.Return.Type = mref.ReturnType) with + r md.Return.Type = retType) with | [] -> failwith ("no method named "+nm+" with appropriate argument types found in type "+td.Name) | [mdef] -> mdef | _ -> failwith ("multiple methods named "+nm+" appear with identical argument types in type "+td.Name) diff --git a/src/absil/il.fsi b/src/absil/il.fsi index 9839c7eccaf..7c8ac9c6d95 100644 --- a/src/absil/il.fsi +++ b/src/absil/il.fsi @@ -2,7 +2,11 @@ /// The "unlinked" view of .NET metadata and code. Central to /// to Abstract IL library +#if COMPILER_PUBLIC_API +module Microsoft.FSharp.Compiler.AbstractIL.IL +#else module internal Microsoft.FSharp.Compiler.AbstractIL.IL +#endif open Internal.Utilities open System.Collections.Generic @@ -57,7 +61,7 @@ type PrimaryAssembly = // ==================================================================== // Guids (Note: consider adjusting these to the System.Guid type) -type Guid = byte[] +type ILGuid = byte[] [] type ILPlatform = @@ -69,10 +73,10 @@ type ILPlatform = /// points and some other locations. [] type ILSourceDocument = - static member Create : language: Guid option * vendor: Guid option * documentType: Guid option * file: string -> ILSourceDocument - member Language: Guid option - member Vendor: Guid option - member DocumentType: Guid option + static member Create : language: ILGuid option * vendor: ILGuid option * documentType: ILGuid option * file: string -> ILSourceDocument + member Language: ILGuid option + member Vendor: ILGuid option + member DocumentType: ILGuid option member File: string @@ -748,7 +752,7 @@ type ILNativeVariant = [] type ILNativeType = | Empty - | Custom of Guid * string * string * byte[] (* guid,nativeTypeName,custMarshallerName,cookieString *) + | Custom of ILGuid * string * string * byte[] (* guid,nativeTypeName,custMarshallerName,cookieString *) | FixedSysString of int32 | FixedArray of int32 | Currency @@ -845,7 +849,7 @@ type ILAttributeNamedArg = string * ILType * bool * ILAttribElem /// Custom attributes. See 'decodeILAttribData' for a helper to parse the byte[] /// to ILAttribElem's as best as possible. type ILAttribute = - { Method: ILMethodSpec; + { Method: ILMethodSpec; Data: byte[] } [] @@ -1844,6 +1848,9 @@ val rescopeILMethodRef: ILScopeRef -> ILMethodRef -> ILMethodRef /// the new scope. val rescopeILFieldRef: ILScopeRef -> ILFieldRef -> ILFieldRef +/// Unscoping. Clears every scope information, use for looking up IL method references only. +val unscopeILType: ILType -> ILType + //----------------------------------------------------------------------- // The ILCode Builder utility. //---------------------------------------------------------------------- diff --git a/src/absil/illib.fs b/src/absil/illib.fs index 001f4640cdf..138a80f83ed 100644 --- a/src/absil/illib.fs +++ b/src/absil/illib.fs @@ -1,6 +1,10 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. +#if COMPILER_PUBLIC_API +module Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +#else module internal Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +#endif #nowarn "1178" // The struct, record or union type 'internal_instr_extension' is not structurally comparable because the type @@ -9,8 +13,6 @@ open System.Collections open System.Collections.Generic open System.Reflection open Internal.Utilities -open Internal.Utilities.Collections -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics #if FX_RESHAPED_REFLECTION open Microsoft.FSharp.Core.ReflectionAdapters @@ -52,7 +54,7 @@ let reportTime = let t = System.Diagnostics.Process.GetCurrentProcess().UserProcessorTime.TotalSeconds let prev = match !tPrev with None -> 0.0 | Some t -> t let first = match !tFirst with None -> (tFirst := Some t; t) | Some t -> t - dprintf "ilwrite: TIME %10.3f (total) %10.3f (delta) - %s\n" (t - first) (t - prev) descr + printf "ilwrite: TIME %10.3f (total) %10.3f (delta) - %s\n" (t - first) (t - prev) descr tPrev := Some t //------------------------------------------------------------------------- @@ -263,8 +265,25 @@ module Option = let attempt (f: unit -> 'T) = try Some (f()) with _ -> None + + let orElseWith f opt = + match opt with + | None -> f() + | x -> x + + let orElse v opt = + match opt with + | None -> v + | x -> x + + let defaultValue v opt = + match opt with + | None -> v + | Some x -> x + module List = + //let item n xs = List.nth xs n #if FX_RESHAPED_REFLECTION open PrimReflectionAdapters open Microsoft.FSharp.Core.ReflectionAdapters @@ -1073,6 +1092,42 @@ module Tables = else res <- f x; t.[x] <- res; res + +/// Interface that defines methods for comparing objects using partial equality relation +type IPartialEqualityComparer<'T> = + inherit IEqualityComparer<'T> + /// Can the specified object be tested for equality? + abstract InEqualityRelation : 'T -> bool + +module IPartialEqualityComparer = + let On f (c: IPartialEqualityComparer<_>) = + { new IPartialEqualityComparer<_> with + member __.InEqualityRelation x = c.InEqualityRelation (f x) + member __.Equals(x, y) = c.Equals(f x, f y) + member __.GetHashCode x = c.GetHashCode(f x) } + + + + // Wrapper type for use by the 'partialDistinctBy' function + [] + type private WrapType<'T> = Wrap of 'T + + // Like Seq.distinctBy but only filters out duplicates for some of the elements + let partialDistinctBy (per:IPartialEqualityComparer<'T>) seq = + let wper = + { new IPartialEqualityComparer> with + member __.InEqualityRelation (Wrap x) = per.InEqualityRelation (x) + member __.Equals(Wrap x, Wrap y) = per.Equals(x, y) + member __.GetHashCode (Wrap x) = per.GetHashCode(x) } + // Wrap a Wrap _ around all keys in case the key type is itself a type using null as a representation + let dict = Dictionary,obj>(wper) + seq |> List.filter (fun v -> + let key = Wrap(v) + if (per.InEqualityRelation(v)) then + if dict.ContainsKey(key) then false else (dict.[key] <- null; true) + else true) + + //------------------------------------------------------------------------- // Library: Name maps //------------------------------------------------------------------------ diff --git a/src/absil/ilread.fs b/src/absil/ilread.fs index eeaa4e6ab5a..c0a2c0be973 100644 --- a/src/absil/ilread.fs +++ b/src/absil/ilread.fs @@ -3967,20 +3967,26 @@ let OpenILModuleReader infile opts = // ++GLOBAL MUTABLE STATE (concurrency safe via locking) type ILModuleReaderCacheLockToken() = interface LockToken -let ilModuleReaderCache = new AgedLookup(0, areSame=(fun (x,y) -> x = y)) +let ilModuleReaderCache = new AgedLookup(0, areSame=(fun (x,y) -> x = y)) let ilModuleReaderCacheLock = Lock() let OpenILModuleReaderAfterReadingAllBytes infile opts = // Pseudo-normalize the paths. let key,succeeded = - try (FileSystem.GetFullPathShim(infile), FileSystem.GetLastWriteTimeShim(infile)), true + try + (FileSystem.GetFullPathShim(infile), + FileSystem.GetLastWriteTimeShim(infile), + opts.ilGlobals.primaryAssemblyScopeRef, + opts.pdbPath.IsSome), true with e -> - System.Diagnostics.Debug.Assert(false, "Failed to compute key in OpenILModuleReaderAfterReadingAllBytes cache. Falling back to uncached.") - ("",System.DateTime.Now), false + System.Diagnostics.Debug.Assert(false, sprintf "Failed to compute key in OpenILModuleReaderAfterReadingAllBytes cache for '%s'. Falling back to uncached." infile) + ("",System.DateTime.Now,ILScopeRef.Local,false), false + let cacheResult = if not succeeded then None // Fall back to uncached. else if opts.pdbPath.IsSome then None // can't used a cached entry when reading PDBs, since it makes the returned object IDisposable else ilModuleReaderCacheLock.AcquireLock (fun ltok -> ilModuleReaderCache.TryGet(ltok, key)) + match cacheResult with | Some(ilModuleReader) -> ilModuleReader | None -> diff --git a/src/absil/ilsupp.fs b/src/absil/ilsupp.fs index 76af3d325ae..80ca547386d 100644 --- a/src/absil/ilsupp.fs +++ b/src/absil/ilsupp.fs @@ -1183,8 +1183,8 @@ let pdbReadOpen (moduleName:string) (path:string) : PdbReader = with _ -> { symReader = null } #else - let symbolBinder = new System.Diagnostics.SymbolStore.SymBinder() - { symReader = symbolBinder.GetReader(importerPtr, moduleName, path) } + let symbolBinder = new System.Diagnostics.SymbolStore.SymBinder() + { symReader = symbolBinder.GetReader(importerPtr, moduleName, path) } #endif finally // Marshal.GetComInterfaceForObject adds an extra ref for importerPtr diff --git a/src/assemblyinfo/assemblyinfo.FSharp.Compiler.Service.MSBuild.v12.dll.fs b/src/assemblyinfo/assemblyinfo.FSharp.Compiler.Service.MSBuild.v12.dll.fs new file mode 100644 index 00000000000..c7f68fe89ac --- /dev/null +++ b/src/assemblyinfo/assemblyinfo.FSharp.Compiler.Service.MSBuild.v12.dll.fs @@ -0,0 +1,14 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +namespace Microsoft.FSharp +open System.Reflection +open System.Runtime.InteropServices + +[] +[] +[] +[] + +[] +[] +do() diff --git a/src/assemblyinfo/assemblyinfo.FSharp.Compiler.Service.dll.fs b/src/assemblyinfo/assemblyinfo.FSharp.Compiler.Service.dll.fs new file mode 100644 index 00000000000..13141ee3b65 --- /dev/null +++ b/src/assemblyinfo/assemblyinfo.FSharp.Compiler.Service.dll.fs @@ -0,0 +1,75 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +namespace Microsoft.FSharp +open System.Reflection +open System.Runtime.InteropServices + +[] +[] +[] +[] + +[] +[] +[] +[] +[] +[] +[] +[] + +#if NO_STRONG_NAMES +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] + +// Note: internals visible to unit test DLLs in Retail (and all) builds. +[] +[] +[] +[] +[] +#endif +#if STRONG_NAME_AND_DELAY_SIGN_FSHARP_COMPILER_WITH_MSFT_KEY +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +#endif +#if STRONG_NAME_FSHARP_COMPILER_WITH_TEST_KEY +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +#endif +do() diff --git a/src/fsharp/CheckFormatStrings.fs b/src/fsharp/CheckFormatStrings.fs index 63df8eec55a..0b5fbe686ed 100644 --- a/src/fsharp/CheckFormatStrings.fs +++ b/src/fsharp/CheckFormatStrings.fs @@ -195,27 +195,30 @@ let parseFormatStringInternal (m:range) (g: TcGlobals) (source: string option) f checkNoZeroFlag c checkNoNumericPrefix c - let collectSpecifierLocation relLine relCol = + let collectSpecifierLocation relLine relCol numStdArgs = + let numArgsForSpecifier = + numStdArgs + (if widthArg then 1 else 0) + (if precisionArg then 1 else 0) match relLine with | 0 -> specifierLocations.Add( - Range.mkFileIndexRange m.FileIndex + (Range.mkFileIndexRange m.FileIndex (Range.mkPos m.StartLine (startCol + offset)) - (Range.mkPos m.StartLine (relCol + offset + 1))) + (Range.mkPos m.StartLine (relCol + offset + 1))), numArgsForSpecifier) | _ -> specifierLocations.Add( - Range.mkFileIndexRange m.FileIndex + (Range.mkFileIndexRange m.FileIndex (Range.mkPos (m.StartLine + relLine) startCol) - (Range.mkPos (m.StartLine + relLine) (relCol + 1))) + (Range.mkPos (m.StartLine + relLine) (relCol + 1))), numArgsForSpecifier) let ch = fmt.[i] match ch with - | '%' -> + | '%' -> + collectSpecifierLocation relLine relCol 0 parseLoop acc (i+1, relLine, relCol+1) | ('d' | 'i' | 'o' | 'u' | 'x' | 'X') -> if info.precision then failwithf "%s" <| FSComp.SR.forFormatDoesntSupportPrecision(ch.ToString()) - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 1 parseLoop ((posi, mkFlexibleIntFormatTypar g m) :: acc) (i+1, relLine, relCol+1) | ('l' | 'L') -> @@ -230,7 +233,7 @@ let parseFormatStringInternal (m:range) (g: TcGlobals) (source: string option) f failwithf "%s" <| FSComp.SR.forLIsUnnecessary() match fmt.[i] with | ('d' | 'i' | 'o' | 'u' | 'x' | 'X') -> - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 1 parseLoop ((posi, mkFlexibleIntFormatTypar g m) :: acc) (i+1, relLine, relCol+1) | _ -> failwithf "%s" <| FSComp.SR.forBadFormatSpecifier() @@ -238,38 +241,38 @@ let parseFormatStringInternal (m:range) (g: TcGlobals) (source: string option) f failwithf "%s" <| FSComp.SR.forHIsUnnecessary() | 'M' -> - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 1 parseLoop ((posi, mkFlexibleDecimalFormatTypar g m) :: acc) (i+1, relLine, relCol+1) | ('f' | 'F' | 'e' | 'E' | 'g' | 'G') -> - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 1 parseLoop ((posi, mkFlexibleFloatFormatTypar g m) :: acc) (i+1, relLine, relCol+1) | 'b' -> checkOtherFlags ch - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 1 parseLoop ((posi, g.bool_ty) :: acc) (i+1, relLine, relCol+1) | 'c' -> checkOtherFlags ch - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 1 parseLoop ((posi, g.char_ty) :: acc) (i+1, relLine, relCol+1) | 's' -> checkOtherFlags ch - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 1 parseLoop ((posi, g.string_ty) :: acc) (i+1, relLine, relCol+1) | 'O' -> checkOtherFlags ch - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 1 parseLoop ((posi, NewInferenceType ()) :: acc) (i+1, relLine, relCol+1) | 'A' -> match info.numPrefixIfPos with | None // %A has BindingFlags=Public, %+A has BindingFlags=Public | NonPublic | Some '+' -> - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 1 parseLoop ((posi, NewInferenceType ()) :: acc) (i+1, relLine, relCol+1) | Some _ -> failwithf "%s" <| FSComp.SR.forDoesNotSupportPrefixFlag(ch.ToString(), (Option.get info.numPrefixIfPos).ToString()) @@ -277,12 +280,12 @@ let parseFormatStringInternal (m:range) (g: TcGlobals) (source: string option) f checkOtherFlags ch let xty = NewInferenceType () let fty = bty --> (xty --> cty) - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 2 parseLoop ((Option.map ((+)1) posi, xty) :: (posi, fty) :: acc) (i+1, relLine, relCol+1) | 't' -> checkOtherFlags ch - collectSpecifierLocation relLine relCol + collectSpecifierLocation relLine relCol 1 parseLoop ((posi, bty --> cty) :: acc) (i+1, relLine, relCol+1) | c -> failwithf "%s" <| FSComp.SR.forBadFormatSpecifierGeneral(String.make 1 c) diff --git a/src/fsharp/CheckFormatStrings.fsi b/src/fsharp/CheckFormatStrings.fsi index cd04c36d67b..616f79736c9 100644 --- a/src/fsharp/CheckFormatStrings.fsi +++ b/src/fsharp/CheckFormatStrings.fsi @@ -13,6 +13,6 @@ open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.AbstractIL.Internal -val ParseFormatString : Range.range -> TcGlobals -> source: string option -> fmt: string -> bty: TType -> cty: TType -> dty: TType -> (TType * TType) * Range.range list +val ParseFormatString : Range.range -> TcGlobals -> source: string option -> fmt: string -> bty: TType -> cty: TType -> dty: TType -> (TType * TType) * (Range.range * int) list val TryCountFormatStringArguments : m:Range.range -> g:TcGlobals -> fmt:string -> bty:TType -> cty:TType -> int option diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index dde739894be..8ac11a3f09c 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -58,20 +58,14 @@ open Microsoft.FSharp.Core.ReflectionAdapters #endif #if DEBUG - -#if COMPILED_AS_LANGUAGE_SERVICE_DLL +[] +#if COMPILER_SERVICE module internal CompilerService = #else module internal FullCompiler = #endif let showAssertForUnexpectedException = ref true -#if COMPILED_AS_LANGUAGE_SERVICE_DLL -open CompilerService -#else -open FullCompiler -#endif - -#endif +#endif // DEBUG //---------------------------------------------------------------------------- // Some Globals @@ -1639,12 +1633,48 @@ let GetFSharpCoreReferenceUsedByCompiler(useSimpleResolution) = // So use the FSharp.Core.dll from alongside the fsc compiler. // This can also be used for the out of gac work on DEV15 let fscCoreLocation = - let fscLocation = typeof.Assembly.Location + let fscLocation = typeof.Assembly.Location Path.Combine(Path.GetDirectoryName(fscLocation), fsCoreName + ".dll") if File.Exists(fscCoreLocation) then fscCoreLocation - else failwithf "Internal error: Could not find %s" fsCoreName + else failwithf "Internal error: Could not find %s" fscCoreLocation #else - // TODO: Remove this when we do out of GAC for DEV 15 because above code will work everywhere. +#if COMPILER_SERVICE_DLL + // The component: + // FSharp.Compiler.Service.dll + // assumes for the version of FSharp.Core running in the hosting environment when processing + // scripts and out-of-project files. + let foundReference = + match System.Reflection.Assembly.GetEntryAssembly() with + | null -> None + | entryAssembly -> + entryAssembly.GetReferencedAssemblies() + |> Array.tryPick (fun name -> + if name.Name = fsCoreName then Some(name.ToString()) + else None) + + // if not we use the referenced FSharp.Core from this project + match foundReference with + | Some fsharpCore -> fsharpCore + | None -> +#endif + // All of these: + // Visual F# fsc.exe + // Visual F# IDE Tools FSharp.LanguageService.Compiler.dll + // FSharp.Compiler.Tools nuget package fsc.exe + // Mono /usr/lib/mono/fsharp/fsc.exe + // + // assume a reference to the latest .NET Framework FSharp.Core with which those tools are built, e.g. + // "FSharp.Core, Version=4.4.1.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" + // This is always known to ship as part of an installation of any delivery of the F# Compiler. + // This reference gets resolved either using the compiler tools directory itself, or using the + // AssemblyFoldersEx key on Windows, or the /usr/lib/mono/4.5/FSharp.Core.dll on Mono + // It doesn't get resolved to the GAC. + // + // In pretty much all these cases we could probably look directly in the folder where the relevant tool is located. + // Even in the case of FSharp.LanguageService.Compiler.dll this component is installed into + // ...Program Files (x86)\Microsoft Visual Studio\2017\Professional\Common7\IDE\CommonExtensions\Microsoft\FSharp + // However that DLL can also be in the GAC + // typeof.Assembly.GetReferencedAssemblies() |> Array.pick (fun name -> if name.Name = fsCoreName then Some(name.ToString()) @@ -1683,13 +1713,30 @@ let DefaultReferencesForScriptsAndOutOfProjectSources(assumeDotNetFramework) = yield "System.Collections" // System.Collections.Generic.List yield "System.Runtime.Numerics" // BigInteger yield "System.Threading" // OperationCanceledException +#if !COMPILER_SERVICE_DLL // avoid a default reference to System.ValueTuple.dll when compiling with FSharp.Compiler.Service.dll. This is an inconsistency that is still to be ironed out. yield "System.ValueTuple" +#endif yield "System.Web" yield "System.Web.Services" yield "System.Windows.Forms" yield "System.Numerics" - ] +#if COMPILER_SERVICE_DLL + else + yield Path.Combine(Path.GetDirectoryName(typeof.Assembly.Location),"mscorlib.dll"); // mscorlib + yield typeof.Assembly.Location; // System.Console + yield typeof.Assembly.Location; // System.Runtime + yield typeof.Assembly.Location; // System.ObjectModel + yield typeof.Assembly.Location; // System.IO + yield typeof.Assembly.Location; // System.Linq + //yield typeof.Assembly.Location; // System.Xml.Linq + yield typeof.Assembly.Location; // System.Net.Requests + yield typeof.Assembly.Location; // System.Runtime.Numerics + yield typeof.Assembly.Location; // System.Threading.Tasks + yield typeof.Assembly.Location; // FSharp.Core +#endif + ] + // A set of assemblies to always consider to be system assemblies. A common set of these can be used a shared // resources between projects in the compiler services. Also all assembles where well-known system types exist @@ -1698,7 +1745,7 @@ let SystemAssemblies () = HashSet [ yield "mscorlib" yield "System.Runtime" - yield "FSharp.Core" + yield GetFSharpCoreLibraryName() yield "System" yield "System.Xml" yield "System.Runtime.Remoting" @@ -1804,8 +1851,14 @@ let SystemAssemblies () = // REVIEW: it isn't clear if there is any negative effect // of leaving an assembly off this list. let BasicReferencesForScriptLoadClosure(useSimpleResolution, useFsiAuxLib, assumeDotNetFramework) = - [ if assumeDotNetFramework then + [ + if assumeDotNetFramework then + +#if COMPILER_SERVICE_DLL && NETSTANDARD1_6 + yield Path.Combine(Path.GetDirectoryName(typeof.Assembly.Location),"mscorlib.dll"); // mscorlib +#else yield "mscorlib" +#endif yield GetFSharpCoreReferenceUsedByCompiler(useSimpleResolution) ] @ // Need to resolve these explicitly so they will be found in the reference assemblies directory which is where the .xml files are. DefaultReferencesForScriptsAndOutOfProjectSources(assumeDotNetFramework) @ [ if useFsiAuxLib then yield GetFsiLibraryName () ] @@ -2135,7 +2188,6 @@ type TcConfigBuilder = /// pause between passes? mutable pause : bool - /// whenever possible, emit callvirt instead of call mutable alwaysCallVirt : bool @@ -2168,7 +2220,12 @@ type TcConfigBuilder = System.Diagnostics.Debug.Assert(FileSystem.IsPathRootedShim(implicitIncludeDir), sprintf "implicitIncludeDir should be absolute: '%s'" implicitIncludeDir) if (String.IsNullOrEmpty(defaultFSharpBinariesDir)) then failwith "Expected a valid defaultFSharpBinariesDir" - { primaryAssembly = PrimaryAssembly.Mscorlib // default value, can be overridden using the command line switch + { +#if COMPILER_SERVICE_DLL && NETSTANDARD1_6 + primaryAssembly = PrimaryAssembly.DotNetCore // defaut value, can be overridden using the command line switch +#else + primaryAssembly = PrimaryAssembly.Mscorlib // defaut value, can be overridden using the command line switch +#endif light = None noFeedback=false stackReserveSize=None @@ -2303,7 +2360,11 @@ type TcConfigBuilder = sqmSessionStartedTime = System.DateTime.Now.Ticks emitDebugInfoInQuotations = false exename = None +#if COMPILER_SERVICE_DLL // FSharp.Compiler.Service doesn't copy FSharp.Core.dll implicitly + copyFSharpCore = false +#else copyFSharpCore = true +#endif shadowCopyReferences = false } @@ -2446,7 +2507,7 @@ let OpenILBinary(filename,optimizeForMemory,openBinariesInMemory,ilGlobalsOpt, p ILBinaryReader.OpenILModuleReaderAfterReadingAllBytes filename opts else let location = -#if FSI_SHADOW_COPY_REFERENCES +#if !FX_RESHAPED_REFLECTION_CORECLR // shadow copy not supported // In order to use memory mapped files on the shadow copied version of the Assembly, we `preload the assembly // We swallow all exceptions so that we do not change the exception contract of this API if shadowCopyReferences then @@ -2455,7 +2516,7 @@ let OpenILBinary(filename,optimizeForMemory,openBinariesInMemory,ilGlobalsOpt, p with e -> filename else #else - ignore shadowCopyReferences + ignore shadowCopyReferences #endif filename ILBinaryReader.OpenILModuleReader location opts @@ -2510,7 +2571,6 @@ type AssemblyResolution = return assRef } - //---------------------------------------------------------------------------- // Names to match up refs and defs for assemblies and modules //-------------------------------------------------------------------------- @@ -4922,6 +4982,9 @@ module private ScriptPreprocessClosure = | CodeContext.Compilation | CodeContext.Evaluation -> ReferenceResolver.RuntimeLike #endif tcConfigB.framework <- false + tcConfigB.useSimpleResolution <- useSimpleResolution + // Indicates that there are some references not in BasicReferencesForScriptLoadClosure which should + // be added conditionally once the relevant version of mscorlib.dll has been detected. tcConfigB.implicitlyResolveAssemblies <- false TcConfig.Create(tcConfigB,validate=true) diff --git a/src/fsharp/CompileOps.fsi b/src/fsharp/CompileOps.fsi index e2c707325b1..fb23dff218b 100755 --- a/src/fsharp/CompileOps.fsi +++ b/src/fsharp/CompileOps.fsi @@ -30,7 +30,7 @@ open Microsoft.FSharp.Compiler.ExtensionTyping #if DEBUG -#if COMPILED_AS_LANGUAGE_SERVICE_DLL +#if COMPILER_SERVICE module internal CompilerService = #else module internal FullCompiler = @@ -91,7 +91,7 @@ val GetDiagnosticNumber : PhasedDiagnostic -> int val SplitRelatedDiagnostics : PhasedDiagnostic -> PhasedDiagnostic * PhasedDiagnostic list /// Output an error to a buffer -val OutputPhasedDiagnostic : StringBuilder -> PhasedDiagnostic -> isError: bool -> unit +val OutputPhasedDiagnostic : StringBuilder -> PhasedDiagnostic -> flattenErrors: bool -> unit /// Output an error or warning to a buffer val OutputDiagnostic : implicitIncludeDir:string * showFullPaths: bool * flattenErrors: bool * errorStyle: ErrorStyle * isError:bool -> StringBuilder -> PhasedDiagnostic -> unit @@ -539,9 +539,7 @@ type TcConfig = member sqmNumOfSourceFiles : int member sqmSessionStartedTime : int64 member copyFSharpCore : bool -#if FSI_SHADOW_COPY_REFERENCES member shadowCopyReferences : bool -#endif static member Create : TcConfigBuilder * validate: bool -> TcConfig /// Represents a computation to return a TcConfig. Normally this is just a constant immutable TcConfig, diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs index d98c88f9ccb..cd7db0e42e9 100755 --- a/src/fsharp/ErrorLogger.fs +++ b/src/fsharp/ErrorLogger.fs @@ -1,6 +1,10 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. +#if COMPILER_PUBLIC_API +module Microsoft.FSharp.Compiler.ErrorLogger +#else module internal Microsoft.FSharp.Compiler.ErrorLogger +#endif open Internal.Utilities @@ -182,7 +186,9 @@ type PhasedDiagnostic = { Exception:exn; Phase:BuildPhase } /// Construct a phased error static member Create(exn:exn,phase:BuildPhase) : PhasedDiagnostic = +#if !COMPILER_SERVICE // TODO: renable this assert in the compiler service System.Diagnostics.Debug.Assert(phase<>BuildPhase.DefaultPhase, sprintf "Compile error seen with no phase to attribute it to.%A %s %s" phase exn.Message exn.StackTrace ) +#endif {Exception = exn; Phase=phase} member this.DebugDisplay() = sprintf "%s: %s" (this.Subcategory()) this.Exception.Message @@ -261,8 +267,14 @@ let DiscardErrorsLogger = let AssertFalseErrorLogger = { new ErrorLogger("AssertFalseErrorLogger") with +#if COMPILER_SERVICE // TODO: renable these asserts in the compiler service + member x.DiagnosticSink(phasedError,isError) = (* assert false; *) () + member x.ErrorCount = (* assert false; *) 0 +#else member x.DiagnosticSink(phasedError,isError) = assert false; () - member x.ErrorCount = assert false; 0 } + member x.ErrorCount = assert false; 0 +#endif + } type CapturingErrorLogger(nm) = inherit ErrorLogger(nm) @@ -291,7 +303,11 @@ type internal CompileThreadStatic = static member BuildPhase with get() = match box CompileThreadStatic.buildPhase with +#if COMPILER_SERVICE // TODO: renable these asserts in the compiler service + | null -> (* assert false; *) BuildPhase.DefaultPhase +#else | null -> assert false; BuildPhase.DefaultPhase +#endif | _ -> CompileThreadStatic.buildPhase and set v = CompileThreadStatic.buildPhase <- v diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index fd6229eca7c..f78f103280a 100644 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -28,6 +28,7 @@ tupleRequiredInAbstractMethod,"\nA tuple type is required for one or more argume 204,buildInvalidVersionString,"Invalid version string '%s'" 205,buildInvalidVersionFile,"Invalid version file '%s'" buildProductName,"Microsoft (R) F# Compiler version %s" +buildProductNameCommunity,"F# Compiler for F# %s" 206,buildProblemWithFilename,"Problem with filename '%s': %s" 207,buildNoInputsSpecified,"No inputs specified" 209,buildPdbRequiresDebug,"The '--pdb' option requires the '--debug' option to be used" @@ -820,6 +821,7 @@ ilDynamicInvocationNotSupported,"Dynamic invocation of %s is not supported" 994,ilReflectedDefinitionsCannotUseSliceOperator,"Reflected definitions cannot contain uses of the prefix splice operator '%%'" 1000,optsProblemWithCodepage,"Problem with codepage '%d': %s" optsCopyright,"Copyright (c) Microsoft Corporation. All Rights Reserved." +optsCopyrightCommunity,"Freely distributed under the Apache 2.0 Open Source License" optsNameOfOutputFile,"Name of the output file (Short form: -o)" optsBuildConsole,"Build a console executable" optsBuildWindows,"Build a Windows executable" @@ -1406,4 +1408,4 @@ keywordDescriptionTypedQuotation,"Delimits a typed code quotation." keywordDescriptionUntypedQuotation,"Delimits a untyped code quotation." 3216,itemNotFoundDuringDynamicCodeGen,"%s '%s' not found in assembly '%s'. A possible cause may be a version incompatibility. You may need to explicitly reference the correct version of this assembly to allow all referenced components to use the correct version." 3216,itemNotFoundInTypeDuringDynamicCodeGen,"%s '%s' not found in type '%s' from assembly '%s'. A possible cause may be a version incompatibility. You may need to explicitly reference the correct version of this assembly to allow all referenced components to use the correct version." -descriptionWordIs,"is" \ No newline at end of file +descriptionWordIs,"is" diff --git a/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj b/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj index 1700fc15e99..8f0995fd546 100644 --- a/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj +++ b/src/fsharp/FSharp.Compiler-proto/FSharp.Compiler-proto.fsproj @@ -14,8 +14,6 @@ BUILDING_PROTO;$(DefineConstants) BUILDING_WITH_LKG;$(DefineConstants) COMPILER;$(DefineConstants) - INCLUDE_METADATA_READER;$(DefineConstants) - INCLUDE_METADATA_WRITER;$(DefineConstants) $(NoWarn);35;44;62;9;60;86;47;1203 LKG true diff --git a/src/fsharp/FSharp.Compiler.Server.Shared/FSharp.Compiler.Server.Shared.fsproj b/src/fsharp/FSharp.Compiler.Server.Shared/FSharp.Compiler.Server.Shared.fsproj index 17336c00e60..b747a17bcd3 100644 --- a/src/fsharp/FSharp.Compiler.Server.Shared/FSharp.Compiler.Server.Shared.fsproj +++ b/src/fsharp/FSharp.Compiler.Server.Shared/FSharp.Compiler.Server.Shared.fsproj @@ -3,6 +3,7 @@ $(MSBuildProjectDirectory)\..\.. + true diff --git a/src/fsharp/FSharp.Compiler.Unittests/FSharp.Compiler.Unittests.fsproj b/src/fsharp/FSharp.Compiler.Unittests/FSharp.Compiler.Unittests.fsproj index 01d0dd44749..41c7c272831 100644 --- a/src/fsharp/FSharp.Compiler.Unittests/FSharp.Compiler.Unittests.fsproj +++ b/src/fsharp/FSharp.Compiler.Unittests/FSharp.Compiler.Unittests.fsproj @@ -12,7 +12,6 @@ true true Library - true FSharp.Compiler.Unittests false diff --git a/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj b/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj index 86d636961ac..d8fca978705 100644 --- a/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj +++ b/src/fsharp/FSharp.Compiler/FSharp.Compiler.fsproj @@ -12,8 +12,6 @@ FSharp.Compiler EXTENSIONTYPING;$(DefineConstants) COMPILER;$(DefineConstants) - INCLUDE_METADATA_READER;$(DefineConstants) - INCLUDE_METADATA_WRITER;$(DefineConstants) $(NoWarn);62;9 {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3} true @@ -493,6 +491,8 @@ CodeGen\IlxGen.fs + + Driver\CompileOps.fsi @@ -511,12 +511,52 @@ Driver\fsc.fs + + + + + Symbols/SymbolHelpers.fsi + + + Symbols/SymbolHelpers.fs + + + Symbols/Symbols.fsi + + + Symbols/Symbols.fs + + + Symbols/Exprs.fsi + + + Symbols/Exprs.fs + + + MSBuildReferenceResolver.fs + + + + FSIstrings.txt + + + InteractiveSession\console.fs + + + InteractiveSession\fsi.fsi + + + InteractiveSession\fsi.fs + + InternalsVisibleTo.fs + + LegacyHostedCompilerForTesting.fs diff --git a/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj b/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj index 95492a7e2fd..79ec5c0f39e 100644 --- a/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj +++ b/src/fsharp/FSharp.Core.Unittests/FSharp.Core.Unittests.fsproj @@ -15,7 +15,6 @@ true true Library - true FSharp.Core.Unittests false diff --git a/src/fsharp/FSharp.Core/FSharp.Core.fsproj b/src/fsharp/FSharp.Core/FSharp.Core.fsproj index 2ca43242341..38a4e9a9a8b 100644 --- a/src/fsharp/FSharp.Core/FSharp.Core.fsproj +++ b/src/fsharp/FSharp.Core/FSharp.Core.fsproj @@ -3,6 +3,7 @@ $(MSBuildProjectDirectory)\..\.. + FSharp diff --git a/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj b/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj index cddb3166ff1..2c53a546633 100644 --- a/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj +++ b/src/fsharp/FSharp.LanguageService.Compiler/FSharp.LanguageService.Compiler.fsproj @@ -12,10 +12,9 @@ FSharp.LanguageService.Compiler EXTENSIONTYPING;$(DefineConstants) COMPILER;$(DefineConstants) - COMPILED_AS_LANGUAGE_SERVICE_DLL;$(DefineConstants) - INCLUDE_METADATA_READER;$(DefineConstants) + COMPILER_SERVICE;$(DefineConstants) + COMPILER_SERVICE_DLL_VISUAL_STUDIO;$(DefineConstants) NO_INLINE_IL_PARSER;$(DefineConstants) - INCLUDE_METADATA_WRITER;$(DefineConstants) $(NoWarn);62;9;75 {a437a6ec-5323-47c2-8f86-e2cac54ff152} true @@ -493,6 +492,24 @@ Driver\fsc.fs + + Symbols/SymbolHelpers.fsi + + + Symbols/SymbolHelpers.fs + + + Symbols/Symbols.fsi + + + Symbols/Symbols.fs + + + Symbols/Exprs.fsi + + + Symbols/Exprs.fs + Service/IncrementalBuild.fsi @@ -508,17 +525,11 @@ Service/ServiceConstants.fs - - Service/ServiceDeclarations.fsi - - - Service/ServiceDeclarations.fs - - - Service/Symbols.fsi + + Service/ServiceDeclarationLists.fsi - - Service/Symbols.fs + + Service/ServiceDeclarationLists.fs Service/ServiceLexing.fsi @@ -550,6 +561,12 @@ Service/MSBuildReferenceResolver.fs + + Service/ServiceDeclarationLists.fsi + + + Service/ServiceDeclarationLists.fs + Service/ServiceAssemblyContent.fsi diff --git a/src/fsharp/IlxGen.fsi b/src/fsharp/IlxGen.fsi index 45d10b9ff6f..94cccee587f 100644 --- a/src/fsharp/IlxGen.fsi +++ b/src/fsharp/IlxGen.fsi @@ -82,3 +82,4 @@ type public IlxAssemblyGenerator = val ReportStatistics : TextWriter -> unit +val IsValCompiledAsMethod : TcGlobals -> Val -> bool diff --git a/src/fsharp/LegacyHostedCompilerForTesting.fs b/src/fsharp/LegacyHostedCompilerForTesting.fs index 7e3d44d1193..a605351d042 100644 --- a/src/fsharp/LegacyHostedCompilerForTesting.fs +++ b/src/fsharp/LegacyHostedCompilerForTesting.fs @@ -13,6 +13,7 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Driver open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library /// build issue location type internal Location = @@ -55,13 +56,16 @@ type internal CompilationOutput = type internal InProcCompiler(referenceResolver) = member this.Compile(argv) = + // Explanation: Compilation happens on whichever thread calls this function. + let ctok = AssumeCompilationThreadWithoutEvidence () + let loggerProvider = InProcErrorLoggerProvider() let exitCode = ref 0 let exiter = { new Exiter with member this.Exit n = exitCode := n; raise StopProcessing } try - typecheckAndCompile(argv, referenceResolver, false, exiter, loggerProvider.Provider) + typecheckAndCompile(ctok, argv, referenceResolver, false, false, exiter, loggerProvider.Provider, None, None) with | StopProcessing -> () | ReportedError _ | WrappedError(ReportedError _,_) -> diff --git a/src/fsharp/MSBuildReferenceResolver.fs b/src/fsharp/MSBuildReferenceResolver.fs index 04d73b6a2f9..4b8d8fe932a 100644 --- a/src/fsharp/MSBuildReferenceResolver.fs +++ b/src/fsharp/MSBuildReferenceResolver.fs @@ -67,6 +67,9 @@ module internal Microsoft.FSharp.Compiler.MSBuildReferenceResolver [] let private Net451 = "v4.5.1" + /// The list of supported .NET Framework version numbers, using the monikers of the Reference Assemblies folder. + let SupportedNetFrameworkVersions = set [ Net20; Net30; Net35; Net40; Net45; Net451; (*SL only*) "v5.0" ] + //[] //let private Net452 = "v4.5.2" // not available in Dev15 MSBuild version @@ -103,31 +106,16 @@ module internal Microsoft.FSharp.Compiler.MSBuildReferenceResolver | x -> [x] | _ -> [] - let GetPathToDotNetFrameworkReferenceAssembliesFor40Plus(version) = -#if ENABLE_MONO_SUPPORT // || !FX_RESHAPED_MSBUILD - match ToolLocationHelper.GetPathToStandardLibraries(".NETFramework",version,"") with - | null | "" -> [] - | x -> [x] + + let GetPathToDotNetFrameworkReferenceAssemblies(version) = +#if NETSTANDARD1_6 + ignore version + let r : string list = [] + r #else -// FUTURE CLEANUP: This is the old implementation, equivalent to calling GetPathToStandardLibraries -// FUTURE CLEANUP: on .NET Framework. But reshapedmsbuild.fs doesn't have an implementation of GetPathToStandardLibraries -// FUTURE CLEANUP: When we remove reshapedmsbuild.fs we can just call GetPathToStandardLibraries directly. - // starting with .Net 4.0, the runtime dirs (WindowsFramework) are never used by MSBuild RAR - let v = - match version with - | Net40 -> Some TargetDotNetFrameworkVersion.Version40 - | Net45 -> Some TargetDotNetFrameworkVersion.Version45 - | Net451 -> Some TargetDotNetFrameworkVersion.Version451 - //| Net452 -> Some TargetDotNetFrameworkVersion.Version452 // not available in Dev15 MSBuild version - | Net46 -> Some TargetDotNetFrameworkVersion.Version46 - | Net461 -> Some TargetDotNetFrameworkVersion.Version461 - | _ -> assert false; None // unknown version - some parts in the code are not synced - match v with - | Some v -> - match ToolLocationHelper.GetPathToDotNetFrameworkReferenceAssemblies v with - | null -> [] - | x -> [x] - | None -> [] + match Microsoft.Build.Utilities.ToolLocationHelper.GetPathToStandardLibraries(".NETFramework",version,"") with + | null | "" -> [] + | x -> [x] #endif /// Use MSBuild to determine the version of the highest installed framework. @@ -143,7 +131,7 @@ module internal Microsoft.FSharp.Compiler.MSBuildReferenceResolver if box (ToolLocationHelper.GetPathToDotNetFramework(TargetDotNetFrameworkVersion.Version451)) <> null then Net451 #endif elif box (ToolLocationHelper.GetPathToDotNetFramework(TargetDotNetFrameworkVersion.Version45)) <> null then Net45 - else Net45 // version is 4.0 assumed since this code is running. + else Net45 // version is 4.5 assumed since this code is running. with _ -> Net45 /// Derive the target framework directories. @@ -159,7 +147,7 @@ module internal Microsoft.FSharp.Compiler.MSBuildReferenceResolver elif targetFrameworkVersion.StartsWith(Net20, StringComparison.Ordinal) then ReplaceVariablesForLegacyFxOnWindows([@"{WindowsFramework}\v2.0.50727"]) elif targetFrameworkVersion.StartsWith(Net30, StringComparison.Ordinal) then ReplaceVariablesForLegacyFxOnWindows([@"{ReferenceAssemblies}\v3.0"; @"{WindowsFramework}\v3.0"; @"{WindowsFramework}\v2.0.50727"]) elif targetFrameworkVersion.StartsWith(Net35, StringComparison.Ordinal) then ReplaceVariablesForLegacyFxOnWindows([@"{ReferenceAssemblies}\v3.5"; @"{WindowsFramework}\v3.5"; @"{ReferenceAssemblies}\v3.0"; @"{WindowsFramework}\v3.0"; @"{WindowsFramework}\v2.0.50727"]) - else GetPathToDotNetFrameworkReferenceAssembliesFor40Plus(targetFrameworkVersion) + else GetPathToDotNetFrameworkReferenceAssemblies(targetFrameworkVersion) let result = result |> Array.ofList logMessage (sprintf "Derived target framework directories for version %s are: %s" targetFrameworkVersion (String.Join(",", result))) @@ -201,15 +189,27 @@ module internal Microsoft.FSharp.Compiler.MSBuildReferenceResolver | AssemblyFolders -> lineIfExists resolvedPath + lineIfExists fusionName +#if CROSS_PLATFORM_COMPILER + + "Found by AssemblyFolders registry key" +#else + FSComp.SR.assemblyResolutionFoundByAssemblyFoldersKey() +#endif | AssemblyFoldersEx -> lineIfExists resolvedPath + lineIfExists fusionName +#if CROSS_PLATFORM_COMPILER + + "Found by AssemblyFoldersEx registry key" +#else + FSComp.SR.assemblyResolutionFoundByAssemblyFoldersExKey() +#endif | TargetFrameworkDirectory -> lineIfExists resolvedPath + lineIfExists fusionName +#if CROSS_PLATFORM_COMPILER + + ".NET Framework" +#else + FSComp.SR.assemblyResolutionNetFramework() +#endif | Unknown -> // Unknown when resolved by plain directory search without help from MSBuild resolver. lineIfExists resolvedPath @@ -218,7 +218,11 @@ module internal Microsoft.FSharp.Compiler.MSBuildReferenceResolver lineIfExists fusionName | GlobalAssemblyCache -> lineIfExists fusionName +#if CROSS_PLATFORM_COMPILER + + "Global Assembly Cache" +#else + lineIfExists (FSComp.SR.assemblyResolutionGAC()) +#endif + lineIfExists redist | Path _ -> lineIfExists resolvedPath diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index 97e937beba8..9d45e16a393 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -804,7 +804,7 @@ let BuildNewDelegateExpr (eventInfoOpt:EventInfo option, g, amap, delegateTy, in if List.exists (isByrefTy g) delArgTys then error(Error(FSComp.SR.tcFunctionRequiresExplicitLambda(List.length delArgTys),m)) - let delArgVals = delArgTys |> List.map (fun argty -> fst (mkCompGenLocal m "delegateArg" argty)) + let delArgVals = delArgTys |> List.mapi (fun i argty -> fst (mkCompGenLocal m ("delegateArg"^string i) argty)) let expr = let args = match eventInfoOpt with diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index cc6ed05b88f..0ad469c82cb 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -1231,7 +1231,7 @@ type ITypecheckResultsSink = abstract NotifyEnvWithScope : range * NameResolutionEnv * AccessorDomain -> unit abstract NotifyExprHasType : pos * TType * Tastops.DisplayEnv * NameResolutionEnv * AccessorDomain * range -> unit abstract NotifyNameResolution : pos * Item * Item * TyparInst * ItemOccurence * Tastops.DisplayEnv * NameResolutionEnv * AccessorDomain * range * bool -> unit - abstract NotifyFormatSpecifierLocation : range -> unit + abstract NotifyFormatSpecifierLocation : range * int -> unit abstract CurrentSource : string option let (|ValRefOfProp|_|) (pi : PropInfo) = pi.ArbitraryValRef @@ -1427,23 +1427,35 @@ type TcResolutions /// Represents container for all name resolutions that were met so far when typechecking some particular file -type TcSymbolUses(g, capturedNameResolutions : ResizeArray, formatSpecifierLocations: range[]) = +type TcSymbolUses(g, capturedNameResolutions : ResizeArray, formatSpecifierLocations: (range * int)[]) = // Make sure we only capture the information we really need to report symbol uses - let cnrs = [| for cnr in capturedNameResolutions -> struct (cnr.Item, cnr.ItemOccurence, cnr.DisplayEnv, cnr.Range) |] +#if COMPILER_SERVICE_DLL // avoid a hard dependency on System.ValueTuple.dll from FSharp.Compiler.Service.dll + let cnrs = [| for cnr in capturedNameResolutions -> (* struct *) (cnr.Item, cnr.ItemOccurence, cnr.DisplayEnv, cnr.Range) |] +#else + let cnrs = [| for cnr in capturedNameResolutions -> struct (cnr.Item, cnr.ItemOccurence, cnr.DisplayEnv, cnr.Range) |] +#endif let capturedNameResolutions = () do ignore capturedNameResolutions // don't capture this! member this.GetUsesOfSymbol(item) = - [| for (struct (cnrItem,occ,denv,m)) in cnrs do +#if COMPILER_SERVICE_DLL // avoid a hard dependency on System.ValueTuple.dll from FSharp.Compiler.Service.dll + [| for ( (* struct *) (cnrItem,occ,denv,m)) in cnrs do +#else + [| for ( struct (cnrItem,occ,denv,m)) in cnrs do +#endif if protectAssemblyExploration false (fun () -> ItemsAreEffectivelyEqual g item cnrItem) then yield occ, denv, m |] member this.GetAllUsesOfSymbols() = - [| for (struct (cnrItem,occ,denv,m)) in cnrs do +#if COMPILER_SERVICE_DLL // avoid a hard dependency on System.ValueTuple.dll from FSharp.Compiler.Service.dll + [| for ( (* struct *) (cnrItem,occ,denv,m)) in cnrs do +#else + [| for ( struct (cnrItem,occ,denv,m)) in cnrs do +#endif yield (cnrItem, occ, denv, m) |] - member this.GetFormatSpecifierLocations() = formatSpecifierLocations + member this.GetFormatSpecifierLocationsAndArity() = formatSpecifierLocations /// An accumulator for the results being emitted into the tcSink. @@ -1499,8 +1511,8 @@ type TcResultsSinkImpl(g, ?source: string) = capturedNameResolutions.Add(CapturedNameResolution(endPos,item,tpinst,occurenceType,denv,nenv,ad,m)) capturedMethodGroupResolutions.Add(CapturedNameResolution(endPos,itemMethodGroup,[],occurenceType,denv,nenv,ad,m)) - member sink.NotifyFormatSpecifierLocation(m) = - capturedFormatSpecifierLocations.Add(m) + member sink.NotifyFormatSpecifierLocation(m, numArgs) = + capturedFormatSpecifierLocations.Add((m, numArgs)) member sink.CurrentSource = source @@ -4440,3 +4452,17 @@ let rec private GetCompletionForItem (ncenv: NameResolver) (nenv: NameResolution let IsItemResolvable (ncenv: NameResolver) (nenv: NameResolutionEnv) m ad plid (item: Item) : bool = GetCompletionForItem ncenv nenv m ad plid item |> Seq.exists (ItemsAreEffectivelyEqual ncenv.g item) + +let GetVisibleNamespacesAndModulesAtPoint (ncenv: NameResolver) (nenv: NameResolutionEnv) m ad = + let ilTyconNames = + nenv.TyconsByAccessNames(FullyQualifiedFlag.OpenQualified).Values + |> List.choose (fun tyconRef -> if tyconRef.IsILTycon then Some tyconRef.DisplayName else None) + |> Set.ofList + + nenv.ModulesAndNamespaces(FullyQualifiedFlag.OpenQualified) + |> NameMultiMap.range + |> List.filter (fun x -> + let demangledName = x.DemangledModuleOrNamespaceName + IsInterestingModuleName demangledName && notFakeContainerModule ilTyconNames demangledName + && EntityRefContainsSomethingAccessible ncenv m ad x + && not (IsTyconUnseen ad ncenv.g ncenv.amap m x)) diff --git a/src/fsharp/NameResolution.fsi b/src/fsharp/NameResolution.fsi index 69e397c15d0..b50fc99db76 100755 --- a/src/fsharp/NameResolution.fsi +++ b/src/fsharp/NameResolution.fsi @@ -305,7 +305,7 @@ type internal TcSymbolUses = member GetAllUsesOfSymbols : unit -> (Item * ItemOccurence * DisplayEnv * range)[] /// Get the locations of all the printf format specifiers in the file - member GetFormatSpecifierLocations : unit -> range[] + member GetFormatSpecifierLocationsAndArity : unit -> (range * int)[] /// An abstract type for reporting the results of name resolution and type checking @@ -321,7 +321,7 @@ type ITypecheckResultsSink = abstract NotifyNameResolution : pos * Item * Item * TyparInst * ItemOccurence * DisplayEnv * NameResolutionEnv * AccessorDomain * range * bool -> unit /// Record that a printf format specifier occurred at a specific location in the source - abstract NotifyFormatSpecifierLocation : range -> unit + abstract NotifyFormatSpecifierLocation : range * int -> unit /// Get the current source abstract CurrentSource : string option @@ -480,5 +480,6 @@ type ResolveCompletionTargets = /// Resolve a (possibly incomplete) long identifier to a set of possible resolutions, qualified by type. val ResolveCompletionsInType : NameResolver -> NameResolutionEnv -> ResolveCompletionTargets -> Range.range -> AccessorDomain -> bool -> TType -> Item list +val GetVisibleNamespacesAndModulesAtPoint : NameResolver -> NameResolutionEnv -> range -> AccessorDomain -> ModuleOrNamespaceRef list -val IsItemResolvable : NameResolver -> NameResolutionEnv -> range -> AccessorDomain -> string list -> Item -> bool \ No newline at end of file +val IsItemResolvable : NameResolver -> NameResolutionEnv -> range -> AccessorDomain -> string list -> Item -> bool diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 83e74cc497c..fc3024109e6 100644 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -919,7 +919,7 @@ let CompilePatternBasic if not (isNil topgtvs) then error(InternalError("Unexpected generalized type variables when compiling an active pattern",m)) let rty = apinfo.ResultType g m resTys - let v,vexp = mkCompGenLocal m "activePatternResult" rty + let v,vexp = mkCompGenLocal m ("activePatternResult"^string (newUnique())) rty if topv.IsMemberOrModuleBinding then AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData let argexp = GetSubExprOfInput subexpr diff --git a/src/fsharp/PrettyNaming.fs b/src/fsharp/PrettyNaming.fs index 3de8fcab9fe..61a6074abfe 100755 --- a/src/fsharp/PrettyNaming.fs +++ b/src/fsharp/PrettyNaming.fs @@ -5,8 +5,12 @@ //-------------------------------------------------------------------------- /// Anything to do with special names of identifiers and other lexical rules +#if COMPILER_PUBLIC_API +module Microsoft.FSharp.Compiler.PrettyNaming +#else module internal Microsoft.FSharp.Compiler.PrettyNaming - open Internal.Utilities +#endif +open Internal.Utilities open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library diff --git a/src/fsharp/SimulatedMSBuildReferenceResolver.fs b/src/fsharp/SimulatedMSBuildReferenceResolver.fs new file mode 100644 index 00000000000..3fbcf906f4a --- /dev/null +++ b/src/fsharp/SimulatedMSBuildReferenceResolver.fs @@ -0,0 +1,229 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +#if INTERACTIVE +#load "../utils/ResizeArray.fs" "../absil/illib.fs" "../fsharp/ReferenceResolver.fs" +#else +module internal Microsoft.FSharp.Compiler.SimulatedMSBuildReferenceResolver +#endif + +open System +open System.IO +open System.Reflection +open Microsoft.Win32 +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.ReferenceResolver +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library + +let internal SimulatedMSBuildResolver = + { new Resolver with + member __.HighestInstalledNetFrameworkVersion() = "v4.5" + member __.DotNetFrameworkReferenceAssembliesRootDirectory = +#if RESHAPED_MSBUILD + "" +#else + if System.Environment.OSVersion.Platform = System.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 + "" +#endif + + member __.Resolve(resolutionEnvironment, references, targetFrameworkVersion, targetFrameworkDirectories, targetProcessorArchitecture, + fsharpCoreDir, explicitIncludeDirs, implicitIncludeDir, logMessage, logWarningOrError) = + +#if !RESHAPED_MSBUILD + let registrySearchPaths() = + [ let registryKey = @"Software\Microsoft\.NetFramework"; + use key = Registry.LocalMachine.OpenSubKey(registryKey) + match key with + | null -> () + | _ -> + for subKeyName in key.GetSubKeyNames() do + use subKey = key.OpenSubKey(subKeyName) + use subSubKey = subKey.OpenSubKey("AssemblyFoldersEx") + match subSubKey with + | null -> () + | _ -> + for subSubSubKeyName in subSubKey.GetSubKeyNames() do + use subSubSubKey = subSubKey.OpenSubKey(subSubSubKeyName) + match subSubSubKey.GetValue(null) with + | :? string as s -> yield s + | _ -> () + use subSubKey = key.OpenSubKey("AssemblyFolders") + match subSubKey with + | null -> () + | _ -> + for subSubSubKeyName in subSubKey.GetSubKeyNames() do + let subSubSubKey = subSubKey.OpenSubKey(subSubSubKeyName) + match subSubSubKey.GetValue(null) with + | :? string as s -> yield s + | _ -> () ] +#endif + + let results = ResizeArray() + let searchPaths = + [ yield! targetFrameworkDirectories + yield! explicitIncludeDirs + yield fsharpCoreDir + yield implicitIncludeDir +#if !RESHAPED_MSBUILD + if System.Environment.OSVersion.Platform = System.PlatformID.Win32NT then + yield! registrySearchPaths() +#endif + ] + + 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 && Path.IsPathRooted(r) then + if FileSystem.SafeExists(r) then + success r + with e -> logWarningOrError false "SR001" (e.ToString()) + +#if !RESHAPED_MSBUILD + // For this one we need to get the version search exactly right, without doing a load + try + if not found && r.StartsWith("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.SafeExists(trialPath) then + success trialPath + with e -> logWarningOrError false "SR001" (e.ToString()) +#endif + + let isFileName = + r.EndsWith("dll",StringComparison.OrdinalIgnoreCase) || + r.EndsWith("exe",StringComparison.OrdinalIgnoreCase) + + let qual = if isFileName then r else try AssemblyName(r).Name + ".dll" with _ -> r + ".dll" + + for searchPath in searchPaths do + try + if not found then + let trialPath = Path.Combine(searchPath,qual) + if FileSystem.SafeExists(trialPath) then + success trialPath + with e -> logWarningOrError false "SR001" (e.ToString()) + +#if !RESHAPED_MSBUILD + try + // Seach 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 = + [ for gacdir in Directory.EnumerateDirectories(gac) do + let assdir = Path.Combine(gacdir,n.Name) + if Directory.Exists(assdir) then + for tdir in Directory.EnumerateDirectories(assdir) do + let trialPath = Path.Combine(tdir,qual) + if FileSystem.SafeExists(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 -> + for gacdir in Directory.EnumerateDirectories(gac) do + //printfn "searching GAC directory: %s" gacdir + let assdir = Path.Combine(gacdir,n.Name) + if Directory.Exists(assdir) then + //printfn "searching GAC directory: %s" assdir + + let tokText = String.concat "" [| for b in tok -> sprintf "%02x" b |] + let verdir = Path.Combine(assdir,"v4.0_"+v.ToString()+"__"+tokText) + //printfn "searching GAC directory: %s" verdir + + if Directory.Exists(verdir) then + let trialPath = Path.Combine(verdir,qual) + //printfn "searching GAC: %s" trialPath + if FileSystem.SafeExists(trialPath) then + success trialPath + with e -> logWarningOrError false "SR001" (e.ToString()) +#endif + + results.ToArray() } + +let internal GetBestAvailableResolver(msbuildEnabled: bool) = +#if RESHAPED_MSBUILD + ignore msbuildEnabled +#else + let tryMSBuild v = + // Detect if MSBuild is on the machine, if so use the resolver from there + let mb = try Assembly.Load(sprintf "Microsoft.Build.Framework, Version=%s.0.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" v) |> Option.ofObj with _ -> None + let ass = mb |> Option.bind (fun _ -> try Assembly.Load(sprintf "FSharp.Compiler.Service.MSBuild.v%s" v) |> Option.ofObj with _ -> None) + let ty = ass |> Option.bind (fun ass -> ass.GetType("Microsoft.FSharp.Compiler.MSBuildReferenceResolver") |> Option.ofObj) + let obj = ty |> Option.bind (fun ty -> ty.InvokeMember("get_Resolver",BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.InvokeMethod ||| BindingFlags.NonPublic, null, null, [| |]) |> Option.ofObj) + let resolver = obj |> Option.bind (fun obj -> match obj with :? Resolver as r -> Some r | _ -> None) + resolver + match (if msbuildEnabled then tryMSBuild "12" else None) with + | Some r -> r + | None -> +#endif + 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.CompileTimeLike,[| 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 [ "Microsoft.SharePoint.Client, Version=16.0.0.0, Culture=neutral, PublicKeyToken=71e9bce111e9429c" ] +#endif + diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index 05a1120d65f..af745c40bd9 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -90,7 +90,6 @@ type InputTable<'T> = let new_itbl n r = { itbl_name=n; itbl_rows=r } -#if INCLUDE_METADATA_WRITER [] type NodeOutTable<'Data,'Node> = { NodeStamp : ('Node -> Stamp) @@ -126,8 +125,6 @@ type WriterState = ofile : string; } let pfailwith st str = ffailwith st.ofile str - -#endif [] type NodeInTable<'Data,'Node> = @@ -163,8 +160,6 @@ let ufailwith st str = ffailwith st.ifile str // Basic pickle/unpickle operations //--------------------------------------------------------------------------- -#if INCLUDE_METADATA_WRITER - type 'T pickler = 'T -> WriterState -> unit let p_byte b st = st.os.EmitIntAsByte b @@ -239,8 +234,6 @@ let inline p_tup15 p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 (a,b,c,d, let inline p_tup16 p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16 (a,b,c,d,e,f,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16) (st:WriterState) = (p1 a st : unit); (p2 b st : unit); (p3 c st : unit); (p4 d st : unit); (p5 e st : unit); (p6 f st : unit); (p7 x7 st : unit); (p8 x8 st : unit); (p9 x9 st : unit); (p10 x10 st : unit); (p11 x11 st : unit); (p12 x12 st : unit); (p13 x13 st : unit) ; (p14 x14 st : unit); (p15 x15 st : unit); (p16 x16 st : unit) let inline p_tup17 p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16 p17 (a,b,c,d,e,f,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17) (st:WriterState) = (p1 a st : unit); (p2 b st : unit); (p3 c st : unit); (p4 d st : unit); (p5 e st : unit); (p6 f st : unit); (p7 x7 st : unit); (p8 x8 st : unit); (p9 x9 st : unit); (p10 x10 st : unit); (p11 x11 st : unit); (p12 x12 st : unit); (p13 x13 st : unit) ; (p14 x14 st : unit); (p15 x15 st : unit); (p16 x16 st : unit); (p17 x17 st : unit) -#endif - let u_byte st = int (st.is.ReadByte()) type unpickler<'T> = ReaderState -> 'T @@ -375,7 +368,6 @@ let inline u_tup17 p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16 p17 (s // exception Nope // ctxt is for debugging -#if INCLUDE_METADATA_WRITER let p_osgn_ref (_ctxt:string) (outMap : NodeOutTable<_,_>) x st = let idx = outMap.Table.FindOrAdd (outMap.NodeStamp x) //if ((idx = 0) && outMap.Name = "otycons") then @@ -387,7 +379,6 @@ let p_osgn_decl (outMap : NodeOutTable<_,_>) p x st = let idx = outMap.Table.FindOrAdd stamp //dprintf "decl %d#%d in table %s has name %s\n" idx (outMap.NodeStamp x) outMap.Name (outMap.NodeName x); p_tup2 p_int p (idx,outMap.Deref x) st -#endif let u_osgn_ref (inMap: NodeInTable<_,_>) st = let n = u_int st @@ -416,7 +407,6 @@ let lookup_uniq st tbl n = // between internal representations relatively easily //------------------------------------------------------------------------- -#if INCLUDE_METADATA_WRITER let p_array f (x: 'T[]) st = p_int x.Length st; for i = 0 to x.Length-1 do @@ -482,9 +472,6 @@ let p_hole () = let h = ref (None : 'T pickler option) (fun f -> h := Some f),(fun x st -> match !h with Some f -> f x st | None -> pfailwith st "p_hole: unfilled hole") - -#endif - let u_array f st = let n = u_int st let res = Array.zeroCreate n @@ -585,12 +572,10 @@ let u_strings = u_list u_string let u_ints = u_list u_int -#if INCLUDE_METADATA_WRITER let p_encoded_string = p_prim_string let p_string s st = p_int (encode_string st.ostrings s) st let p_strings = p_list p_string let p_ints = p_list p_int -#endif // CCU References // A huge number of these occur in pickled F# data, so make them unique @@ -603,13 +588,11 @@ let u_encoded_ccuref st = | n -> ufailwith st ("u_encoded_ccuref: found number " + string n) let u_ccuref st = lookup_uniq st st.iccus (u_int st) -#if INCLUDE_METADATA_WRITER let p_encoded_ccuref x st = p_byte 0 st // leave a dummy tag to make room for future encodings of ccurefs p_prim_string x st let p_ccuref s st = p_int (encode_ccuref st.occus s) st -#endif // References to public items in this module // A huge number of these occur in pickled F# data, so make them unique @@ -618,11 +601,9 @@ let lookup_pubpath st pubpathTab x = lookup_uniq st pubpathTab x let u_encoded_pubpath = u_array u_int let u_pubpath st = lookup_uniq st st.ipubpaths (u_int st) -#if INCLUDE_METADATA_WRITER let encode_pubpath stringTab pubpathTab (PubPath(a)) = encode_uniq pubpathTab (Array.map (encode_string stringTab) a) let p_encoded_pubpath = p_array p_int let p_pubpath x st = p_int (encode_pubpath st.ostrings st.opubpaths x) st -#endif // References to other modules // A huge number of these occur in pickled F# data, so make them unique @@ -631,7 +612,6 @@ let lookup_nleref st nlerefTab x = lookup_uniq st nlerefTab x let u_encoded_nleref = u_tup2 u_int (u_array u_int) let u_nleref st = lookup_uniq st st.inlerefs (u_int st) -#if INCLUDE_METADATA_WRITER let encode_nleref ccuTab stringTab nlerefTab thisCcu (nleref: NonLocalEntityRef) = #if EXTENSIONTYPING // Remap references to statically-linked Entity nodes in provider-generated entities to point to the current assembly. @@ -650,7 +630,6 @@ let encode_nleref ccuTab stringTab nlerefTab thisCcu (nleref: NonLocalEntityRef) encode_uniq nlerefTab (encode_ccuref ccuTab a, Array.map (encode_string stringTab) b) let p_encoded_nleref = p_tup2 p_int (p_array p_int) let p_nleref x st = p_int (encode_nleref st.occus st.ostrings st.onlerefs st.oscope x) st -#endif // Simple types are types like "int", represented as TType(Ref_nonlocal(...,"int"),[]). // A huge number of these occur in pickled F# data, so make them unique. @@ -658,14 +637,11 @@ let decode_simpletyp st _ccuTab _stringTab nlerefTab a = TType_app(ERefNonLocal let lookup_simpletyp st simpletypTab x = lookup_uniq st simpletypTab x let u_encoded_simpletyp st = u_int st let u_simpletyp st = lookup_uniq st st.isimpletyps (u_int st) -#if INCLUDE_METADATA_WRITER let encode_simpletyp ccuTab stringTab nlerefTab simpletypTab thisCcu a = encode_uniq simpletypTab (encode_nleref ccuTab stringTab nlerefTab thisCcu a) let p_encoded_simpletyp x st = p_int x st let p_simpletyp x st = p_int (encode_simpletyp st.occus st.ostrings st.onlerefs st.osimpletyps st.oscope x) st -#endif type sizes = int * int * int -#if INCLUDE_METADATA_WRITER let pickleObjWithDanglingCcus file g scope p x = let ccuNameTab,(sizes: sizes),stringTab,pubpathTab,nlerefTab,simpletypTab,phase1bytes = let st1 = @@ -715,8 +691,6 @@ let pickleObjWithDanglingCcus file g scope p x = st2.os.Close() phase2bytes -#endif - let check (ilscope:ILScopeRef) (inMap : NodeInTable<_,_>) = for i = 0 to inMap.Count - 1 do let n = inMap.Get i @@ -788,7 +762,6 @@ let unpickleObjWithDanglingCcus file ilscope (iILModule:ILModuleDef option) u (p // Pickle/unpickle for Abstract IL data, up to IL instructions //--------------------------------------------------------------------------- -#if INCLUDE_METADATA_WRITER let p_ILPublicKey x st = match x with | PublicKey b -> p_byte 0 st; p_bytes b st @@ -807,7 +780,6 @@ let p_ILScopeRef x st = | ILScopeRef.Local -> p_byte 0 st | ILScopeRef.Module mref -> p_byte 1 st; p_ILModuleRef mref st | ILScopeRef.Assembly aref -> p_byte 2 st; p_ILAssemblyRef aref st -#endif let u_ILPublicKey st = let tag = u_byte st @@ -844,7 +816,6 @@ let u_ILScopeRef st = let res = rescopeILScopeRef st.iilscope res res -#if INCLUDE_METADATA_WRITER let p_ILHasThis x st = p_byte (match x with | ILThisConvention.Instance -> 0 @@ -883,7 +854,6 @@ and p_ILCallSig x st = p_tup3 p_ILCallConv p_ILTypes p_ILType (x.CallingConv,x.A and p_ILTypeRef (x:ILTypeRef) st = p_tup3 p_ILScopeRef p_strings p_string (x.Scope,x.Enclosing,x.Name) st and p_ILTypeSpec (a:ILTypeSpec) st = p_tup2 p_ILTypeRef p_ILTypes (a.TypeRef,a.GenericArgs) st -#endif let u_ILBasicCallConv st = match u_byte st with @@ -925,7 +895,6 @@ and u_ILCallSig = u_wrap (fun (a,b,c) -> {CallingConv=a; ArgTypes=b; ReturnType= and u_ILTypeSpec st = let a,b = u_tup2 u_ILTypeRef u_ILTypes st in ILTypeSpec.Create(a,b) -#if INCLUDE_METADATA_WRITER let p_ILMethodRef (x: ILMethodRef) st = p_tup6 p_ILTypeRef p_ILCallConv p_int p_string p_ILTypes p_ILType (x.EnclosingTypeRef,x.CallingConv,x.GenericArity,x.Name,x.ArgTypes,x.ReturnType) st let p_ILFieldRef (x: ILFieldRef) st = p_tup3 p_ILTypeRef p_string p_ILType (x.EnclosingTypeRef, x.Name, x.Type) st @@ -954,8 +923,6 @@ let p_ILBasicType x st = let p_ILVolatility x st = p_int (match x with Volatile -> 0 | Nonvolatile -> 1) st let p_ILReadonly x st = p_int (match x with ReadonlyAddress -> 0 | NormalAddress -> 1) st -#endif - let u_ILMethodRef st = let x1,x2,x3,x4,x5,x6 = u_tup6 u_ILTypeRef u_ILCallConv u_int u_string u_ILTypes u_ILType st ILMethodRef.Create(x1,x2,x4,x3,x5,x6) @@ -1147,8 +1114,6 @@ let decode_tab = List.iter (fun (icode,mk) -> add_instr (icode,(fun _ -> mk))) simple_instrs; tab -#if INCLUDE_METADATA_WRITER - let p_ILInstr x st = match x with | si when isNoArgInstr si -> p_byte (encode_instr si) st @@ -1186,7 +1151,6 @@ let p_ILInstr x st = | I_initobj c -> p_byte itag_initobj st; p_ILType c st | I_cpobj c -> p_byte itag_cpobj st; p_ILType c st | i -> pfailwith st (sprintf "the IL instruction '%+A' cannot be emitted" i) -#endif let u_ILInstr st = let n = u_byte st @@ -1198,25 +1162,21 @@ let u_ILInstr st = // Pickle/unpickle for F# types and module signatures //--------------------------------------------------------------------------- -#if INCLUDE_METADATA_WRITER // TODO: remove all pickling of maps let p_Map pk pv = p_wrap Map.toList (p_list (p_tup2 pk pv)) let p_qlist pv = p_wrap QueueList.toList (p_list pv) let p_namemap p = p_Map p_string p -#endif // TODO: remove all pickling of maps let u_Map uk uv = u_wrap Map.ofList (u_list (u_tup2 uk uv)) let u_qlist uv = u_wrap QueueList.ofList (u_list uv) let u_namemap u = u_Map u_string u -#if INCLUDE_METADATA_WRITER let p_pos (x: pos) st = p_tup2 p_int p_int (x.Line,x.Column) st let p_range (x: range) st = p_tup3 p_string p_pos p_pos (x.FileName, x.Start, x.End) st let p_dummy_range : range pickler = fun _x _st -> () let p_ident (x: Ident) st = p_tup2 p_string p_range (x.idText,x.idRange) st let p_xmldoc (XmlDoc x) st = p_array p_string x st -#endif let u_pos st = let a = u_int st in let b = u_int st in mkPos a b let u_range st = let a = u_string st in let b = u_pos st in let c = u_pos st in mkRange a b c @@ -1227,7 +1187,6 @@ let u_ident st = let a = u_string st in let b = u_range st in ident(a,b) let u_xmldoc st = XmlDoc (u_array u_string st) -#if INCLUDE_METADATA_WRITER let p_local_item_ref ctxt tab st = p_osgn_ref ctxt tab st let p_tcref ctxt (x:EntityRef) st = @@ -1239,8 +1198,6 @@ let p_ucref (UCRef(a,b)) st = p_tup2 (p_tcref "ucref") p_string (a,b) st let p_rfref (RFRef(a,b)) st = p_tup2 (p_tcref "rfref") p_string (a,b) st let p_tpref x st = p_local_item_ref "typar" st.otypars x st -#endif - let u_local_item_ref tab st = u_osgn_ref tab st let u_tcref st = @@ -1256,8 +1213,6 @@ let u_rfref st = let a,b = u_tup2 u_tcref u_string st in RFRef(a,b) let u_tpref st = u_local_item_ref st.itypars st - -#if INCLUDE_METADATA_WRITER // forward reference let fill_p_typ,p_typ = p_hole() let p_typs = (p_list p_typ) @@ -1281,7 +1236,6 @@ let rec p_vref ctxt x st = | VRefNonLocal x -> p_byte 1 st; p_nonlocal_val_ref x st let p_vrefs ctxt = p_list (p_vref ctxt) -#endif let fill_u_typ,u_typ = u_hole() let u_typs = (u_list u_typ) @@ -1306,9 +1260,6 @@ let u_vref st = let u_vrefs = u_list u_vref - - -#if INCLUDE_METADATA_WRITER let p_kind x st = p_byte (match x with | TyparKind.Type -> 0 @@ -1322,8 +1273,6 @@ let p_member_kind x st = | MemberKind.Constructor -> 3 | MemberKind.ClassConstructor -> 4 | MemberKind.PropertyGetSet -> pfailwith st "pickling: MemberKind.PropertyGetSet only expected in parse trees") st -#endif - let u_kind st = match u_byte st with @@ -1340,7 +1289,6 @@ let u_member_kind st = | 4 -> MemberKind.ClassConstructor | _ -> ufailwith st "u_member_kind" -#if INCLUDE_METADATA_WRITER let p_MemberFlags x st = p_tup6 p_bool p_bool p_bool p_bool p_bool p_member_kind (x.IsInstance, @@ -1349,7 +1297,6 @@ let p_MemberFlags x st = x.IsOverrideOrExplicitImpl, x.IsFinal, x.MemberKind) st -#endif let u_MemberFlags st = let x2,_x3UnusedBoolInFormat,x4,x5,x6,x7 = u_tup6 u_bool u_bool u_bool u_bool u_bool u_member_kind st { IsInstance=x2; @@ -1359,7 +1306,6 @@ let u_MemberFlags st = MemberKind=x7} let fill_u_Expr_hole,u_expr_fwd = u_hole() -#if INCLUDE_METADATA_WRITER let fill_p_Expr_hole,p_expr_fwd = p_hole() let p_trait_sln sln st = @@ -1377,7 +1323,6 @@ let p_trait_sln sln st = let p_trait (TTrait(a,b,c,d,e,f)) st = p_tup6 p_typs p_string p_MemberFlags p_typs (p_option p_typ) (p_option p_trait_sln) (a,b,c,d,e,!f) st -#endif // We have to store trait solutions since they can occur in optimization data let u_trait_sln st = @@ -1402,7 +1347,6 @@ let u_trait st = let a,b,c,d,e,f = u_tup6 u_typs u_string u_MemberFlags u_typs (u_option u_typ) (u_option u_trait_sln) st TTrait (a,b,c,d,e,ref f) -#if INCLUDE_METADATA_WRITER let p_rational q st = p_int32 (GetNumerator q) st; p_int32 (GetDenominator q) st @@ -1457,8 +1401,6 @@ let rec p_normalized_measure unt st = // See https://github.com/Microsoft/visualfsharp/issues/69 let p_measure_expr unt st = p_normalized_measure (normalizeMeasure st.oglobals unt) st -#endif - let u_rational st = let a,b = u_tup2 u_int32 u_int32 st in DivRational (intToRational a) (intToRational b) @@ -1473,7 +1415,6 @@ let rec u_measure_expr st = | 5 -> let a = u_measure_expr st in let b = u_rational st in Measure.RationalPower (a,b) | _ -> ufailwith st "u_measure_expr" -#if INCLUDE_METADATA_WRITER let p_typar_constraint x st = match x with | TyparConstraint.CoercesTo (a,_) -> p_byte 0 st; p_typ a st @@ -1490,7 +1431,6 @@ let p_typar_constraint x st = | TyparConstraint.SupportsEquality _ -> p_byte 11 st | TyparConstraint.IsUnmanaged _ -> p_byte 12 st let p_typar_constraints = (p_list p_typar_constraint) -#endif let u_typar_constraint st = let tag = u_byte st @@ -1514,7 +1454,6 @@ let u_typar_constraint st = let u_typar_constraints = (u_list_revi u_typar_constraint) -#if INCLUDE_METADATA_WRITER let p_typar_spec_data (x:Typar) st = p_tup5 p_ident @@ -1531,7 +1470,6 @@ let p_typar_spec (x:Typar) st = p_osgn_decl st.otypars p_typar_spec_data x st let p_typar_specs = (p_list p_typar_spec) -#endif let u_typar_spec_data st = let a,c,d,e,g = u_tup5 u_ident u_attribs u_int64 u_typar_constraints u_xmldoc st @@ -1550,8 +1488,6 @@ let u_typar_spec st = let u_typar_specs = (u_list u_typar_spec) - -#if INCLUDE_METADATA_WRITER let _ = fill_p_typ (fun ty st -> let ty = stripTyparEqns ty match ty with @@ -1568,8 +1504,6 @@ let _ = fill_p_typ (fun ty st -> | TType_measure unt -> p_byte 6 st; p_measure_expr unt st | TType_ucase (uc,tinst) -> p_byte 7 st; p_tup2 p_ucref p_typs (uc,tinst) st) -#endif - let _ = fill_u_typ (fun st -> let tag = u_byte st match tag with @@ -1585,13 +1519,11 @@ let _ = fill_u_typ (fun st -> | _ -> ufailwith st "u_typ") -#if INCLUDE_METADATA_WRITER let fill_p_binds,p_binds = p_hole() let fill_p_targets,p_targets = p_hole() let fill_p_Exprs,p_Exprs = p_hole() let fill_p_constraints,p_constraints = p_hole() let fill_p_Vals,p_Vals = p_hole() -#endif let fill_u_binds,u_binds = u_hole() let fill_u_targets,u_targets = u_hole() @@ -1599,7 +1531,6 @@ let fill_u_Exprs,u_Exprs = u_hole() let fill_u_constraints,u_constraints = u_hole() let fill_u_Vals,u_Vals = u_hole() -#if INCLUDE_METADATA_WRITER let p_ArgReprInfo (x:ArgReprInfo) st = p_attribs x.Attribs st; p_option p_ident x.Name st @@ -1612,7 +1543,6 @@ let p_ValReprInfo (ValReprInfo (a,args,ret)) st = p_list p_TyparReprInfo a st; p_list (p_list p_ArgReprInfo) args st; p_ArgReprInfo ret st -#endif let u_ArgReprInfo st = let a = u_attribs st @@ -1632,7 +1562,6 @@ let u_ValReprInfo st = let c = u_ArgReprInfo st ValReprInfo (a,b,c) -#if INCLUDE_METADATA_WRITER let p_ranges x st = p_option (p_tup2 p_range p_range) x st @@ -1645,8 +1574,6 @@ let p_istype x st = let p_cpath (CompPath(a,b)) st = p_tup2 p_ILScopeRef (p_list (p_tup2 p_string p_istype)) (a,b) st -#endif - let u_ranges st = u_option (u_tup2 u_range u_range) st let u_istype st = @@ -1661,7 +1588,6 @@ let u_cpath st = let a,b = u_tup2 u_ILScopeRef (u_list (u_tup2 u_string u_istyp let rec dummy x = x -#if INCLUDE_METADATA_WRITER and p_tycon_repr x st = // The leading "p_byte 1" and "p_byte 0" come from the F# 2.0 format, which used an option value at this point. match x with @@ -1858,9 +1784,6 @@ and p_modul_typ (x: ModuleOrNamespaceType) st = (x.ModuleOrNamespaceKind,x.AllValsAndMembers,x.AllEntities) st -#endif - - and u_tycon_repr st = let tag1 = u_byte st match tag1 with @@ -2167,7 +2090,6 @@ and u_modul_typ st = // Pickle/unpickle for F# expressions (for optimization data) //--------------------------------------------------------------------------- -#if INCLUDE_METADATA_WRITER and p_const x st = match x with | Const.Bool x -> p_byte 0 st; p_bool x st @@ -2188,7 +2110,6 @@ and p_const x st = | Const.Unit -> p_byte 15 st | Const.Zero -> p_byte 16 st | Const.Decimal s -> p_byte 17 st; p_array p_int32 (System.Decimal.GetBits(s)) st -#endif and u_const st = let tag = u_byte st @@ -2214,7 +2135,6 @@ and u_const st = | _ -> ufailwith st "u_const" -#if INCLUDE_METADATA_WRITER and p_dtree x st = match x with | TDSwitch (a,b,c,d) -> p_byte 0 st; p_tup4 p_expr (p_list p_dtree_case) (p_option p_dtree) p_dummy_range (a,b,c,d) st @@ -2243,8 +2163,6 @@ and p_recdInfo x st = | RecdExpr -> () | RecdExprIsObjInit -> pfailwith st "explicit object constructors can't be inlined and should not have optimization information" - -#endif and u_dtree st = let tag = u_byte st match tag with @@ -2278,7 +2196,6 @@ and u_lval_op_kind st = | _ -> ufailwith st "uval_op_kind" -#if INCLUDE_METADATA_WRITER and p_op x st = match x with | TOp.UnionCase c -> p_byte 0 st; p_ucref c st @@ -2322,7 +2239,6 @@ and p_op x st = // Note tag byte 29 is taken for struct tuples, see above // Note tag byte 30 is taken for struct tuples, see above | TOp.Goto _ | TOp.Label _ | TOp.Return -> failwith "unexpected backend construct in pickled TAST" -#endif and u_op st = let tag = u_byte st @@ -2390,7 +2306,6 @@ and u_op st = TOp.TupleFieldGet (tupInfoStruct, a) | _ -> ufailwith st "u_op" -#if INCLUDE_METADATA_WRITER and p_expr expr st = match expr with | Expr.Link e -> p_expr !e st @@ -2408,7 +2323,6 @@ and p_expr expr st = | Expr.StaticOptimization(a,b,c,d) -> p_byte 11 st; p_tup4 p_constraints p_expr p_expr p_dummy_range (a,b,c,d) st | Expr.TyChoose (a,b,c) -> p_byte 12 st; p_tup3 p_typar_specs p_expr p_dummy_range (a,b,c) st | Expr.Quote(ast,_,_,m,ty) -> p_byte 13 st; p_tup3 p_expr p_dummy_range p_typ (ast,m,ty) st -#endif and u_expr st = let tag = u_byte st @@ -2485,7 +2399,6 @@ and u_expr st = Expr.Quote (b,ref None,false,c,d) // isFromQueryExpression=false | _ -> ufailwith st "u_expr" -#if INCLUDE_METADATA_WRITER and p_static_optimization_constraint x st = match x with | TTyconEqualsTycon (a,b) -> p_byte 0 st; p_tup2 p_typ p_typ (a,b) st @@ -2497,7 +2410,6 @@ and p_method (TObjExprMethod (a,b,c,d,e,f)) st = p_tup6 p_slotsig p_attribs p_ty and p_methods x st = p_list p_method x st and p_intf x st = p_tup2 p_typ p_methods x st and p_intfs x st = p_list p_intf x st -#endif and u_static_optimization_constraint st = let tag = u_byte st @@ -2524,7 +2436,6 @@ and u_intf st = u_tup2 u_typ u_methods st and u_intfs st = u_list u_intf st -#if INCLUDE_METADATA_WRITER let _ = fill_p_binds (p_List p_bind) let _ = fill_p_targets (p_array p_target) let _ = fill_p_constraints (p_list p_static_optimization_constraint) @@ -2533,7 +2444,6 @@ let _ = fill_p_Expr_hole p_expr let _ = fill_p_Exprs (p_List p_expr) let _ = fill_p_attribs (p_list p_attrib) let _ = fill_p_Vals (p_list p_Val) -#endif let _ = fill_u_binds (u_List u_bind) let _ = fill_u_targets (u_array u_target) @@ -2547,11 +2457,9 @@ let _ = fill_u_Vals (u_list u_Val) // Pickle/unpickle F# interface data //--------------------------------------------------------------------------- -#if INCLUDE_METADATA_WRITER let pickleModuleOrNamespace mspec st = p_tycon_spec mspec st let pickleCcuInfo minfo st = p_tup4 pickleModuleOrNamespace p_string p_bool (p_space 3) (minfo.mspec, minfo.compileTimeWorkingDir, minfo.usesQuotations,()) st -#endif let unpickleModuleOrNamespace st = u_tycon_spec st diff --git a/src/fsharp/TastPickle.fsi b/src/fsharp/TastPickle.fsi index e8dc0ddbd97..ec4acc1c0fa 100644 --- a/src/fsharp/TastPickle.fsi +++ b/src/fsharp/TastPickle.fsi @@ -24,7 +24,6 @@ type PickledDataWithReferences<'RawData> = /// Like Fixup but loader may return None, in which case there is no fixup. member OptionalFixup: (CcuReference -> CcuThunk option) -> 'RawData -#if INCLUDE_METADATA_WRITER /// The type of state written to by picklers type WriterState @@ -84,7 +83,6 @@ val internal pickleCcuInfo : pickler /// Serialize an arbitrary object using the given pickler val pickleObjWithDanglingCcus : string -> TcGlobals -> scope:CcuThunk -> pickler<'T> -> 'T -> byte[] -#endif /// The type of state unpicklers read from type ReaderState diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 621b0d36600..378d12c27c4 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -1831,7 +1831,7 @@ let MakeAndPublishSimpleVals cenv env m names mergeNamesInOneNameresEnv = if not m.IsSynthetic then nameResolutions.Add(pos, item, itemGroup, itemTyparInst, occurence, denv, nenv, ad, m, replacing) member this.NotifyExprHasType(_, _, _, _, _, _) = assert false // no expr typings in MakeSimpleVals - member this.NotifyFormatSpecifierLocation _ = () + member this.NotifyFormatSpecifierLocation(_, _) = () member this.CurrentSource = None } use _h = WithNewTypecheckResultsSink(sink, cenv.tcSink) @@ -6679,8 +6679,8 @@ and TcConstStringExpr cenv overallTy env m tpenv s = match cenv.tcSink.CurrentSink with | None -> () | Some sink -> - for specifierLocation in specifierLocations do - sink.NotifyFormatSpecifierLocation specifierLocation + for specifierLocation,numArgs in specifierLocations do + sink.NotifyFormatSpecifierLocation(specifierLocation, numArgs) UnifyTypes cenv env m aty aty' UnifyTypes cenv env m ety ety' diff --git a/src/fsharp/ast.fs b/src/fsharp/ast.fs index ae4984cc055..de9be576dc1 100644 --- a/src/fsharp/ast.fs +++ b/src/fsharp/ast.fs @@ -1,6 +1,10 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. +#if COMPILER_PUBLIC_API +module Microsoft.FSharp.Compiler.Ast +#else module internal Microsoft.FSharp.Compiler.Ast +#endif open System.Collections.Generic open Internal.Utilities @@ -2149,35 +2153,35 @@ and LexCont = LexerWhitespaceContinuation exception SyntaxError of obj (* ParseErrorContext<_> *) * range:range /// Get an F# compiler position from a lexer position -let posOfLexPosition (p:Position) = +let internal posOfLexPosition (p:Position) = mkPos p.Line p.Column /// Get an F# compiler range from a lexer range -let mkSynRange (p1:Position) (p2: Position) = +let internal mkSynRange (p1:Position) (p2: Position) = mkFileIndexRange p1.FileIndex (posOfLexPosition p1) (posOfLexPosition p2) type LexBuffer<'Char> with - member lexbuf.LexemeRange = mkSynRange lexbuf.StartPos lexbuf.EndPos + member internal lexbuf.LexemeRange = mkSynRange lexbuf.StartPos lexbuf.EndPos /// Get the range corresponding to the result of a grammar rule while it is being reduced -let lhs (parseState: IParseState) = +let internal lhs (parseState: IParseState) = let p1 = parseState.ResultStartPosition let p2 = parseState.ResultEndPosition mkSynRange p1 p2 /// Get the range covering two of the r.h.s. symbols of a grammar rule while it is being reduced -let rhs2 (parseState: IParseState) i j = +let internal rhs2 (parseState: IParseState) i j = let p1 = parseState.InputStartPosition i let p2 = parseState.InputEndPosition j mkSynRange p1 p2 /// Get the range corresponding to one of the r.h.s. symbols of a grammar rule while it is being reduced -let rhs parseState i = rhs2 parseState i i +let internal rhs parseState i = rhs2 parseState i i type IParseState with /// Get the generator used for compiler-generated argument names. - member x.SynArgNameGenerator = + member internal x.SynArgNameGenerator = let key = "SynArgNameGenerator" let bls = x.LexBuffer.BufferLocalStore if not (bls.ContainsKey key) then @@ -2185,7 +2189,7 @@ type IParseState with bls.[key] :?> SynArgNameGenerator /// Reset the generator used for compiler-generated argument names. - member x.ResetSynArgNameGenerator() = x.SynArgNameGenerator.Reset() + member internal x.ResetSynArgNameGenerator() = x.SynArgNameGenerator.Reset() /// XmlDoc F# lexer/parser state, held in the BufferLocalStore for the lexer. @@ -2194,20 +2198,20 @@ module LexbufLocalXmlDocStore = // The key into the BufferLocalStore used to hold the current accumulated XmlDoc lines let private xmlDocKey = "XmlDoc" - let ClearXmlDoc (lexbuf:Lexbuf) = + let internal ClearXmlDoc (lexbuf:Lexbuf) = lexbuf.BufferLocalStore.[xmlDocKey] <- box (XmlDocCollector()) /// Called from the lexer to save a single line of XML doc comment. - let SaveXmlDocLine (lexbuf:Lexbuf, lineText, pos) = - if not (lexbuf.BufferLocalStore.ContainsKey(xmlDocKey)) then + let internal SaveXmlDocLine (lexbuf:Lexbuf, lineText, pos) = + if not (lexbuf.BufferLocalStore.ContainsKey(xmlDocKey)) then lexbuf.BufferLocalStore.[xmlDocKey] <- box (XmlDocCollector()) let collector = unbox(lexbuf.BufferLocalStore.[xmlDocKey]) collector.AddXmlDocLine (lineText, pos) /// Called from the parser each time we parse a construct that marks the end of an XML doc comment range, /// e.g. a 'type' declaration. The markerRange is the range of the keyword that delimits the construct. - let GrabXmlDocBeforeMarker (lexbuf:Lexbuf, markerRange:range) = - if lexbuf.BufferLocalStore.ContainsKey(xmlDocKey) then + let internal GrabXmlDocBeforeMarker (lexbuf:Lexbuf, markerRange:range) = + if lexbuf.BufferLocalStore.ContainsKey(xmlDocKey) then PreXmlDoc.CreateFromGrabPoint(unbox(lexbuf.BufferLocalStore.[xmlDocKey]),markerRange.End) else PreXmlDoc.Empty diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs index df2acd7bf9c..0c8420f09cd 100644 --- a/src/fsharp/fsc.fs +++ b/src/fsharp/fsc.fs @@ -1564,6 +1564,13 @@ let ValidateKeySigningAttributes (tcConfig : TcConfig, tcGlobals, topAttrs) = StrongNameSigningInfo (delaysign, tcConfig.publicsign, signer, container) +/// Checks if specified file name is absolute path. If yes - returns the name as is, otherwise makes full path using tcConfig.implicitIncludeDir as base. +let expandFileNameIfNeeded (tcConfig : TcConfig) name = + if FileSystem.IsPathRootedShim name then + name + else + Path.Combine(tcConfig.implicitIncludeDir, name) + let GetStrongNameSigner signingInfo = let (StrongNameSigningInfo(delaysign, publicsign, signer, container)) = signingInfo // REVIEW: favor the container over the key file - C# appears to do this @@ -1625,7 +1632,7 @@ let CopyFSharpCore(outFile: string, referencedDlls: AssemblyReference list) = [] type Args<'T> = Args of 'T -let main0(ctok, argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, errorLoggerProvider : ErrorLoggerProvider, disposables : DisposablesTracker) = +let main0(ctok, argv, referenceResolver, bannerAlreadyPrinted, openBinariesInMemory:bool, exiter:Exiter, errorLoggerProvider : ErrorLoggerProvider, disposables : DisposablesTracker) = // See Bug 735819 let lcidFromCodePage = @@ -1641,6 +1648,7 @@ let main0(ctok, argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, er let directoryBuildingFrom = Directory.GetCurrentDirectory() let setProcessThreadLocals tcConfigB = + tcConfigB.openBinariesInMemory <- openBinariesInMemory #if PREFERRED_UI_LANG match tcConfigB.preferredUiLang with | Some s -> System.Globalization.CultureInfo.CurrentUICulture <- new System.Globalization.CultureInfo(s) @@ -1846,6 +1854,77 @@ let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, gener // Pass on only the minimum information required for the next phase Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter) + +// set up typecheck for given AST without parsing any command line parameters +let main1OfAst (ctok, referenceResolver, openBinariesInMemory, assemblyName, target, outfile, pdbFile, dllReferences, noframework, exiter, errorLoggerProvider: ErrorLoggerProvider, inputs : ParsedInput list) = + + let defaultFSharpBinariesDir = Internal.Utilities.FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(None).Value + let tcConfigB = TcConfigBuilder.CreateNew(referenceResolver, defaultFSharpBinariesDir, (*optimizeForMemory*) false, Directory.GetCurrentDirectory(), isInteractive=false, isInvalidationSupported=false) + tcConfigB.openBinariesInMemory <- openBinariesInMemory + tcConfigB.framework <- not noframework + // Preset: --optimize+ -g --tailcalls+ (see 4505) + SetOptimizeSwitch tcConfigB OptionSwitch.On + SetDebugSwitch tcConfigB None ( + match pdbFile with + | Some _ -> OptionSwitch.On + | None -> OptionSwitch.Off) + SetTailcallSwitch tcConfigB OptionSwitch.On + tcConfigB.target <- target + tcConfigB.sqmNumOfSourceFiles <- 1 + + let errorLogger = errorLoggerProvider.CreateErrorLoggerUpToMaxErrors (tcConfigB, exiter) + + tcConfigB.conditionalCompilationDefines <- "COMPILED" :: tcConfigB.conditionalCompilationDefines + + // append assembly dependencies + dllReferences |> List.iter (fun ref -> tcConfigB.AddReferencedAssemblyByPath(rangeStartup,ref)) + + // If there's a problem building TcConfig, abort + let tcConfig = + try + TcConfig.Create(tcConfigB,validate=false) + with e -> + exiter.Exit 1 + + let foundationalTcConfigP = TcConfigProvider.Constant(tcConfig) + let sysRes,otherRes,knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(ctok, tcConfig) + let tcGlobals,frameworkTcImports = TcImports.BuildFrameworkTcImports (ctok, foundationalTcConfigP, sysRes, otherRes) |> Cancellable.runWithoutCancellation + + use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + + let meta = Directory.GetCurrentDirectory() + let tcConfig = (tcConfig,inputs) ||> List.fold (fun tcc inp -> ApplyMetaCommandsFromInputToTcConfig (tcc, inp,meta)) + let tcConfigP = TcConfigProvider.Constant(tcConfig) + + let tcGlobals,tcImports = + let tcImports = TcImports.BuildNonFrameworkTcImports(ctok, tcConfigP, tcGlobals, frameworkTcImports, otherRes,knownUnresolved) |> Cancellable.runWithoutCancellation + tcGlobals,tcImports + + use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck) + let tcEnv0 = GetInitialTcEnv (assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals) + + let tcState,topAttrs,typedAssembly,_tcEnvAtEnd = + TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, inputs,exiter) + + let generatedCcu = tcState.Ccu + + use unwindPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.CodeGen) + let signingInfo = ValidateKeySigningAttributes (tcConfig, tcGlobals, topAttrs) + + // Try to find an AssemblyVersion attribute + let assemVerFromAttrib = + match AttributeHelpers.TryFindVersionAttribute tcGlobals "System.Reflection.AssemblyVersionAttribute" "AssemblyVersionAttribute" topAttrs.assemblyAttrs with + | Some v -> + match tcConfig.version with + | VersionNone -> Some v + | _ -> warning(Error(FSComp.SR.fscAssemblyVersionAttributeIgnored(),Range.range0)); None + | _ -> None + + // Pass on only the minimum information required for the next phase to ensure GC kicks in. + // In principle the JIT should be able to do good liveness analysis to clean things up, but the + // data structures involved here are so large we can't take the risk. + Args(ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedAssembly, topAttrs, pdbFile, assemblyName, assemVerFromAttrib, signingInfo ,exiter) + /// Phase 2a: encode signature data, optimize, encode optimization data let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, errorLogger: ErrorLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter)) = @@ -1883,7 +1962,11 @@ let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlo Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, (sigDataAttributes, sigDataResources), optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter) /// Phase 2b: IL code generation -let main2b(Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, idata, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter)) = +let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, idata, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter)) = + + match tcImportsCapture with + | None -> () + | Some f -> f tcImports // Compute a static linker. let ilGlobals = tcGlobals.ilg @@ -1899,7 +1982,7 @@ let main2b(Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, erro // Check if System.SerializableAttribute exists in mscorlib.dll, // so that make sure the compiler only emits "serializable" bit into IL metadata when it is available. // Note that SerializableAttribute may be relocated in the future but now resides in mscorlib. - let codegenResults = GenerateIlxCode (IlWriteBackend, false, false, tcConfig, topAttrs, optimizedImpls, generatedCcu.AssemblyName, ilxGenerator) + let codegenResults = GenerateIlxCode ((if Option.isSome dynamicAssemblyCreator then IlReflectBackend else IlWriteBackend), Option.isSome dynamicAssemblyCreator, false, tcConfig, topAttrs, optimizedImpls, generatedCcu.AssemblyName, ilxGenerator) let casApplied = new Dictionary() let securityAttrs, topAssemblyAttrs = topAttrs.assemblyAttrs |> List.partition (fun a -> TypeChecker.IsSecurityAttribute tcGlobals (tcImports.GetImportMap()) casApplied a rangeStartup) // remove any security attributes from the top-level assembly attribute list @@ -1912,10 +1995,10 @@ let main2b(Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, erro AbortOnError(errorLogger, exiter) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, errorLogger, staticLinker, ilGlobals, outfile, pdbfile, ilxMainModule, signingInfo, exiter) + Args (ctok, tcConfig, tcGlobals, errorLogger, staticLinker, outfile, pdbfile, ilxMainModule, signingInfo, exiter) /// Phase 3: static linking -let main3(Args (ctok, tcConfig, errorLogger: ErrorLogger, staticLinker, ilGlobals, outfile, pdbfile, ilxMainModule, signingInfo, exiter:Exiter)) = +let main3(Args (ctok, tcConfig, tcGlobals, errorLogger: ErrorLogger, staticLinker, outfile, pdbfile, ilxMainModule, signingInfo, exiter:Exiter)) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Output @@ -1929,10 +2012,10 @@ let main3(Args (ctok, tcConfig, errorLogger: ErrorLogger, staticLinker, ilGlobal AbortOnError(errorLogger, exiter) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, errorLogger, ilGlobals, ilxMainModule, outfile, pdbfile, signingInfo, exiter) + Args (ctok, tcConfig, errorLogger, tcGlobals, ilxMainModule, outfile, pdbfile, signingInfo, exiter) /// Phase 4: write the binaries -let main4 (Args (ctok, tcConfig, errorLogger: ErrorLogger, ilGlobals, ilxMainModule, outfile, pdbfile, signingInfo, exiter: Exiter)) = +let main4 dynamicAssemblyCreator (Args (ctok, tcConfig, errorLogger: ErrorLogger, tcGlobals: TcGlobals, ilxMainModule, outfile, pdbfile, signingInfo, exiter: Exiter)) = ReportTime tcConfig "Write .NET Binary" use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Output let outfile = tcConfig.MakePathAbsolute outfile @@ -1940,12 +2023,14 @@ let main4 (Args (ctok, tcConfig, errorLogger: ErrorLogger, ilGlobals, ilxMainMod DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok let pdbfile = pdbfile |> Option.map (tcConfig.MakePathAbsolute >> Path.GetFullPath) - begin + + match dynamicAssemblyCreator with + | None -> try try ILBinaryWriter.WriteILBinary (outfile, - { ilg = ilGlobals + { ilg = tcGlobals.ilg pdbfile=pdbfile emitTailcalls = tcConfig.emitTailcalls showTimes = tcConfig.showTimes @@ -1962,7 +2047,8 @@ let main4 (Args (ctok, tcConfig, errorLogger: ErrorLogger, ilGlobals, ilxMainMod with e -> errorRecoveryNoRange e exiter.Exit 1 - end + | Some da -> da (tcGlobals,outfile,ilxMainModule) + AbortOnError(errorLogger, exiter) // Don't copy referenced FSharp.core.dll if we are building FSharp.Core.dll @@ -1976,22 +2062,27 @@ let main4 (Args (ctok, tcConfig, errorLogger: ErrorLogger, ilGlobals, ilxMainMod //----------------------------------------------------------------------------- /// Entry point typecheckAndCompile -let typecheckAndCompile (argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, errorLoggerProvider) = - - // Explanation: Compilation happens on whichever thread calls this function. - let ctok = AssumeCompilationThreadWithoutEvidence () +let typecheckAndCompile (ctok, argv, referenceResolver, bannerAlreadyPrinted, openBinariesInMemory, exiter:Exiter, errorLoggerProvider, tcImportsCapture, dynamicAssemblyCreator) = use d = new DisposablesTracker() use e = new SaveAndRestoreConsoleEncoding() - main0(ctok, argv, referenceResolver, bannerAlreadyPrinted, exiter, errorLoggerProvider, d) + main0(ctok, argv, referenceResolver, bannerAlreadyPrinted, openBinariesInMemory, exiter, errorLoggerProvider, d) |> main1 |> main2a - |> main2b + |> main2b (tcImportsCapture,dynamicAssemblyCreator) |> main3 - |> main4 + |> main4 dynamicAssemblyCreator + + +let compileOfAst (ctok, referenceResolver, openBinariesInMemory, assemblyName, target, outFile, pdbFile, dllReferences, noframework, exiter, errorLoggerProvider, inputs, tcImportsCapture, dynamicAssemblyCreator) = + main1OfAst (ctok, referenceResolver, openBinariesInMemory, assemblyName, target, outFile, pdbFile, dllReferences, noframework, exiter, errorLoggerProvider, inputs) + |> main2a + |> main2b (tcImportsCapture, dynamicAssemblyCreator) + |> main3 + |> main4 dynamicAssemblyCreator -/// Entry point (with ConsoleLoggerProvider) -let mainCompile (argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter) = - typecheckAndCompile(argv, referenceResolver, bannerAlreadyPrinted, exiter, ConsoleLoggerProvider()) +let mainCompile (ctok, argv, referenceResolver, bannerAlreadyPrinted, openBinariesInMemory, exiter, errorLoggerProvider, tcImportsCapture, dynamicAssemblyCreator) = + //System.Runtime.GCSettings.LatencyMode <- System.Runtime.GCLatencyMode.Batch + typecheckAndCompile(ctok, argv, referenceResolver, bannerAlreadyPrinted, openBinariesInMemory, exiter, errorLoggerProvider, tcImportsCapture, dynamicAssemblyCreator) diff --git a/src/fsharp/fsc.fsi b/src/fsharp/fsc.fsi index 66e80b7aac6..df770f29bae 100755 --- a/src/fsharp/fsc.fsi +++ b/src/fsharp/fsc.fsi @@ -30,17 +30,45 @@ val internal ProcessCommandLineFlags : TcConfigBuilder * setProcessThreadLocals: // The entry point used by fsc.exe val typecheckAndCompile : + ctok: CompilationThreadToken * argv : string[] * referenceResolver: ReferenceResolver.Resolver * bannerAlreadyPrinted : bool * + openBinariesInMemory: bool * exiter : Exiter * - loggerProvider: ErrorLoggerProvider -> unit + loggerProvider: ErrorLoggerProvider * + tcImportsCapture: (TcImports -> unit) option * + dynamicAssemblyCreator: (TcGlobals * string * ILModuleDef -> unit) option + -> unit val mainCompile : - argv : string[] * + ctok: CompilationThreadToken * + argv: string[] * referenceResolver: ReferenceResolver.Resolver * - bannerAlreadyPrinted : bool * - exiter : Exiter -> unit + bannerAlreadyPrinted: bool * + openBinariesInMemory: bool * + exiter: Exiter * + loggerProvider: ErrorLoggerProvider * + tcImportsCapture: (TcImports -> unit) option * + dynamicAssemblyCreator: (TcGlobals * string * ILModuleDef -> unit) option + -> unit + +val compileOfAst : + ctok: CompilationThreadToken * + referenceResolver: ReferenceResolver.Resolver * + openBinariesInMemory: bool * + assemblyName:string * + target:CompilerTarget * + targetDll:string * + targetPdb:string option * + dependencies:string list * + noframework:bool * + exiter:Exiter * + loggerProvider: ErrorLoggerProvider * + inputs:ParsedInput list * + tcImportsCapture : (TcImports -> unit) option * + dynamicAssemblyCreator: (TcGlobals * string * ILModuleDef -> unit) option + -> unit /// Part of LegacyHostedCompilerForTesting @@ -50,9 +78,14 @@ type InProcErrorLoggerProvider = member CapturedWarnings : Diagnostic[] member CapturedErrors : Diagnostic[] +/// The default ErrorLogger implementation, reporting messages to the Console up to the maxerrors maximum +type ConsoleLoggerProvider = + new : unit -> ConsoleLoggerProvider + inherit ErrorLoggerProvider +// For unit testing module internal MainModuleBuilder = - val fileVersion: warn: (exn -> unit) -> findStringAttr: (string -> string option) -> assemblyVersion: AbstractIL.IL.ILVersionInfo -> AbstractIL.IL.ILVersionInfo - val productVersion: warn: (exn -> unit) -> findStringAttr: (string -> string option) -> fileVersion: AbstractIL.IL.ILVersionInfo -> string - val productVersionToILVersionInfo: string -> AbstractIL.IL.ILVersionInfo + val fileVersion: warn: (exn -> unit) -> findStringAttr: (string -> string option) -> assemblyVersion: ILVersionInfo -> ILVersionInfo + val productVersion: warn: (exn -> unit) -> findStringAttr: (string -> string option) -> fileVersion: ILVersionInfo -> string + val productVersionToILVersionInfo: string -> ILVersionInfo diff --git a/src/fsharp/fscmain.fs b/src/fsharp/fscmain.fs index c8e74b3d9d1..1b524557b85 100644 --- a/src/fsharp/fscmain.fs +++ b/src/fsharp/fscmain.fs @@ -1,3 +1,4 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. module internal Microsoft.FSharp.Compiler.CommandLineMain @@ -14,6 +15,7 @@ open Microsoft.FSharp.Compiler.Driver open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Internal.Utilities #if FX_RESHAPED_REFLECTION @@ -28,6 +30,9 @@ do () module Driver = let main argv = + + let ctok = AssumeCompilationThreadWithoutEvidence () + // Check for --pause as the very first step so that a compiler can be attached here. if argv |> Array.exists (fun x -> x = "/pause" || x = "--pause") then System.Console.WriteLine("Press return to continue...") @@ -43,7 +48,7 @@ module Driver = failwithf "%s" <| FSComp.SR.elSysEnvExitDidntExit() } - mainCompile (argv, MSBuildReferenceResolver.Resolver, false, quitProcessExiter) + mainCompile (ctok, argv, MSBuildReferenceResolver.Resolver, (*bannerAlreadyPrinted*)false, (*openBinariesInMemory*)false, quitProcessExiter, ConsoleLoggerProvider(), None, None) 0 [] diff --git a/src/fsharp/fsi/FSIstrings.txt b/src/fsharp/fsi/FSIstrings.txt index adae45913dc..d02cfeb79c4 100644 --- a/src/fsharp/fsi/FSIstrings.txt +++ b/src/fsharp/fsi/FSIstrings.txt @@ -50,4 +50,5 @@ fsiUnexpectedThreadAbortException,"- Unexpected ThreadAbortException (Ctrl-C) du fsiFailedToResolveAssembly,"Failed to resolve assembly '%s'" fsiBindingSessionTo,"Binding session to '%s'..." fsiProductName,"Microsoft (R) F# Interactive version %s" -shadowCopyReferences,"Prevents references from being locked by the F# Interactive process" \ No newline at end of file +fsiProductNameCommunity,"F# Interactive for F# %s" +shadowCopyReferences,"Prevents references from being locked by the F# Interactive process" diff --git a/src/fsharp/fsi/Fsi.fsproj b/src/fsharp/fsi/Fsi.fsproj index 0af69b280bd..f53b7c9dce6 100644 --- a/src/fsharp/fsi/Fsi.fsproj +++ b/src/fsharp/fsi/Fsi.fsproj @@ -18,7 +18,10 @@ $(NoWarn);62 fsi 0x0A000000 - EXTENSIONTYPING;COMPILER;$(DefineConstants) + EXTENSIONTYPING;$(DefineConstants) + COMPILER;$(DefineConstants) + FSI_SHADOW_COPY_REFERENCES;$(DefineConstants) + FSI_SERVER;$(DefineConstants) true $(OtherFlags) --warnon:1182 fsi.res @@ -31,23 +34,11 @@ false false - - FSIstrings.txt - assemblyinfo.fsi.exe.fs - - Utilities/InternalCollections.fsi - - - Utilities/InternalCollections.fs - - - Console/console.fs - - - InteractiveSession/fsi.fs + + fsimain.fs PreserveNewest diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs index 1a0ddc6fbb1..6cc5787d614 100644 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -1,6 +1,6 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. -module internal Microsoft.FSharp.Compiler.Interactive.Shell +module Microsoft.FSharp.Compiler.Interactive.Shell #nowarn "55" @@ -8,21 +8,17 @@ module internal Microsoft.FSharp.Compiler.Interactive.Shell [] do() -open Internal.Utilities open System open System.Collections.Generic open System.Diagnostics open System.Globalization open System.Runtime.InteropServices -open System.Runtime.CompilerServices open System.IO open System.Text open System.Threading open System.Reflection -#if !FX_NO_WINFORMS -open System.Windows.Forms -#endif +open System.Runtime.CompilerServices open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics @@ -31,8 +27,6 @@ open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX open Microsoft.FSharp.Compiler.AbstractIL.ILRuntimeWriter - -open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast @@ -53,33 +47,25 @@ open Microsoft.FSharp.Compiler.TypeChecker open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.SourceCodeServices +open Internal.Utilities open Internal.Utilities.Collections open Internal.Utilities.StructuredFormat -type FormatOptions = Internal.Utilities.StructuredFormat.FormatOptions - -//---------------------------------------------------------------------------- -// Hardbinding dependencies should we NGEN fsi.exe -//---------------------------------------------------------------------------- - #if FX_RESHAPED_REFLECTION open Microsoft.FSharp.Core.ReflectionAdapters #endif -open System.Runtime.CompilerServices -#if !FX_NO_DEFAULT_DEPENDENCY_TYPE -[] do () -[] do () -#endif //---------------------------------------------------------------------------- // For the FSI as a service methods... //---------------------------------------------------------------------------- -type FsiValue(reflectionValue:obj, reflectionType:Type) = +type FsiValue(reflectionValue:obj, reflectionType:Type, fsharpType:FSharpType) = member x.ReflectionValue = reflectionValue member x.ReflectionType = reflectionType + member x.FSharpType = fsharpType [] @@ -196,8 +182,6 @@ module internal Utilities = outWriter.WriteLine() -let referencedAssemblies = Dictionary() - #if FX_RESHAPED_REFLECTION // restore type alias type BindingFlags = System.Reflection.BindingFlags @@ -232,10 +216,23 @@ type internal FsiValuePrinterMode = | PrintExpr | PrintDecl +#if COMPILER_SERVICE_AS_DLL +type EvaluationEventArgs(fsivalue : FsiValue option, symbolUse : FSharpSymbolUse, decl: FSharpImplementationFileDeclaration) = + inherit EventArgs() + member x.Name = symbolUse.Symbol.DisplayName + member x.FsiValue = fsivalue + member x.SymbolUse = symbolUse + member x.Symbol = symbolUse.Symbol + member x.ImplementationDeclaration = decl +#endif + [] /// User-configurable information that changes how F# Interactive operates, stored in the 'fsi' object /// and accessible via the programming model -type public FsiEvaluationSessionHostConfig () = +type FsiEvaluationSessionHostConfig () = +#if COMPILER_SERVICE_AS_DLL + let evaluationEvent = new Event () +#endif /// Called by the evaluation session to ask the host for parameters to format text for output abstract FormatProvider: System.IFormatProvider /// Called by the evaluation session to ask the host for parameters to format text for output @@ -261,6 +258,31 @@ type public FsiEvaluationSessionHostConfig () = /// stripping things like "/use:file.fsx", "-r:Foo.dll" etc. 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. + /// + /// A "console" gets used if + /// --readline- is specified (the default on Windows + .NET); and + /// not --fsi-server (which should always be combined with --readline-); and + /// GetOptionalConsoleReadLine() returns a Some + /// + /// "Peekahead" occurs if --peekahead- is not specified (i.e. it is the default): + /// - If a console is being used then + /// - a prompt is printed early + /// - a background thread is created + /// - the GetOptionalConsoleReadLine() callback is used to read the first line + /// - Otherwise call inReader.Peek() + /// + /// Further lines are read as follows: + /// - If a console is being used then use GetOptionalConsoleReadLine() + /// - Otherwise use inReader.ReadLine() + + 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 + /// 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. @@ -273,15 +295,15 @@ type public FsiEvaluationSessionHostConfig () = /// Schedule a restart for the event loop. abstract EventLoopScheduleRestart : unit -> unit + /// Implicitly reference FSharp.Compiler.Interactive.Settings.dll + abstract UseFsiAuxLib : bool - /// 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 SetEventLoop : run: (unit -> bool) * invoke: ((unit -> obj) -> obj) * restart: (unit -> unit) -> unit - - - +#if COMPILER_SERVICE_AS_DLL + /// Hook for listening for evaluation bindings + member x.OnEvaluation = evaluationEvent.Publish + member internal x.TriggerEvaluation (value, symbolUse, decl) = + evaluationEvent.Trigger (EvaluationEventArgs (value, symbolUse, decl) ) +#endif /// 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. @@ -438,6 +460,13 @@ type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, g: TcGlobals, else None + + /// Format a value + member valuePrinter.FormatValue (obj:obj, objTy) = + let opts = valuePrinter.GetFsiPrintOptions() + let lay = valuePrinter.PrintValue (FsiValuePrinterMode.PrintExpr, opts, obj, objTy) + Internal.Utilities.StructuredFormat.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, emEnv, ilxGenerator: IlxAssemblyGenerator, vref) = let opts = valuePrinter.GetFsiPrintOptions() @@ -497,9 +526,11 @@ type internal FsiStdinSyphon(errorWriter: TextWriter) = Utilities.ignoreAllErrors (fun () -> let isError = true DoWithErrorColor isError (fun () -> + errorWriter.WriteLine(); writeViaBufferWithEnvironmentNewLines errorWriter (OutputDiagnosticContext " " syphon.GetLine) err; writeViaBufferWithEnvironmentNewLines errorWriter (OutputDiagnostic (tcConfig.implicitIncludeDir,tcConfig.showFullPaths,tcConfig.flatErrors,tcConfig.errorStyle,isError)) err; - errorWriter.WriteLine("\n") + errorWriter.WriteLine() + errorWriter.WriteLine() errorWriter.Flush())) @@ -544,7 +575,9 @@ type internal ErrorLoggerThatStopsOnFirstError(tcConfigB:TcConfigBuilder, fsiStd fsiConsoleOutput.Error.WriteLine() writeViaBufferWithEnvironmentNewLines fsiConsoleOutput.Error (OutputDiagnosticContext " " fsiStdinSyphon.GetLine) err writeViaBufferWithEnvironmentNewLines fsiConsoleOutput.Error (OutputDiagnostic (tcConfigB.implicitIncludeDir,tcConfigB.showFullPaths,tcConfigB.flatErrors,tcConfigB.errorStyle,isError)) err - fsiConsoleOutput.Error.WriteLine("\n")) + fsiConsoleOutput.Error.WriteLine() + fsiConsoleOutput.Error.WriteLine() + fsiConsoleOutput.Error.Flush()) override x.ErrorCount = errorCount @@ -581,8 +614,7 @@ type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, argv: s // Mono on Win32 doesn't implement correct console processing not (runningOnMono && System.Environment.OSVersion.Platform = System.PlatformID.Win32NT) #endif -// In the cross-platform edition of F#, 'gui' support is currently off by default - let mutable gui = not runningOnMono // override via "--gui", on by default + let mutable gui = not runningOnMono // override via "--gui", on by default except when on Mono #if DEBUG let mutable showILCode = false // show modul il code #endif @@ -665,7 +697,14 @@ type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, argv: s [ // 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"); + +#if COMPILER_SERVICE + // Disables interaction (to be used by libraries embedding FSI only!) + CompilerOption("noninteractive","", OptionUnit (fun () -> interact <- false), None, None); +#endif + ]) ] @@ -692,9 +731,7 @@ type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, argv: s (* Renamed --readline and --no-readline to --tabcompletion:+|- *) 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())); -#if FSI_SHADOW_COPY_REFERENCES CompilerOption("shadowcopyreferences", tagNone, OptionSwitch(fun flag -> tcConfigB.shadowCopyReferences <- flag = OptionSwitch.On), None, Some(FSIstrings.SR.shadowCopyReferences())); -#endif ]); ] @@ -711,7 +748,11 @@ type internal FsiCommandLineOptions(fsi: FsiEvaluationSessionHostConfig, argv: s let abbrevArgs = GetAbbrevFlagSet tcConfigB false ParseCompilerOptions (collect, fsiCompilerOptions, List.tail (PostProcessCompilerArgs abbrevArgs argv)) with e -> - stopProcessingRecovery e range0; exit 1; +#if COMPILER_SERVICE + stopProcessingRecovery e range0; failwithf "Error creating evaluation session: %A" e +#else + stopProcessingRecovery e range0; exit 1 +#endif inputFilesAcc do @@ -820,9 +861,11 @@ let internal SetServerCodePages(fsiOptions: FsiCommandLineOptions) = for pause in [10;50;100;1000;2000;10000] do if not !successful then Thread.Sleep(pause); +#if LOGGING_GUI if not !successful then System.Windows.Forms.MessageBox.Show(FSIstrings.SR.fsiConsoleProblem()) |> ignore #endif +#endif //---------------------------------------------------------------------------- // Prompt printing @@ -847,32 +890,18 @@ type internal FsiConsolePrompt(fsiOptions: FsiCommandLineOptions, fsiConsoleOutp //---------------------------------------------------------------------------- // Startup processing //---------------------------------------------------------------------------- -type internal FsiConsoleInput(fsiOptions: FsiCommandLineOptions, inReader: TextReader, outWriter: TextWriter) = - - let consoleLooksOperational() = - if fsiOptions.ProbeToSeeIfConsoleWorks then - try - // Probe to see if the console looks functional on this version of .NET - let _ = Console.KeyAvailable - let _ = Console.ForegroundColor - let _ = Console.CursorLeft <- Console.CursorLeft - true - with _ -> - (* warning(Failure("Note: there was a problem setting up custom readline console support. Consider starting fsi.exe with the --no-readline option")); *) - false - else - true +type internal FsiConsoleInput(fsi: FsiEvaluationSessionHostConfig, fsiOptions: FsiCommandLineOptions, inReader: TextReader, outWriter: TextWriter) = let consoleOpt = // The "console.fs" code does a limited form of "TAB-completion". // Currently, it turns on if it looks like we have a console. - if fsiOptions.EnableConsoleKeyProcessing && consoleLooksOperational() then - Some(new Microsoft.FSharp.Compiler.Interactive.ReadLineConsole()) + if fsiOptions.EnableConsoleKeyProcessing then + fsi.GetOptionalConsoleReadLine(fsiOptions.ProbeToSeeIfConsoleWorks) else 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 = None) + 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) @@ -888,7 +917,7 @@ type internal FsiConsoleInput(fsiOptions: FsiCommandLineOptions, inReader: TextR | Some console when fsiOptions.EnableConsoleKeyProcessing && not fsiOptions.IsInteractiveServer -> if List.isEmpty fsiOptions.SourceFiles then if !progress then fprintfn outWriter "first-line-reader-thread reading first line..."; - firstLine <- Some(console.ReadLine()); + 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." ; @@ -957,6 +986,7 @@ type internal FsiDynamicCompiler ilGlobals: ILGlobals, fsiOptions : FsiCommandLineOptions, fsiConsoleOutput : FsiConsoleOutput, + fsiCollectible: bool, niceNameGen, resolveAssemblyRef) = @@ -970,10 +1000,12 @@ type internal FsiDynamicCompiler let valuePrinter = FsiValuePrinter(fsi, tcGlobals, generateDebugInfo, resolveAssemblyRef, outWriter) - let assemblyBuilder,moduleBuilder = ILRuntimeWriter.mkDynamicAssemblyAndModule (assemblyName, tcConfigB.optSettings.localOpt(), generateDebugInfo, false) + let assemblyBuilder,moduleBuilder = ILRuntimeWriter.mkDynamicAssemblyAndModule (assemblyName, tcConfigB.optSettings.localOpt(), generateDebugInfo, fsiCollectible) let rangeStdin = rangeN Lexhelp.stdinMockFilename 0 + //let _writer = moduleBuilder.GetSymWriter() + let infoReader = InfoReader(tcGlobals,tcImports.GetImportMap()) /// Add attributes @@ -1134,10 +1166,49 @@ type internal FsiDynamicCompiler let prefixPath = pathOfLid prefix let impl = SynModuleOrNamespace(prefix,(*isRec*)false, (* isModule: *) true,defs,PreXmlDoc.Empty,[],None,rangeStdin) let input = ParsedInput.ImplFile(ParsedImplFileInput(filename,true, ComputeQualifiedNameOfFileFromUniquePath (rangeStdin,prefixPath),[],[],[impl],(true (* isLastCompiland *), false (* isExe *)) )) - let istate,tcEnvAtEndOfLastInput,_declaredImpls = ProcessInputs (ctok, errorLogger, istate, [input], showTypes, true, isInteractiveItExpr, prefix) + let istate,tcEnvAtEndOfLastInput,declaredImpls = ProcessInputs (ctok, errorLogger, istate, [input], showTypes, true, isInteractiveItExpr, prefix) let tcState = istate.tcState let newState = { istate with tcState = tcState.NextStateAfterIncrementalFragment(tcEnvAtEndOfLastInput) } +#if COMPILER_SERVICE_AS_DLL + // Find all new declarations the EvaluationListener + begin + let contents = FSharpAssemblyContents(tcGlobals, tcState.Ccu, tcImports, declaredImpls) + let contentFile = contents.ImplementationFiles.[0] + // Skip the "FSI_NNNN" + match contentFile.Declarations with + | [FSharpImplementationFileDeclaration.Entity (_eFakeModule,modDecls) ] -> + for decl in modDecls do + match decl with + | 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 optValue = newState.ilxGenerator.LookupGeneratedValue(valuePrinter.GetEvaluationContext(newState.emEnv), vref.Deref) + match optValue with + | Some (res, typ) -> Some(FsiValue(res, typ, FSharpType(tcGlobals, newState.tcState.Ccu, newState.tcImports, vref.Type))) + | None -> None + | _ -> None + + let symbol = FSharpSymbol.Create(newState.tcGlobals, newState.tcState.Ccu, newState.tcImports, v.Item) + let symbolUse = FSharpSymbolUse(tcGlobals, newState.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(newState.tcGlobals, newState.tcState.Ccu, newState.tcImports, e.Item) + let symbolUse = FSharpSymbolUse(tcGlobals, newState.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 + () + | _ -> () + end +#else + ignore declaredImpls +#endif + newState @@ -1167,7 +1238,7 @@ type internal FsiDynamicCompiler // let optValue = istate.ilxGenerator.LookupGeneratedValue(valuePrinter.GetEvaluationContext(istate.emEnv), vref.Deref); match optValue with - | Some (res, typ) -> istate, Completed(Some(FsiValue(res, typ))) + | Some (res, typ) -> istate, Completed(Some(FsiValue(res, typ, FSharpType(tcGlobals, istate.tcState.Ccu, istate.tcImports, vref.Type)))) | _ -> istate, Completed None // Return the interactive state. @@ -1290,56 +1361,12 @@ type internal FsiDynamicCompiler debugBreak = false } + member __.CurrentPartialAssemblySignature(istate) = + FSharpAssemblySignature(istate.tcGlobals, istate.tcState.Ccu, istate.tcImports, None, istate.tcState.PartialAssemblySignature) -type internal FsiIntellisenseProvider(tcGlobals, tcImports: TcImports) = - - let rangeStdin = rangeN Lexhelp.stdinMockFilename 0 + member __.FormatValue(obj:obj, objTy) = + valuePrinter.FormatValue(obj, objTy) - //---------------------------------------------------------------------------- - // FsiIntellisense - v1 - identifier completion - namedItemInEnvL - //---------------------------------------------------------------------------- - - member __.CompletionsForPartialLID istate (prefix:string) = - let lid,stem = - if prefix.IndexOf(".",StringComparison.Ordinal) >= 0 then - let parts = prefix.Split(Array.ofList ['.']) - let n = parts.Length - Array.sub parts 0 (n-1) |> Array.toList,parts.[n-1] - else - [],prefix - let tcState = istate.tcState (* folded through now? *) - - let amap = tcImports.GetImportMap() - let infoReader = new InfoReader(tcGlobals,amap) - let ncenv = new NameResolution.NameResolver(tcGlobals,amap,infoReader,NameResolution.FakeInstantiationGenerator) - // Note: for the accessor domain we should use (AccessRightsOfEnv tcState.TcEnvFromImpls) - let ad = AccessibleFromSomeFSharpCode - let nItems = NameResolution.ResolvePartialLongIdent ncenv tcState.TcEnvFromImpls.NameEnv (ConstraintSolver.IsApplicableMethApprox tcGlobals amap rangeStdin) rangeStdin ad lid false - let names = nItems |> List.map (fun d -> d.DisplayName) - let names = names |> List.filter (fun (name:string) -> name.StartsWith(stem,StringComparison.Ordinal)) - names - -#if FSI_SERVER_INTELLISENSE - //---------------------------------------------------------------------------- - // FsiIntellisense (posible feature for v2) - GetDeclarations - //---------------------------------------------------------------------------- - - member __.FsiGetDeclarations istate (text:string) (names:string[]) = - try - let tcConfig = TcConfig.Create(tcConfigB,validate=false) - Microsoft.FSharp.Compiler.SourceCodeServices.FsiIntelisense.getDeclarations - (tcConfig, - tcGlobals, - tcImports, - istate.tcState) - text - names - with - e -> - System.Windows.Forms.MessageBox.Show("FsiGetDeclarations: throws:\n" ^ e.ToString()) |> ignore - [| |] - -#endif //---------------------------------------------------------------------------- // ctrl-c handling @@ -1403,6 +1430,12 @@ type internal FsiInterruptController(fsiOptions : FsiCommandLineOptions, // REVIEW: streamline all this code to use the same code on Windows and Posix. member controller.InstallKillThread(threadToKill:Thread, pauseMilliseconds:int) = +#if DYNAMIC_CODE_EMITS_INTERRUPT_CHECKS + let action() = + Microsoft.FSharp.Silverlight.InterruptThread(threadToKill.ManagedThreadId) + + ctrlEventActions <- action :: ctrlEventActions; +#else #if FX_NO_THREADABORT ignore threadToKill ignore pauseMilliseconds @@ -1519,6 +1552,7 @@ type internal FsiInterruptController(fsiOptions : FsiCommandLineOptions, stdinInterruptState <- StdinEOFPermittedBecauseCtrlCRecentlyPressed killThreadRequest <- if (interruptAllowed = InterruptCanRaiseException) then ThreadAbortRequest else PrintInterruptRequest +#endif //---------------------------------------------------------------------------- // assembly finder @@ -1574,7 +1608,11 @@ module internal MagicAssemblyResolution = // 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. +#if FSI_TODO_NETCORE + Assembly.LoadFrom(path) +#else Assembly.UnsafeLoadFrom(path) +#endif let Install(tcConfigB, tcImports: TcImports, fsiDynamicCompiler: FsiDynamicCompiler, fsiConsoleOutput: FsiConsoleOutput) = @@ -1755,7 +1793,7 @@ type internal FsiStdinLexerProvider LexbufFromLineReader fsiStdinSyphon (fun () -> match fsiConsoleInput.TryGetFirstLine() with | Some firstLine -> firstLine - | None -> console.ReadLine()) + | None -> console()) | _ -> LexbufFromLineReader fsiStdinSyphon (fun () -> fsiConsoleInput.In.ReadLine() |> removeZeroCharsFromString) @@ -1794,9 +1832,12 @@ type internal FsiInteractionProcessor lexResourceManager : LexResourceManager, initialInteractiveState) = + let referencedAssemblies = Dictionary() + let mutable currState = initialInteractiveState let event = Control.Event() let setCurrState s = currState <- s; event.Trigger() + let runCodeOnEventLoop errorLogger f istate = try fsi.EventLoopInvoke (fun () -> @@ -1883,7 +1924,6 @@ type internal FsiInteractionProcessor let resolutions,istate = fsiDynamicCompiler.EvalRequireReference(ctok, istate, m, path) resolutions |> List.iter (fun ar -> let format = -#if FSI_SHADOW_COPY_REFERENCES if tcConfig.shadowCopyReferences then let resolvedPath = ar.resolvedPath.ToUpperInvariant() let fileTime = File.GetLastWriteTimeUtc(resolvedPath) @@ -1896,7 +1936,6 @@ type internal FsiInteractionProcessor | _ -> FSIstrings.SR.fsiDidAHashr(ar.resolvedPath) else -#endif FSIstrings.SR.fsiDidAHashrWithLockWarning(ar.resolvedPath) fsiConsoleOutput.uprintnfnn "%s" format) istate,Completed None @@ -2218,6 +2257,8 @@ type internal FsiInteractionProcessor mainThreadProcessParsedExpression ctok errorLogger (exprWithSeq, istate)) |> commitResult + member __.PartialAssemblySignatureUpdated = event.Publish + /// Start the background thread used to read the input reader and/or console /// /// This is the main stdin loop, running on the stdinReaderThread. @@ -2317,82 +2358,15 @@ type internal FsiInteractionProcessor let names = names |> List.filter (fun name -> name.StartsWith(stem,StringComparison.Ordinal)) names +#if COMPILER_SERVICE + member __.ParseAndCheckInteraction (ctok, referenceResolver, checker, istate, text:string) = + let tcConfig = TcConfig.Create(tcConfigB,validate=false) - - - -#if !FX_NO_WINFORMS -//---------------------------------------------------------------------------- -// GUI runCodeOnMainThread -//---------------------------------------------------------------------------- - -//type InteractionStateConverter = delegate of FsiDynamicCompilerState -> FsiDynamicCompilerState * stepStatus - -///Use a dummy to access protected member -type internal DummyForm() = - inherit Form() - member x.DoCreateHandle() = x.CreateHandle() - -/// This is the event loop implementation for winforms -let WinFormsEventLoop(fsiConsoleOutput: FsiConsoleOutput, lcid : int option) = - let mainForm = new DummyForm() - do mainForm.DoCreateHandle(); - // Set the default thread exception handler - let restart = ref false - let run() = - restart := false; - if !progress then fprintfn fsiConsoleOutput.Out "MAIN: Calling Application.Run..."; - Application.Run() - if !progress then fprintfn fsiConsoleOutput.Out "MAIN: Returned from Application.Run..."; - !restart - let invoke (f: unit -> obj) : obj = - if !progress then fprintfn fsiConsoleOutput.Out "RunCodeOnWinFormsMainThread: entry..."; - if not mainForm.InvokeRequired then - f() - else - - // Workaround: Mono's Control.Invoke returns a null result. Hence avoid the problem by - // transferring the resulting state using a mutable location. - let mainFormInvokeResultHolder = ref None - - // Actually, Mono's Control.Invoke isn't even blocking (or wasn't on 1.1.15)! So use a signal to indicate completion. - // Indeed, we should probably do this anyway with a timeout so we can report progress from - // the GUI thread. - use doneSignal = new AutoResetEvent(false) - - if !progress then fprintfn fsiConsoleOutput.Out "RunCodeOnWinFormsMainThread: invoking..."; - - // BLOCKING: This blocks the stdin-reader thread until the - // form invocation has completed. NOTE: does not block on Mono, or did not on 1.1.15 - mainForm.Invoke(new MethodInvoker(fun () -> - try - // When we get called back, someone may jack our culture - // So we must reset our UI culture every time - use _holder = SetCurrentUICultureForThread lcid; - mainFormInvokeResultHolder := Some(f ()); - finally - doneSignal.Set() |> ignore)) |> ignore; - - if !progress then fprintfn fsiConsoleOutput.Out "RunCodeOnWinFormsMainThread: Waiting for completion signal...."; - while not (doneSignal.WaitOne(new TimeSpan(0,0,1),true)) do - if !progress then fprintf fsiConsoleOutput.Out "."; fsiConsoleOutput.Out.Flush() - - if !progress then fprintfn fsiConsoleOutput.Out "RunCodeOnWinFormsMainThread: Got completion signal, res = %b" (Option.isSome !mainFormInvokeResultHolder); - !mainFormInvokeResultHolder |> Option.get - - let restart() = restart := true; Application.Exit() - (run, invoke, restart) - -let internal TrySetUnhandledExceptionMode() = - let i = ref 0 // stop inlining - try - Application.SetUnhandledExceptionMode(UnhandledExceptionMode.CatchException) - incr i;incr i;incr i;incr i;incr i;incr i; - with _ -> - decr i;decr i;decr i;decr i;() + let fsiInteractiveChecker = FsiInteractiveChecker(referenceResolver, checker, tcConfig, istate.tcGlobals, istate.tcImports, istate.tcState) + fsiInteractiveChecker.ParseAndCheckInteraction(ctok, text) #endif -#if FSI_SERVER + //---------------------------------------------------------------------------- // Server mode: //---------------------------------------------------------------------------- @@ -2403,32 +2377,18 @@ let internal SpawnThread name f = th.Start() let internal SpawnInteractiveServer - (fsiOptions : FsiCommandLineOptions, - fsiConsoleOutput: FsiConsoleOutput, - fsiInterruptController: FsiInterruptController) = + (fsi: FsiEvaluationSessionHostConfig, + fsiOptions : FsiCommandLineOptions, + fsiConsoleOutput: FsiConsoleOutput) = //printf "Spawning fsi server on channel '%s'" !fsiServerName; SpawnThread "ServerThread" (fun () -> #if FX_LCIDFROMCODEPAGE use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID #endif try - let server = - {new Server.Shared.FSharpInteractiveServer() with - member this.Interrupt() = - //printf "FSI-SERVER: received CTRL-C request...\n"; - try - fsiInterruptController.Interrupt() - with e -> - // Final sanity check! - catch all exns - but not expected - assert false - () - - } - - Server.Shared.FSharpInteractiveServer.StartServer(fsiOptions.FsiServerName,server) + fsi.StartServer(fsiOptions.FsiServerName) with e -> fprintfn fsiConsoleOutput.Error "%s" (FSIstrings.SR.fsiExceptionRaisedStartingServer(e.ToString()))) -#endif /// Repeatedly drive the event loop (e.g. Application.Run()) but catching ThreadAbortException and re-running. /// @@ -2462,7 +2422,7 @@ let internal DriveFsiEventLoop (fsi: FsiEvaluationSessionHostConfig, fsiConsoleO /// 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 internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], inReader:TextReader, outWriter:TextWriter, errorWriter: TextWriter) = +type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], inReader:TextReader, outWriter:TextWriter, errorWriter: TextWriter, fsiCollectible: bool, msbuildEnabled: bool) = #if !FX_NO_HEAPTERMINATION do if not runningOnMono then Lib.UnmanagedProcessExecutionOptions.EnableHeapTerminationOnCorruption() (* SDL recommendation *) @@ -2511,10 +2471,26 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st #if FX_RESHAPED_REFLECTION System.AppContext.BaseDirectory #else - System.AppDomain.CurrentDomain.BaseDirectory + System.AppDomain.CurrentDomain.BaseDirectory +#endif + + // When used as part of FCS we cannot assume the current process is fsi.exe + // So we try to fallback to the default compiler dir. + let defaultFSharpBinariesDir = + let safeExists f = (try File.Exists(f) with _ -> false) + let containsRequiredFiles = + [ "FSharp.Core.dll"; "FSharp.Core.sigdata"; "FSharp.Core.optdata" ] + |> Seq.map (fun file -> Path.Combine(defaultFSharpBinariesDir, file)) + |> Seq.forall safeExists + if containsRequiredFiles then defaultFSharpBinariesDir + else Internal.Utilities.FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(None).Value + +#if COMPILER_SERVICE && !COMPILER_SERVICE_DLL_VISUAL_STUDIO + let referenceResolver = SimulatedMSBuildReferenceResolver.GetBestAvailableResolver(msbuildEnabled) +#else + let referenceResolver = (assert msbuildEnabled); MSBuildReferenceResolver.Resolver #endif - let referenceResolver = MSBuildReferenceResolver.Resolver let tcConfigB = TcConfigBuilder.CreateNew(referenceResolver, defaultFSharpBinariesDir, @@ -2523,7 +2499,7 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st isInvalidationSupported=false) let tcConfigP = TcConfigProvider.BasedOnMutableBuilder(tcConfigB) do tcConfigB.resolutionEnvironment <- ReferenceResolver.RuntimeLike // See Bug 3608 - do tcConfigB.useFsiAuxLib <- true + do tcConfigB.useFsiAuxLib <- fsi.UseFsiAuxLib #if FSI_TODO_NETCORE // "RuntimeLike" assembly resolution for F# Interactive is not yet properly figured out on .NET Core @@ -2538,9 +2514,11 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st do SetDebugSwitch tcConfigB (Some "pdbonly") OptionSwitch.On do SetTailcallSwitch tcConfigB OptionSwitch.On +#if !FSI_TODO_NETCORE // set platform depending on whether the current process is a 64-bit process. // BUG 429882 : FsiAnyCPU.exe issues warnings (x64 v MSIL) when referencing 64-bit assemblies do tcConfigB.platform <- if IntPtr.Size = 8 then Some AMD64 else Some X86 +#endif let fsiStdinSyphon = new FsiStdinSyphon(errorWriter) let fsiConsoleOutput = FsiConsoleOutput(tcConfigB, outWriter, errorWriter) @@ -2592,13 +2570,32 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st fsiConsolePrompt.PrintAhead() - let fsiConsoleInput = FsiConsoleInput(fsiOptions, inReader, outWriter) + let fsiConsoleInput = FsiConsoleInput(fsi, fsiOptions, inReader, outWriter) +#if COMPILER_SERVICE + /// The single, global interactive checker that can be safely used in conjunction with other operations + /// on the FsiEvaluationSession. + let checker = FSharpChecker.Create(msbuildEnabled=msbuildEnabled) + + let (tcGlobals,frameworkTcImports,nonFrameworkResolutions,unresolvedReferences) = + try + let tcConfig = tcConfigP.Get(ctokStartup) + checker.FrameworkImportsCache.Get (ctokStartup, tcConfig) |> Cancellable.runWithoutCancellation + with e -> + stopProcessingRecovery e range0; failwithf "Error creating evaluation session: %A" e + + let tcImports = + try + TcImports.BuildNonFrameworkTcImports(ctokStartup, tcConfigP, tcGlobals, frameworkTcImports, nonFrameworkResolutions, unresolvedReferences) |> Cancellable.runWithoutCancellation + with e -> + stopProcessingRecovery e range0; failwithf "Error creating evaluation session: %A" e +#else let tcGlobals,tcImports = try TcImports.BuildTcImports(ctokStartup, tcConfigP) |> Cancellable.runWithoutCancellation with e -> stopProcessingRecovery e range0; exit 1 +#endif let ilGlobals = tcGlobals.ilg @@ -2623,7 +2620,7 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st | Some resolvedPath -> Some (Choice1Of2 resolvedPath) | None -> None - let fsiDynamicCompiler = FsiDynamicCompiler(fsi, timeReporter, tcConfigB, tcLockObject, outWriter, tcImports, tcGlobals, ilGlobals, fsiOptions, fsiConsoleOutput, niceNameGen, resolveAssemblyRef) + let fsiDynamicCompiler = FsiDynamicCompiler(fsi, timeReporter, tcConfigB, tcLockObject, outWriter, tcImports, tcGlobals, ilGlobals, fsiOptions, fsiConsoleOutput, fsiCollectible, niceNameGen, resolveAssemblyRef) let fsiInterruptController = FsiInterruptController(fsiOptions, fsiConsoleOutput) @@ -2634,8 +2631,6 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st let fsiStdinLexerProvider = FsiStdinLexerProvider(tcConfigB, fsiStdinSyphon, fsiConsoleInput, fsiConsoleOutput, fsiOptions, lexResourceManager) - let fsiIntellisenseProvider = FsiIntellisenseProvider(tcGlobals, tcImports) - let fsiInteractionProcessor = FsiInteractionProcessor(fsi, tcConfigB, fsiOptions, fsiDynamicCompiler, fsiConsolePrompt, fsiConsoleOutput, fsiInterruptController, fsiStdinLexerProvider, lexResourceManager, initialInteractiveState) let commitResult res = @@ -2644,6 +2639,16 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st | Choice2Of2 None -> failwith "Operation failed. The error text has been printed in the error stream. To return the corresponding FSharpErrorInfo use the EvalInteractionNonThrowing, EvalScriptNonThrowing or EvalExpressionNonThrowing" | Choice2Of2 (Some userExn) -> raise userExn + let commitResultNonThrowing tcConfig scriptFile (errorLogger: CompilationErrorLogger) res = + let errs = errorLogger.GetErrors() + let userRes = + match res with + | Choice1Of2 r -> Choice1Of2 r + | Choice2Of2 None -> Choice2Of2 (System.Exception "Operation could not be completed due to earlier error") + | Choice2Of2 (Some userExn) -> Choice2Of2 userExn + + userRes, ErrorHelpers.CreateErrorInfos (tcConfig, true, scriptFile, errs) + let dummyScriptFileName = "input.fsx" interface IDisposable with @@ -2659,6 +2664,17 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st member x.GetCompletions(longIdent) = fsiInteractionProcessor.CompletionsForPartialLID (fsiInteractionProcessor.CurrentState, longIdent) |> Seq.ofList +#if COMPILER_SERVICE + member x.ParseAndCheckInteraction(code) = + let ctok = AssumeCompilationThreadWithoutEvidence () + fsiInteractionProcessor.ParseAndCheckInteraction (ctok, referenceResolver, checker.ReactorOps, fsiInteractionProcessor.CurrentState, code) + + member x.InteractiveChecker = checker +#endif + + member x.CurrentPartialAssemblySignature = + fsiDynamicCompiler.CurrentPartialAssemblySignature (fsiInteractionProcessor.CurrentState) + member x.DynamicAssembly = fsiDynamicCompiler.DynamicAssembly /// A host calls this to determine if the --gui parameter is active @@ -2667,7 +2683,7 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st /// A host calls this to get the active language ID if provided by fsi-server-lcid member x.LCID = fsiOptions.FsiLCID -#if !FSI_SERVER +#if FX_NO_APP_DOMAINS member x.ReportUnhandledException (exn:exn) = ignore exn; () #else /// 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 @@ -2724,7 +2740,7 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st 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)) || ((IntPtr.Size = 8) && isWindows8Plus)) + if isFromThreadException && ((isWindows7 && (IntPtr.Size = 8) && isWindows8Plus)) #if DEBUG // for debug purposes && Environment.GetEnvironmentVariable("FSI_SCHEDULE_RESTART_WITH_ERRORS") = null @@ -2736,6 +2752,12 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st ) #endif + member x.PartialAssemblySignatureUpdated = fsiInteractionProcessor.PartialAssemblySignatureUpdated + + + member x.FormatValue(obj:obj, objTy) = + fsiDynamicCompiler.FormatValue(obj, objTy) + member x.EvalExpression(sourceText) = // Explanation: When the user of the FsiInteractiveSession object calls this method, the @@ -2746,6 +2768,17 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st fsiInteractionProcessor.EvalExpression(ctok, sourceText, dummyScriptFileName, errorLogger) |> commitResult + member x.EvalExpressionNonThrowing(sourceText) = + // 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 + // is not safe to call concurrently. + let ctok = AssumeCompilationThreadWithoutEvidence() + + let tcConfig = TcConfig.Create(tcConfigB,validate=false) + let errorLogger = CompilationErrorLogger("EvalInteraction",tcConfig) + fsiInteractionProcessor.EvalExpression(ctok, sourceText, dummyScriptFileName, errorLogger) + |> commitResultNonThrowing tcConfig dummyScriptFileName errorLogger + member x.EvalInteraction(sourceText) : unit = // 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 @@ -2756,6 +2789,18 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st |> commitResult |> ignore + member x.EvalInteractionNonThrowing(sourceText) = + // 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 + // is not safe to call concurrently. + let ctok = AssumeCompilationThreadWithoutEvidence() + + let tcConfig = TcConfig.Create(tcConfigB,validate=false) + let errorLogger = CompilationErrorLogger("EvalInteraction",tcConfig) + fsiInteractionProcessor.EvalInteraction(ctok, sourceText, dummyScriptFileName, errorLogger) + |> commitResultNonThrowing tcConfig "input.fsx" errorLogger + |> function Choice1Of2(_), errs -> Choice1Of2 (), errs | Choice2Of2 exn, errs -> Choice2Of2 exn, errs + member x.EvalScript(scriptPath) : unit = // 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 @@ -2766,6 +2811,18 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st |> commitResult |> ignore + member x.EvalScriptNonThrowing(scriptPath) = + // 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 + // is not safe to call concurrently. + let ctok = AssumeCompilationThreadWithoutEvidence() + + let tcConfig = TcConfig.Create(tcConfigB,validate=false) + let errorLogger = CompilationErrorLogger("EvalInteraction",tcConfig) + fsiInteractionProcessor.EvalScript(ctok, scriptPath, errorLogger) + |> commitResultNonThrowing tcConfig scriptPath errorLogger + |> function Choice1Of2(_), errs -> Choice1Of2 (), errs | Choice2Of2 exn, errs -> Choice2Of2 exn, errs + /// Performs these steps: /// - Load the dummy interaction, if any /// - Set up exception handling, if any @@ -2781,6 +2838,8 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st [] member x.Run() = + progress := condition "FSHARP_INTERACTIVE_PROGRESS" + // Explanation: When Run is called we do a bunch of processing. For fsi.exe // and fsiAnyCpu.exe there are no other active threads at this point, so we can assume this is the // unique compilation thread. For other users of FsiEvaluationSession it is reasonable to assume that @@ -2789,17 +2848,8 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st // We later switch to doing interaction-by-interaction processing on the "event loop" thread let ctokRun = AssumeCompilationThreadWithoutEvidence () - // Update the console completion function now we've got an initial type checking state. - // This means completion doesn't work until the initial type checking state has finished loading - fair enough! - match fsiConsoleInput.TryGetConsole() with - | Some console when fsiOptions.EnableConsoleKeyProcessing -> - console.SetCompletionFunction(fun (s1,s2) -> fsiIntellisenseProvider.CompletionsForPartialLID fsiInteractionProcessor.CurrentState (match s1 with | Some s -> s + "." + s2 | None -> s2) |> Seq.ofList) - | _ -> () - -#if FSI_SERVER if not runningOnMono && fsiOptions.IsInteractiveServer then - SpawnInteractiveServer (fsiOptions, fsiConsoleOutput, fsiInterruptController) -#endif + SpawnInteractiveServer (fsi, fsiOptions, fsiConsoleOutput) use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Interactive @@ -2824,25 +2874,6 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st | _ -> ()) #endif -#if !FX_NO_WINFORMS - if fsiOptions.Gui then - try - Application.EnableVisualStyles() - with _ -> - () - - // Route GUI application exceptions to the exception handlers - Application.add_ThreadException(new ThreadExceptionEventHandler(fun _ args -> x.ReportUnhandledException args.Exception)); - - if not runningOnMono then - try - TrySetUnhandledExceptionMode() - with _ -> - (); - - // This is the event loop for winforms - fsi.SetEventLoop (WinFormsEventLoop(fsiConsoleOutput, fsiOptions.FsiLCID)) -#endif fsiInteractionProcessor.LoadInitialFiles(ctokRun, errorLogger) fsiInteractionProcessor.StartStdinReadAndProcessThread(errorLogger) @@ -2859,10 +2890,14 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st // The Ctrl-C exception handler that we've passed to native code has // to be explicitly kept alive. GC.KeepAlive fsiInterruptController.EventHandlers - - static member GetDefaultConfiguration(fsiObj:obj) = - + + static member Create(fsiConfig, argv, inReader, outWriter, errorWriter, ?collectible, ?msbuildEnabled) = + new FsiEvaluationSession(fsiConfig, argv, inReader, outWriter, errorWriter, defaultArg collectible false, defaultArg msbuildEnabled true) + + static member GetDefaultConfiguration(fsiObj:obj) = FsiEvaluationSession.GetDefaultConfiguration(fsiObj, true) + + 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 @@ -2878,69 +2913,203 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st 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 __.SetEventLoop(v1,v2,v3) = callInstanceMethod3 fsiObj [| |] "SetEventLoop" (box v1) (box v2) (box v3) - } + member __.EventLoopScheduleRestart() = callInstanceMethod0 (getInstanceProperty fsiObj "EventLoop") [||] "ScheduleRestart" + member __.UseFsiAuxLib = useFsiAuxLib + member __.GetOptionalConsoleReadLine(_probe) = None } -// Mark the main thread as STAThread since it is a GUI thread -[] -[] -#if !FX_NO_LOADER_OPTIMIZATION -[] -#endif -let MainMain argv = - ignore argv - let argv = System.Environment.GetCommandLineArgs() - use e = new SaveAndRestoreConsoleEncoding() - let evaluateSession () = -#if !FX_REDUCED_CONSOLE - // When VFSI is running, set the input/output encoding to UTF8. - // Otherwise, unicode gets lost during redirection. - // It is required only under Net4.5 or above (with unicode console feature). - if FSharpEnvironment.IsRunningOnNetFx45OrAbove && - argv |> Array.exists (fun x -> x.Contains "fsi-server") then - Console.InputEncoding <- System.Text.Encoding.UTF8 - Console.OutputEncoding <- System.Text.Encoding.UTF8 -#endif +//------------------------------------------------------------------------------- +// If no "fsi" object for the configuration is specified, make the default +// configuration one which stores the settings in-process - let fsiObj = - let defaultFSharpBinariesDir = -#if FX_RESHAPED_REFLECTION - System.AppContext.BaseDirectory -#else - System.AppDomain.CurrentDomain.BaseDirectory -#endif - // We use LoadFrom to make sure we get the copy of this assembly from the right load context - let fsiAssemblyPath = Path.Combine(defaultFSharpBinariesDir,"FSharp.Compiler.Interactive.Settings.dll") - let fsiAssembly = FileSystem.AssemblyLoadFrom(fsiAssemblyPath) - if isNull fsiAssembly then failwith (sprintf "failed to load %s" fsiAssemblyPath) - let fsiTy = fsiAssembly.GetType("Microsoft.FSharp.Compiler.Interactive.Settings") - if isNull fsiAssembly then failwith "failed to find type Microsoft.FSharp.Compiler.Interactive.Settings in FSharp.Compiler.Interactive.Settings.dll" - callStaticMethod fsiTy "get_fsi" [ ] - let fsi = FsiEvaluationSession.GetDefaultConfiguration(fsiObj) - if argv |> Array.exists (fun x -> x = "/pause" || x = "--pause") then - Console.WriteLine("Press any key to continue...") - Console.ReadKey() |> ignore +module Settings = + type IEventLoop = + abstract Run : unit -> bool + abstract Invoke : (unit -> 'T) -> 'T + abstract ScheduleRestart : unit -> unit - try - let session = new FsiEvaluationSession (fsi, argv, Console.In, Console.Out, Console.Error) - session.Run() - with e -> printf "Exception by fsi.exe:\n%+A\n" e - -#if FSI_SHADOW_COPY_REFERENCES - let isShadowCopy x = (x = "/shadowcopyreferences" || x = "--shadowcopyreferences" || x = "/shadowcopyreferences+" || x = "--shadowcopyreferences+") - if AppDomain.CurrentDomain.IsDefaultAppDomain() && argv |> Array.exists isShadowCopy then - let setupInformation = AppDomain.CurrentDomain.SetupInformation - setupInformation.ShadowCopyFiles <- "true" - let helper = AppDomain.CreateDomain("FSI_Domain", null, setupInformation) - helper.ExecuteAssemblyByName(Assembly.GetExecutingAssembly().GetName()) |> ignore - else - evaluateSession() - 0 -#else - evaluateSession() - 0 -#endif + // fsi.fs in FSHarp.Compiler.Sevice.dll avoids a hard dependency on FSharp.Compiler.Interactive.Settings.dll + // by providing an optional reimplementation of the functionality + + // An implementation of IEventLoop suitable for the command-line console + [] + type internal SimpleEventLoop() = + 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 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 x.Invoke(f : unit -> 'T) : 'T = + queue <- [f >> box] + setSignal runSignal + waitSignal doneSignal + result.Value |> unbox + member x.ScheduleRestart() = + if running then + restart <- true + setSignal exitSignal + interface System.IDisposable with + member x.Dispose() = + runSignal.Dispose() + exitSignal.Dispose() + doneSignal.Dispose() + + + + [] + type InteractiveSettings() = + let mutable evLoop = (new SimpleEventLoop() :> IEventLoop) + let mutable showIDictionary = true + let mutable showDeclarationValues = true + let mutable args = Environment.GetCommandLineArgs() + let mutable fpfmt = "g10" + let mutable fp = (CultureInfo.InvariantCulture :> System.IFormatProvider) + let mutable printWidth = 78 + let mutable printDepth = 100 + let mutable printLength = 100 + let mutable printSize = 10000 + let mutable showIEnumerable = true + 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 __.EventLoop + 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 + + let fsi = InteractiveSettings() + +type FsiEvaluationSession with + static member GetDefaultConfiguration() = + FsiEvaluationSession.GetDefaultConfiguration(Settings.fsi, false) + +/// Defines a read-only input stream used to feed content to the hosted F# Interactive dynamic compiler. +[] +type CompilerInputStream() = + inherit Stream() + // Duration (in milliseconds) of the pause in the loop of waitForAtLeastOneByte. + let pauseDuration = 100 + + // Queue of characters waiting to be read. + let readQueue = new Queue() + + 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 -> System.Threading.Thread.Sleep(pauseDuration); loop() + | Some res -> res + 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.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.Read(buffer, offset, count) = + let bytes = waitForAtLeastOneByte count + Array.Copy(bytes, 0, buffer, offset, bytes.Length) + bytes.Length + + /// Feeds content into the stream. + member x.Add(str:string) = + if (System.String.IsNullOrEmpty(str)) then () else + + lock readQueue (fun () -> + let bytes = System.Text.Encoding.UTF8.GetBytes(str) + 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() = + inherit Stream() + // Queue of characters waiting to be read. + let contentQueue = new Queue() + 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.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.Write(buffer, offset, count) = + let stop = offset + count + if (stop > buffer.Length) then raise (ArgumentException("offset,count")) + + lock contentQueue (fun () -> + for i in offset .. stop - 1 do + contentQueue.Enqueue(buffer.[i])) + + member x.Read() = + lock contentQueue (fun () -> + let n = contentQueue.Count + if (n > 0) then + let bytes = Array.zeroCreate n + for i in 0 .. n-1 do + bytes.[i] <- contentQueue.Dequeue() + + System.Text.Encoding.UTF8.GetString(bytes, 0, n) + else + "") + diff --git a/src/fsharp/fsi/fsi.fsi b/src/fsharp/fsi/fsi.fsi new file mode 100644 index 00000000000..dc7a2568f43 --- /dev/null +++ b/src/fsharp/fsi/fsi.fsi @@ -0,0 +1,344 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + + +#if COMPILER_PUBLIC_API +module Microsoft.FSharp.Compiler.Interactive.Shell +#else +module internal Microsoft.FSharp.Compiler.Interactive.Shell +#endif + +open System.IO +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.SourceCodeServices + +[] +/// Represents an evaluated F# value +type FsiValue = + /// The value, as an object + member ReflectionValue : obj + /// The type of the value, from the point of view of the .NET type system + member ReflectionType : System.Type +#if COMPILER_API + /// The type of the value, from the point of view of the F# type system + member FSharpType : FSharpType +#endif + +#if COMPILER_SERVICE_AS_DLL +[] +type EvaluationEventArgs = + inherit System.EventArgs + + /// The display name of the symbol defined + member Name : string + + /// The value of the symbol defined, if any + member FsiValue : FsiValue option + + /// The FSharpSymbolUse for the symbol defined + member SymbolUse : FSharpSymbolUse + + /// The symbol defined + member Symbol : FSharpSymbol + + /// The details of the expression defined + member ImplementationDeclaration : FSharpImplementationFileDeclaration +#endif + +[] +type public FsiEvaluationSessionHostConfig = + new : unit -> FsiEvaluationSessionHostConfig + /// Called by the evaluation session to ask the host for parameters to format text for output + abstract FormatProvider: System.IFormatProvider + /// Called by the evaluation session to ask the host for parameters to format text for output + abstract FloatingPointFormat: string + /// Called by the evaluation session to ask the host for parameters to format text for output + abstract AddedPrinters : Choice<(System.Type * (obj -> string)), (System.Type * (obj -> obj))> list + /// Called by the evaluation session to ask the host for parameters to format text for output + abstract ShowDeclarationValues: bool + /// Called by the evaluation session to ask the host for parameters to format text for output + abstract ShowIEnumerable: bool + /// Called by the evaluation session to ask the host for parameters to format text for output + abstract ShowProperties : bool + /// Called by the evaluation session to ask the host for parameters to format text for output + abstract PrintSize : int + /// Called by the evaluation session to ask the host for parameters to format text for output + abstract PrintDepth : int + /// Called by the evaluation session to ask the host for parameters to format text for output + abstract PrintWidth : int + /// Called by the evaluation session to ask the host for parameters to format text for output + 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 + +#if COMPILER_SERVICE_AS_DLL + /// Hook for listening for evaluation bindings + member OnEvaluation : IEvent +#endif + + + /// + /// Indicate a special console "readline" reader for the evaluation session, if any.  + /// + /// A "console" gets used if --readline is specified (the default on Windows + .NET); and --fsi-server is not + /// given (always combine with --readline-), and OptionalConsoleReadLine is given. + /// When a console is used, special rules apply to "peekahead", which allows early typing on the console. + /// Peekahead happens if --peekahead- is not specified (the default). + /// In this case, a prompt is printed early, a background thread is created and + /// the OptionalConsoleReadLine is used to read the first line. + /// If a console is not used, then inReader.Peek() is called early instead. + ///   + /// + /// Further lines are read using OptionalConsoleReadLine(). + /// If not provided, lines are read using inReader.ReadLine(). + ///   + /// + + 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 + + /// 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 + + /// Request that the given operation be run synchronously on the event loop. + abstract EventLoopInvoke : codeToRun: (unit -> 'T) -> 'T + + /// Schedule a restart for the event loop. + abstract EventLoopScheduleRestart : unit -> unit + + /// Implicitly reference FSharp.Compiler.Interactive.Settings.dll + abstract UseFsiAuxLib : bool + + +/// Represents an F# Interactive evaluation session. +[] +type FsiEvaluationSession = + + interface System.IDisposable + + /// Create an FsiEvaluationSession, reading from the given text input, writing to the given text output and error writers. + /// + /// Create an FsiEvaluationSession, reading from the given text input, writing to the given text output and error writers + /// + /// The dynamic configuration of the evaluation session + /// The commmand line arguments for the evaluation session + /// Read input from the given reader + /// Write output to the given writer + /// Optionally make the dynamic assmbly for the session collectible + static member Create : fsiConfig: FsiEvaluationSessionHostConfig * argv:string[] * inReader:TextReader * outWriter:TextWriter * errorWriter: TextWriter * ?collectible: bool * ?msbuildEnabled: bool -> FsiEvaluationSession + + /// A host calls this to request an interrupt on the evaluation thread. + member Interrupt : unit -> unit + + /// A host calls this to get the completions for a long identifier, e.g. in the console + /// + /// Due to a current limitation, it is not fully thread-safe to run this operation concurrently with evaluation triggered + /// by input from 'stdin'. + member GetCompletions : longIdent: string -> seq + +#if COMPILER_SERVICE + /// Execute the code as if it had been entered as one or more interactions, with an + /// implicit termination at the end of the input. Stop on first error, discarding the rest + /// of the input. Errors are sent to the output writer, a 'true' return value indicates there + /// were no errors overall. Execution is performed on the 'Run()' thread. + /// + /// Due to a current limitation, it is not fully thread-safe to run this operation concurrently with evaluation triggered + /// by input from 'stdin'. + member EvalInteraction : code: string -> unit + + /// Execute the code as if it had been entered as one or more interactions, with an + /// implicit termination at the end of the input. Stop on first error, discarding the rest + /// of the input. Errors and warnings are collected apart from any exception arising from execution + /// which is returned via a Choice. Execution is performed on the 'Run()' thread. + /// + /// Due to a current limitation, it is not fully thread-safe to run this operation concurrently with evaluation triggered + /// by input from 'stdin'. + member EvalInteractionNonThrowing : code: string -> Choice * FSharpErrorInfo[] + + /// Execute the given script. Stop on first error, discarding the rest + /// of the script. Errors are sent to the output writer, a 'true' return value indicates there + /// were no errors overall. Execution is performed on the 'Run()' thread. + /// + /// Due to a current limitation, it is not fully thread-safe to run this operation concurrently with evaluation triggered + /// by input from 'stdin'. + member EvalScript : filePath: string -> unit + + /// Execute the given script. Stop on first error, discarding the rest + /// of the script. Errors and warnings are collected apart from any exception arising from execution + /// which is returned via a Choice. Execution is performed on the 'Run()' thread. + /// + /// Due to a current limitation, it is not fully thread-safe to run this operation concurrently with evaluation triggered + /// by input from 'stdin'. + member EvalScriptNonThrowing : filePath: string -> Choice * FSharpErrorInfo[] + + /// Execute the code as if it had been entered as one or more interactions, with an + /// implicit termination at the end of the input. Stop on first error, discarding the rest + /// of the input. Errors are sent to the output writer. Parsing is performed on the current thread, and execution is performed + /// sycnhronously on the 'main' thread. + /// + /// Due to a current limitation, it is not fully thread-safe to run this operation concurrently with evaluation triggered + /// by input from 'stdin'. + member EvalExpression : code: string -> FsiValue option + + /// Execute the code as if it had been entered as one or more interactions, with an + /// implicit termination at the end of the input. Stop on first error, discarding the rest + /// of the input. Errors and warnings are collected apart from any exception arising from execution + /// which is returned via a Choice. Parsing is performed on the current thread, and execution is performed + /// sycnhronously on the 'main' thread. + /// + /// Due to a current limitation, it is not fully thread-safe to run this operation concurrently with evaluation triggered + /// by input from 'stdin'. + member EvalExpressionNonThrowing : code: string -> Choice * FSharpErrorInfo[] + + /// Format a value to a string using the current PrintDepth, PrintLength etc settings provided by the active fsi configuration object + member FormatValue : reflectionValue: obj * reflectionType: System.Type -> string + + /// Raised when an interaction is successfully typechecked and executed, resulting in an update to the + /// type checking state. + /// + /// This event is triggered after parsing and checking, either via input from 'stdin', or via a call to EvalInteraction. + member PartialAssemblySignatureUpdated : IEvent + + /// Typecheck the given script fragment in the type checking context implied by the current state + /// of F# Interactive. The results can be used to access intellisense, perform resolutions, + /// check brace matching and other information. + /// + /// Operations may be run concurrently with other requests to the InteractiveChecker. + /// + /// Due to a current limitation, it is not fully thread-safe to run this operation concurrently with evaluation triggered + /// by input from 'stdin'. + member ParseAndCheckInteraction : code: string -> Async + + /// The single, global interactive checker to use in conjunction with other operations + /// on the FsiEvaluationSession. + /// + /// If you are using an FsiEvaluationSession in this process, you should only use this InteractiveChecker + /// for additional checking operations. + member InteractiveChecker: FSharpChecker + +#endif + + /// Get a handle to the resolved view of the current signature of the incrementally generated assembly. + member CurrentPartialAssemblySignature : FSharpAssemblySignature + + /// Get a handle to the dynamicly generated assembly + member DynamicAssembly : System.Reflection.Assembly + + /// A host calls this to determine if the --gui parameter is active + member IsGui : bool + + /// A host calls this to get the active language ID if provided by fsi-server-lcid + member LCID : int option + + /// 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 ReportUnhandledException : exn: exn -> unit + + /// Load the dummy interaction, load the initial files, and, + /// if interacting, start the background thread to read the standard input. + /// + /// Performs these steps: + /// - Load the dummy interaction, if any + /// - Set up exception handling, if any + /// - Load the initial files, if any + /// - Start the background thread to read the standard input, if any + /// - Sit in the GUI event loop indefinitely, if needed + + member Run : unit -> unit + + /// Get a configuration that uses the 'fsi' object (normally from FSharp.Compiler.Interactive.Settings.dll, + /// an object from another DLL with identical characteristics) to provide an implementation of the configuration. + /// The flag indicates if FSharp.Compiler.Interactive.Settings.dll is referenced by default. + static member GetDefaultConfiguration: fsiObj: obj * useFsiAuxLib: bool -> FsiEvaluationSessionHostConfig + + /// Get a configuration that uses the 'fsi' object (normally from FSharp.Compiler.Interactive.Settings.dll, + /// an object from another DLL with identical characteristics) to provide an implementation of the configuration. + /// FSharp.Compiler.Interactive.Settings.dll is referenced by default. + static member GetDefaultConfiguration: fsiObj: obj -> FsiEvaluationSessionHostConfig + + /// Get a configuration that uses a private inbuilt implementation of the 'fsi' object and does not + /// implicitly reference FSharp.Compiler.Interactive.Settings.dll. + static member GetDefaultConfiguration: unit -> FsiEvaluationSessionHostConfig + + +/// A default implementation of the 'fsi' object, used by GetDefaultConfiguration() +module Settings = + /// An event loop used by the currently executing F# Interactive session to execute code + /// in the context of a GUI or another event-based system. + type IEventLoop = + /// Run the event loop. + /// True if the event loop was restarted; false otherwise. + abstract Run : unit -> bool + /// Request that the given operation be run synchronously on the event loop. + /// The result of the operation. + abstract Invoke : (unit -> 'T) -> 'T + /// Schedule a restart for the event loop. + abstract ScheduleRestart : unit -> unit + +#if COMPILER_SERVICE_AS_DLL + [] + /// Operations supported by the currently executing F# Interactive session. + type InteractiveSettings = + /// Get or set the floating point format used in the output of the interactive session. + member FloatingPointFormat: string with get,set + /// Get or set the format provider used in the output of the interactive session. + member FormatProvider: System.IFormatProvider with get,set + /// Get or set the print width of the interactive session. + member PrintWidth : int with get,set + /// Get or set the print depth of the interactive session. + member PrintDepth : int with get,set + /// Get or set the total print length of the interactive session. + member PrintLength : int with get,set + /// Get or set the total print size of the interactive session. + member PrintSize : int with get,set + /// When set to 'false', disables the display of properties of evaluated objects in the output of the interactive session. + member ShowProperties : bool with get,set + /// When set to 'false', disables the display of sequences in the output of the interactive session. + member ShowIEnumerable: bool with get,set + /// When set to 'false', disables the display of declaration values in the output of the interactive session. + member ShowDeclarationValues: bool with get,set + /// Register a printer that controls the output of the interactive session. + member AddPrinter: ('T -> string) -> unit + /// Register a print transformer that controls the output of the interactive session. + member AddPrintTransformer: ('T -> obj) -> unit + + member internal AddedPrinters : Choice<(System.Type * (obj -> string)), + (System.Type * (obj -> obj))> list + + + /// The command line arguments after ignoring the arguments relevant to the interactive + /// environment and replacing the first argument with the name of the last script file, + /// if any. Thus 'fsi.exe test1.fs test2.fs -- hello goodbye' will give arguments + /// 'test2.fs', 'hello', 'goodbye'. This value will normally be different to those + /// returned by System.Environment.GetCommandLineArgs. + member CommandLineArgs : string [] with get,set + + /// Gets or sets a the current event loop being used to process interactions. + member EventLoop: IEventLoop with get,set + + /// A default implementation of the 'fsi' object, used by GetDefaultConfiguration(). Note this + /// is a different object to FSharp.Compiler.Interactive.Settings.fsi in FSharp.Compiler.Interactive.Settings.dll, + /// which can be used as an alternative implementation of the interactiev settings if passed as a parameter + /// to GetDefaultConfiguration(fsiObj). + val fsi : InteractiveSettings + +/// Defines a read-only input stream used to feed content to the hosted F# Interactive dynamic compiler. +[] +type CompilerInputStream = + inherit Stream + new : unit -> CompilerInputStream + /// Feeds content into the stream. + member Add: str:string -> unit + +/// Defines a write-only stream used to capture output of the hosted F# Interactive dynamic compiler. +[] +type CompilerOutputStream = + inherit Stream + new : unit -> CompilerOutputStream + + member Read : unit -> string +#endif diff --git a/src/fsharp/fsi/fsimain.fs b/src/fsharp/fsi/fsimain.fs new file mode 100644 index 00000000000..168afce9b7a --- /dev/null +++ b/src/fsharp/fsi/fsimain.fs @@ -0,0 +1,338 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + + +// This file provides the actual entry point for fsi.exe. +// +// Configure the F# Interactive Session to +// 1. use a WinForms event loop (introduces a System.Windows.Forms.dll dependency) +// 2. provide a remoting connection for the use of editor-hosted sessions (introduces a System.Remoting dependency) +// 3. connect the configuration to the global state programmer-settable settings in FSharp.Compiler.Interactive.Settings.dll +// 4. implement shadow copy of references + +module internal Sample.Microsoft.FSharp.Compiler.Interactive.Main + +open System +open System.Globalization +open System.IO +open System.Reflection +open System.Threading +open System.Runtime.CompilerServices +#if !FX_NO_WINFORMS +open System.Windows.Forms +#endif + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.Interactive.Shell +open Microsoft.FSharp.Compiler.Interactive +open Microsoft.FSharp.Compiler.Interactive.Shell.Settings + +#if FX_RESHAPED_REFLECTION +open Microsoft.FSharp.Core.ReflectionAdapters +#endif + +#nowarn "55" +#nowarn "40" // let rec on value 'fsiConfig' + + + +// Hardbinding dependencies should we NGEN fsi.exe +#if !FX_NO_DEFAULT_DEPENDENCY_TYPE +[] do () +[] do () +#endif + +// Standard attributes +[] +[] +do() + + +/// Set the current ui culture for the current thread. +#if FX_LCIDFROMCODEPAGE +let internal SetCurrentUICultureForThread (lcid : int option) = + let culture = Thread.CurrentThread.CurrentUICulture + match lcid with + | Some n -> Thread.CurrentThread.CurrentUICulture <- new CultureInfo(n) + | None -> () + { new IDisposable with member x.Dispose() = Thread.CurrentThread.CurrentUICulture <- culture } +#endif + +let callStaticMethod (ty:Type) name args = + ty.InvokeMember(name, (BindingFlags.InvokeMethod ||| BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic), null, null, Array.ofList args,Globalization.CultureInfo.InvariantCulture) + +#if !FX_NO_WINFORMS +///Use a dummy to access protected member +type internal DummyForm() = + inherit Form() + member x.DoCreateHandle() = x.CreateHandle() + /// Creating the dummy form object can crash on Mono Mac, and then prints a nasty background + /// error during finalization of the half-initialized object... + override x.Finalize() = () + +/// This is the event loop implementation for winforms +type WinFormsEventLoop() = + let mainForm = new DummyForm() + do mainForm.DoCreateHandle() + let mutable lcid = None + // Set the default thread exception handler + let restart = ref false + member __.LCID with get () = lcid and set v = lcid <- v + interface IEventLoop with + member x.Run() = + restart := false + Application.Run() + !restart + member x.Invoke (f: unit -> 'T) : 'T = + if not mainForm.InvokeRequired then + f() + else + + // Workaround: Mono's Control.Invoke returns a null result. Hence avoid the problem by + // transferring the resulting state using a mutable location. + let mainFormInvokeResultHolder = ref None + + // Actually, Mono's Control.Invoke isn't even blocking (or wasn't on 1.1.15)! So use a signal to indicate completion. + // Indeed, we should probably do this anyway with a timeout so we can report progress from + // the GUI thread. + use doneSignal = new AutoResetEvent(false) + + + // BLOCKING: This blocks the stdin-reader thread until the + // form invocation has completed. NOTE: does not block on Mono, or did not on 1.1.15 + mainForm.Invoke(new MethodInvoker(fun () -> + try + // When we get called back, someone may jack our culture + // So we must reset our UI culture every time +#if FX_LCIDFROMCODEPAGE + use _scope = SetCurrentUICultureForThread lcid +#else + ignore lcid +#endif + mainFormInvokeResultHolder := Some(f ()) + finally + doneSignal.Set() |> ignore)) |> ignore + + //if !progress then fprintfn outWriter "RunCodeOnWinFormsMainThread: Waiting for completion signal...." + while not (doneSignal.WaitOne(new TimeSpan(0,0,1),true)) do + () // if !progress then fprintf outWriter "." outWriter.Flush() + + //if !progress then fprintfn outWriter "RunCodeOnWinFormsMainThread: Got completion signal, res = %b" (Option.isSome !mainFormInvokeResultHolder) + !mainFormInvokeResultHolder |> Option.get + + member x.ScheduleRestart() = restart := true; Application.Exit() + +/// Try to set the unhandled exception mode of System.Windows.Forms +let internal TrySetUnhandledExceptionMode() = + let i = ref 0 // stop inlining + try + Application.SetUnhandledExceptionMode(UnhandledExceptionMode.CatchException) + with _ -> + decr i;() + +#endif + +/// Starts the remoting server to handle interrupt reuests from a host tool. +let StartServer (fsiSession : FsiEvaluationSession) (fsiServerName) = +#if FSI_SERVER + let server = + {new Server.Shared.FSharpInteractiveServer() with + member this.Interrupt() = + //printf "FSI-SERVER: received CTRL-C request...\n" + try + fsiSession.Interrupt() + with e -> + // Final sanity check! - catch all exns - but not expected + assert false + () + } + + Server.Shared.FSharpInteractiveServer.StartServer(fsiServerName,server) +#else + ignore (fsiSession, fsiServerName) +#endif + +//---------------------------------------------------------------------------- +// GUI runCodeOnMainThread +//---------------------------------------------------------------------------- + +let evaluateSession(argv: string[]) = +#if DEBUG + if argv |> Array.exists (fun x -> x = "/pause" || x = "--pause") then + Console.WriteLine("Press any key to continue...") + Console.ReadKey() |> ignore +#endif + +#if !FX_REDUCED_CONSOLE + // When VFSI is running, set the input/output encoding to UTF8. + // Otherwise, unicode gets lost during redirection. + // It is required only under Net4.5 or above (with unicode console feature). + if argv |> Array.exists (fun x -> x.Contains "fsi-server") then + Console.InputEncoding <- System.Text.Encoding.UTF8 + Console.OutputEncoding <- System.Text.Encoding.UTF8 +#else + ignore argv +#endif + + try + // Create the console reader + let console = new Microsoft.FSharp.Compiler.Interactive.ReadLineConsole() + + // Define the function we pass to the FsiEvaluationSession + let getConsoleReadLine (probeToSeeIfConsoleWorks) = + let consoleIsOperational = + if probeToSeeIfConsoleWorks then + //if progress then fprintfn outWriter "probing to see if console works..." + try + // Probe to see if the console looks functional on this version of .NET + let _ = Console.KeyAvailable + let _ = Console.ForegroundColor + let _ = Console.CursorLeft <- Console.CursorLeft + true + with _ -> + //if progress then fprintfn outWriter "probe failed, we have no console..." + false + else true + if consoleIsOperational then + Some (fun () -> console.ReadLine()) + else + None + +//#if USE_FSharp_Compiler_Interactive_Settings + let fsiObjOpt = + let defaultFSharpBinariesDir = +#if FX_RESHAPED_REFLECTION + System.AppContext.BaseDirectory +#else + System.AppDomain.CurrentDomain.BaseDirectory +#endif + // We use LoadFrom to make sure we get the copy of this assembly from the right load context + let fsiAssemblyPath = Path.Combine(defaultFSharpBinariesDir,"FSharp.Compiler.Interactive.Settings.dll") + let fsiAssembly = Assembly.LoadFrom(fsiAssemblyPath) + if isNull fsiAssembly then + None + else + let fsiTy = fsiAssembly.GetType("Microsoft.FSharp.Compiler.Interactive.Settings") + if isNull fsiAssembly then failwith "failed to find type Microsoft.FSharp.Compiler.Interactive.Settings in FSharp.Compiler.Interactive.Settings.dll" + Some (callStaticMethod fsiTy "get_fsi" [ ]) + + let fsiConfig0 = + match fsiObjOpt with + | None -> FsiEvaluationSession.GetDefaultConfiguration() + | Some fsiObj -> FsiEvaluationSession.GetDefaultConfiguration(fsiObj, true) + +//fsiSession.LCID +#if !FX_NO_WINFORMS + // Create the WinForms event loop + let fsiWinFormsLoop = + lazy + try Some (WinFormsEventLoop()) + with e -> + printfn "Your system doesn't seem to support WinForms correctly. You will" + printfn "need to set fsi.EventLoop use GUI windows from F# Interactive." + printfn "You can set different event loops for MonoMac, Gtk#, WinForms and other" + printfn "UI toolkits. Drop the --gui argument if no event loop is required." + None +#endif + + // Update the configuration to include 'StartServer', WinFormsEventLoop and 'GetOptionalConsoleReadLine()' + let rec fsiConfig = + { new FsiEvaluationSessionHostConfig () with + member __.FormatProvider = fsiConfig0.FormatProvider + member __.FloatingPointFormat = fsiConfig0.FloatingPointFormat + member __.AddedPrinters = fsiConfig0.AddedPrinters + member __.ShowDeclarationValues = fsiConfig0.ShowDeclarationValues + member __.ShowIEnumerable = fsiConfig0.ShowIEnumerable + member __.ShowProperties = fsiConfig0.ShowProperties + member __.PrintSize = fsiConfig0.PrintSize + member __.PrintDepth = fsiConfig0.PrintDepth + member __.PrintWidth = fsiConfig0.PrintWidth + member __.PrintLength = fsiConfig0.PrintLength + member __.ReportUserCommandLineArgs args = fsiConfig0.ReportUserCommandLineArgs args + member __.EventLoopRun() = +#if !FX_NO_WINFORMS + match fsiWinFormsLoop.Value with + | Some l -> (l :> IEventLoop).Run() + | _ -> +#endif + fsiConfig0.EventLoopRun() + member __.EventLoopInvoke(f) = +#if !FX_NO_WINFORMS + match fsiWinFormsLoop.Value with + | Some l -> (l :> IEventLoop).Invoke(f) + | _ -> +#endif + fsiConfig0.EventLoopInvoke(f) + member __.EventLoopScheduleRestart() = +#if !FX_NO_WINFORMS + match fsiWinFormsLoop.Value with + | Some l -> (l :> IEventLoop).ScheduleRestart() + | _ -> +#endif + fsiConfig0.EventLoopScheduleRestart() + + member __.UseFsiAuxLib = fsiConfig0.UseFsiAuxLib + + member __.StartServer(fsiServerName) = StartServer fsiSession fsiServerName + + // Connect the configuration through to the 'fsi' Event loop + member __.GetOptionalConsoleReadLine(probe) = getConsoleReadLine(probe) } + + // Create the console + and fsiSession = FsiEvaluationSession.Create (fsiConfig, argv, Console.In, Console.Out, Console.Error) + + +#if !FX_NO_WINFORMS + // Configure some remaining parameters of the GUI support + if fsiSession.IsGui then + try + Application.EnableVisualStyles() + with _ -> + () + + // Route GUI application exceptions to the exception handlers + Application.add_ThreadException(new ThreadExceptionEventHandler(fun _ args -> fsiSession.ReportUnhandledException args.Exception)); + + let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e-> false + if not runningOnMono then + try + TrySetUnhandledExceptionMode() + with _ -> + () + + fsiWinFormsLoop.Value |> Option.iter (fun l -> l.LCID <- fsiSession.LCID) +#endif + + // Setup the completion function for intellisense in the console + console.SetCompletionFunction(fun (s1,s2) -> fsiSession.GetCompletions (match s1 with | Some s -> s + "." + s2 | None -> s2)) + + // Start the session + fsiSession.Run() + + with e -> printf "Exception by fsi.exe:\n%+A\n" e + + 0 + +// Mark the main thread as STAThread since it is a GUI thread +[] +[] +#if !FX_NO_LOADER_OPTIMIZATION +[] +#endif +let MainMain argv = + ignore argv + let argv = System.Environment.GetCommandLineArgs() + use e = new SaveAndRestoreConsoleEncoding() + +#if FSI_SHADOW_COPY_REFERENCES + let isShadowCopy x = (x = "/shadowcopyreferences" || x = "--shadowcopyreferences" || x = "/shadowcopyreferences+" || x = "--shadowcopyreferences+") + if AppDomain.CurrentDomain.IsDefaultAppDomain() && argv |> Array.exists isShadowCopy then + let setupInformation = AppDomain.CurrentDomain.SetupInformation + setupInformation.ShadowCopyFiles <- "true" + let helper = AppDomain.CreateDomain("FSI_Domain", null, setupInformation) + helper.ExecuteAssemblyByName(Assembly.GetExecutingAssembly().GetName()) + else + evaluateSession(argv) +#else + evaluateSession(argv) +#endif diff --git a/src/fsharp/fsiAnyCpu/FsiAnyCPU.fsproj b/src/fsharp/fsiAnyCpu/FsiAnyCPU.fsproj index 778af8d0912..4f6c473816b 100644 --- a/src/fsharp/fsiAnyCpu/FsiAnyCPU.fsproj +++ b/src/fsharp/fsiAnyCpu/FsiAnyCPU.fsproj @@ -13,7 +13,10 @@ $(NoWarn);62 fsiAnyCpu 0x0A000000 - EXTENSIONTYPING;COMPILER;$(DefineConstants) + EXTENSIONTYPING;$(DefineConstants) + COMPILER;$(DefineConstants) + FSI_SHADOW_COPY_REFERENCES;$(DefineConstants) + FSI_SERVER;$(DefineConstants) true $(OtherFlags) --warnon:1182 ..\fsi\fsi.res @@ -27,27 +30,12 @@ false - - - - - FSIstrings.txt - assemblyinfo.fsi.exe.fs - - InternalCollections.fsi - - - InternalCollections.fs - - - console.fs - - - fsi.fs + + fsimain.fs PreserveNewest diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 95e48fd89ca..a2e06a21227 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -1646,7 +1646,6 @@ type ILFieldInfo = | ProvidedField(_,fi1,_), ProvidedField(_,fi2,_)-> ProvidedFieldInfo.TaintedEquals (fi1, fi2) | _ -> false #endif - /// Get an (uninstantiated) reference to the field as an Abstract IL ILFieldRef member x.ILFieldRef = rescopeILFieldRef x.ScopeRef (mkILFieldRef(x.ILTypeRef,x.FieldName,x.ILFieldType)) override x.ToString() = x.FieldName diff --git a/src/fsharp/layout.fs b/src/fsharp/layout.fs index bb2d7e577d5..3ed5dd52c52 100644 --- a/src/fsharp/layout.fs +++ b/src/fsharp/layout.fs @@ -1,6 +1,6 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. -module internal Microsoft.FSharp.Compiler.Layout +module Microsoft.FSharp.Compiler.Layout open System open System.Collections.Generic @@ -10,9 +10,15 @@ open Microsoft.FSharp.Core.Printf #nowarn "62" // This construct is for ML compatibility. +#if COMPILER_PUBLIC_API type layout = Internal.Utilities.StructuredFormat.Layout type LayoutTag = Internal.Utilities.StructuredFormat.LayoutTag type TaggedText = Internal.Utilities.StructuredFormat.TaggedText +#else +type internal layout = Internal.Utilities.StructuredFormat.Layout +type internal LayoutTag = Internal.Utilities.StructuredFormat.LayoutTag +type internal TaggedText = Internal.Utilities.StructuredFormat.TaggedText +#endif type NavigableTaggedText(taggedText: TaggedText, range: Range.range) = member val Range = range diff --git a/src/fsharp/layout.fsi b/src/fsharp/layout.fsi index ee9d63ba56e..4b44df31378 100644 --- a/src/fsharp/layout.fsi +++ b/src/fsharp/layout.fsi @@ -1,6 +1,10 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. +#if COMPILER_PUBLIC_API +module Microsoft.FSharp.Compiler.Layout +#else module internal Microsoft.FSharp.Compiler.Layout +#endif open System.Text open System.Collections.Generic diff --git a/src/fsharp/range.fs b/src/fsharp/range.fs index c4ccf969976..fe027d94168 100755 --- a/src/fsharp/range.fs +++ b/src/fsharp/range.fs @@ -1,7 +1,7 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. /// Anything to do with special names of identifiers and other lexical rules -module internal Microsoft.FSharp.Compiler.Range +module Microsoft.FSharp.Compiler.Range open System.IO open System.Collections.Generic diff --git a/src/fsharp/range.fsi b/src/fsharp/range.fsi index 07e2abd4c29..6fd76f725ed 100755 --- a/src/fsharp/range.fsi +++ b/src/fsharp/range.fsi @@ -1,6 +1,10 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. +#if COMPILER_PUBLIC_API +module Microsoft.FSharp.Compiler.Range +#else module internal Microsoft.FSharp.Compiler.Range +#endif open System.Text open System.Collections.Generic diff --git a/src/fsharp/symbols/Exprs.fs b/src/fsharp/symbols/Exprs.fs new file mode 100644 index 00000000000..e7752ac49f1 --- /dev/null +++ b/src/fsharp/symbols/Exprs.fs @@ -0,0 +1,1146 @@ +// Copyright (c) Microsoft Corpration, Inc. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Compiler.SourceCodeServices + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.QuotationTranslator +open Microsoft.FSharp.Compiler.TypeRelations +open Internal.Utilities + +[] +module ExprTranslationImpl = + + let nonNil x = not (List.isEmpty x) + + type ExprTranslationEnv = + { //Map from Val to binding index + vs: ValMap; + //Map from typar stamps to binding index + tyvs: StampMap; + // Map for values bound by the + // 'let v = isinst e in .... if nonnull v then ...v .... ' + // construct arising out the compilation of pattern matching. We decode these back to the form + // 'if istype v then ...unbox v .... ' + isinstVals: ValMap + substVals: ValMap } + + static member Empty = + { vs=ValMap<_>.Empty; + tyvs = Map.empty ; + isinstVals = ValMap<_>.Empty + substVals = ValMap<_>.Empty } + + member env.BindTypar (v:Typar, gp) = + { env with tyvs = env.tyvs.Add(v.Stamp,gp ) } + + member env.BindTypars vs = + (env, vs) ||> List.fold (fun env v -> env.BindTypar v) // fold left-to-right because indexes are left-to-right + + member env.BindVal v = + { env with vs = env.vs.Add v () } + + member env.BindIsInstVal v (ty,e) = + { env with isinstVals = env.isinstVals.Add v (ty,e) } + + member env.BindSubstVal v e = + { env with substVals = env.substVals.Add v e } + + member env.BindVals vs = (env,vs) ||> List.fold (fun env v -> env.BindVal v) + member env.BindCurriedVals vsl = (env,vsl) ||> List.fold (fun env vs -> env.BindVals vs) + + exception IgnoringPartOfQuotedTermWarning of string * Range.range + + let wfail (msg,m:range) = failwith (msg + sprintf " at %s" (m.ToString())) + + +/// The core tree of data produced by converting F# compiler TAST expressions into the form which we make available through the compiler API +/// through active patterns. +type E = + | Value of FSharpMemberOrFunctionOrValue + | ThisValue of FSharpType + | BaseValue of FSharpType + | Application of FSharpExpr * FSharpType list * FSharpExpr list + | Lambda of FSharpMemberOrFunctionOrValue * FSharpExpr + | TypeLambda of FSharpGenericParameter list * FSharpExpr + | Quote of FSharpExpr + | IfThenElse of FSharpExpr * FSharpExpr * FSharpExpr + | DecisionTree of FSharpExpr * (FSharpMemberOrFunctionOrValue list * FSharpExpr) list + | DecisionTreeSuccess of int * FSharpExpr list + | Call of FSharpExpr option * FSharpMemberOrFunctionOrValue * FSharpType list * FSharpType list * FSharpExpr list + | NewObject of FSharpMemberOrFunctionOrValue * FSharpType list * FSharpExpr list + | LetRec of ( FSharpMemberOrFunctionOrValue * FSharpExpr) list * FSharpExpr + | Let of (FSharpMemberOrFunctionOrValue * FSharpExpr) * FSharpExpr + | NewRecord of FSharpType * FSharpExpr list + | ObjectExpr of FSharpType * FSharpExpr * FSharpObjectExprOverride list * (FSharpType * FSharpObjectExprOverride list) list + | FSharpFieldGet of FSharpExpr option * FSharpType * FSharpField + | FSharpFieldSet of FSharpExpr option * FSharpType * FSharpField * FSharpExpr + | NewUnionCase of FSharpType * FSharpUnionCase * FSharpExpr list + | UnionCaseGet of FSharpExpr * FSharpType * FSharpUnionCase * FSharpField + | UnionCaseSet of FSharpExpr * FSharpType * FSharpUnionCase * FSharpField * FSharpExpr + | UnionCaseTag of FSharpExpr * FSharpType + | UnionCaseTest of FSharpExpr * FSharpType * FSharpUnionCase + | TraitCall of FSharpType list * string * Ast.MemberFlags * FSharpType list * FSharpType list * FSharpExpr list + | NewTuple of FSharpType * FSharpExpr list + | TupleGet of FSharpType * int * FSharpExpr + | Coerce of FSharpType * FSharpExpr + | NewArray of FSharpType * FSharpExpr list + | TypeTest of FSharpType * FSharpExpr + | AddressSet of FSharpExpr * FSharpExpr + | ValueSet of FSharpMemberOrFunctionOrValue * FSharpExpr + | Unused + | DefaultValue of FSharpType + | Const of obj * FSharpType + | AddressOf of FSharpExpr + | Sequential of FSharpExpr * FSharpExpr + | FastIntegerForLoop of FSharpExpr * FSharpExpr * FSharpExpr * bool + | WhileLoop of FSharpExpr * FSharpExpr + | TryFinally of FSharpExpr * FSharpExpr + | TryWith of FSharpExpr * FSharpMemberOrFunctionOrValue * FSharpExpr * FSharpMemberOrFunctionOrValue * FSharpExpr + | NewDelegate of FSharpType * FSharpExpr + | ILFieldGet of FSharpExpr option * FSharpType * string + | ILFieldSet of FSharpExpr option * FSharpType * string * FSharpExpr + | ILAsm of string * FSharpType list * FSharpExpr list + +/// Used to represent the information at an object expression member +and [] FSharpObjectExprOverride(sgn: FSharpAbstractSignature, gps: FSharpGenericParameter list, args:FSharpMemberOrFunctionOrValue list list, body: FSharpExpr) = + member __.Signature = sgn + member __.GenericParameters = gps + member __.CurriedParameterGroups = args + member __.Body = body + +/// The type of expressions provided through the compiler API. +and [] FSharpExpr (cenv, f: (unit -> FSharpExpr) option, e: E, m:range, ty) = + + member x.Range = m + member x.Type = FSharpType(cenv, ty) + member x.cenv = cenv + member x.E = match f with None -> e | Some f -> f().E + override x.ToString() = sprintf "%+A" x.E + + member x.ImmediateSubExpressions = + match x.E with + | E.Value _v -> [] + | E.Const (_constValue, _ty) -> [] + | E.TypeLambda (_v, body) -> [body] + | E.Lambda (_v, body) -> [body] + | E.Application (f, _tyargs, arg) -> f :: arg + | E.IfThenElse (e1, e2, e3) -> [e1;e2;e3] + | E.Let ((_bindingVar, bindingExpr), b) -> [bindingExpr;b] + | E.LetRec (ves, b) -> (List.map snd ves) @ [b] + | E.NewRecord (_recordType, es) -> es + | E.NewUnionCase (_unionType, _unionCase, es) -> es + | E.NewTuple (_tupleType, es) -> es + | E.TupleGet (_tupleType, _itemIndex, tupleExpr) -> [tupleExpr] + | E.Call (objOpt, _b, _c, _d, es) -> (match objOpt with None -> es | Some x -> x::es) + | E.NewObject (_a, _b, c) -> c + | E.FSharpFieldGet (objOpt, _b, _c) -> (match objOpt with None -> [] | Some x -> [x]) + | E.FSharpFieldSet (objOpt, _b, _c, d) -> (match objOpt with None -> [d] | Some x -> [x;d]) + | E.UnionCaseGet (obj, _b, _c, _d) -> [obj] + | E.UnionCaseTag (obj, _b) -> [obj] + | E.UnionCaseTest (obj, _b, _c) -> [obj] + | E.NewArray (_ty, elems) -> elems + | E.Coerce (_ty, b) -> [b] + | E.Quote (a) -> [a] + | E.TypeTest (_ty, b) -> [b] + | E.Sequential (a, b) -> [a;b] + | E.FastIntegerForLoop (a, b, c, _dir) -> [a;b;c] + | E.WhileLoop (guard, body) -> [guard; body] + | E.TryFinally (body, b) -> [body; b] + | E.TryWith (body, _b, _c, _d, handler) -> [body; handler] + | E.NewDelegate (_ty, body) -> [body] + | E.DefaultValue (_ty) -> [] + | E.AddressSet (lvalueExpr, rvalueExpr) -> [lvalueExpr; rvalueExpr] + | E.ValueSet (_v, rvalueExpr) -> [rvalueExpr] + | E.AddressOf (lvalueExpr) -> [lvalueExpr] + | E.ThisValue (_ty) -> [] + | E.BaseValue (_ty) -> [] + | E.ILAsm (_code, _tyargs, argExprs) -> argExprs + | E.ILFieldGet (objOpt, _ty, _fieldName) -> (match objOpt with None -> [] | Some x -> [x]) + | E.ILFieldSet (objOpt, _ty, _fieldName, d) -> (match objOpt with None -> [d] | Some x -> [x;d]) + | E.ObjectExpr (_ty, basecall, overrides, interfaceImpls) -> + [ yield basecall; + for m in overrides do yield m.Body + for (_, ms) in interfaceImpls do for m in ms do yield m.Body ] + | E.DecisionTree (inputExpr, targetCases) -> + [ yield inputExpr; + for (_targetVars, targetExpr) in targetCases do yield targetExpr ] + | E.DecisionTreeSuccess (_targetNumber, targetArgs) -> targetArgs + | E.UnionCaseSet (obj, _unionType, _unionCase, _unionField, valueExpr) -> [ yield obj; yield valueExpr ] + | E.TraitCall (_sourceTypes, _traitName, _memberFlags, _paramTypes, _retTypes, args) -> args + | E.Unused -> [] // unexpected + + +/// The implementation of the conversion operation +module FSharpExprConvert = + + let IsStaticInitializationField (rfref: RecdFieldRef) = + rfref.RecdField.IsCompilerGenerated && + rfref.RecdField.IsStatic && + rfref.RecdField.IsMutable && + rfref.RecdField.Name.StartsWith "init" + + // Match "if [AI_clt](init@41,6) then IntrinsicFunctions.FailStaticInit () else ()" + let (|StaticInitializationCheck|_|) e = + match e with + | Expr.Match (_,_,TDSwitch(Expr.Op(TOp.ILAsm ([ AI_clt ],_),_,[Expr.Op(TOp.ValFieldGet rfref,_,_,_) ;_],_),_,_,_),_,_,_) when IsStaticInitializationField rfref -> Some () + | _ -> None + + // Match "init@41 <- 6" + let (|StaticInitializationCount|_|) e = + match e with + | Expr.Op(TOp.ValFieldSet rfref,_,_,_) when IsStaticInitializationField rfref -> Some () + | _ -> None + + let ConvType cenv typ = FSharpType(cenv, typ) + let ConvTypes cenv typs = List.map (ConvType cenv) typs + let ConvILTypeRefApp (cenv:Impl.cenv) m tref tyargs = + let tcref = Import.ImportILTypeRef cenv.amap m tref + ConvType cenv (mkAppTy tcref tyargs) + + let ConvUnionCaseRef cenv (ucref:UnionCaseRef) = FSharpUnionCase(cenv, ucref) + let ConvRecdFieldRef cenv (rfref:RecdFieldRef) = FSharpField(cenv,rfref ) + + let rec exprOfExprAddr (cenv:Impl.cenv) expr = + match expr with + | Expr.Op(op,tyargs,args,m) -> + match op, args, tyargs with + | TOp.LValueOp(LGetAddr,vref),_,_ -> exprForValRef m vref + | TOp.ValFieldGetAddr(rfref),[],_ -> mkStaticRecdFieldGet(rfref,tyargs,m) + | TOp.ValFieldGetAddr(rfref),[arg],_ -> mkRecdFieldGetViaExprAddr(exprOfExprAddr cenv arg,rfref,tyargs,m) + | TOp.UnionCaseFieldGetAddr(uref,n),[arg],_ -> mkUnionCaseFieldGetProvenViaExprAddr(exprOfExprAddr cenv arg,uref,tyargs,n,m) + | TOp.ILAsm([ I_ldflda(fspec) ],rtys),[arg],_ -> mkAsmExpr([ mkNormalLdfld(fspec) ],tyargs, [exprOfExprAddr cenv arg], rtys, m) + | TOp.ILAsm([ I_ldsflda(fspec) ],rtys),_,_ -> mkAsmExpr([ mkNormalLdsfld(fspec) ],tyargs, args, rtys, m) + | TOp.ILAsm(([ I_ldelema(_ro,_isNativePtr,shape,_tyarg) ] ),_), (arr::idxs), [elemty] -> + match shape.Rank, idxs with + | 1, [idx1] -> mkCallArrayGet cenv.g m elemty arr idx1 + | 2, [idx1; idx2] -> mkCallArray2DGet cenv.g m elemty arr idx1 idx2 + | 3, [idx1; idx2; idx3] -> mkCallArray3DGet cenv.g m elemty arr idx1 idx2 idx3 + | 4, [idx1; idx2; idx3; idx4] -> mkCallArray4DGet cenv.g m elemty arr idx1 idx2 idx3 idx4 + | _ -> expr + | _ -> expr + | _ -> expr + + + let Mk cenv m ty e = FSharpExpr(cenv, None, e, m, ty) + + let Mk2 cenv (orig:Expr) e = FSharpExpr(cenv, None, e, orig.Range, tyOfExpr cenv.g orig) + + let rec ConvLValueExpr (cenv:Impl.cenv) env expr = ConvExpr cenv env (exprOfExprAddr cenv expr) + + and ConvExpr cenv env expr = + Mk2 cenv expr (ConvExprPrim cenv env expr) + + and ConvExprLinear cenv env expr contf = + ConvExprPrimLinear cenv env expr (fun exprR -> contf (Mk2 cenv expr exprR)) + + // Tail recursive function to process the subset of expressions considered "linear" + and ConvExprPrimLinear cenv env expr contf = + + match expr with + // Large lists + | Expr.Op(TOp.UnionCase ucref,tyargs,[e1;e2],_) -> + let mkR = ConvUnionCaseRef cenv ucref + let typR = ConvType cenv (mkAppTy ucref.TyconRef tyargs) + let e1R = ConvExpr cenv env e1 + // tail recursive + ConvExprLinear cenv env e2 (contf << (fun e2R -> E.NewUnionCase(typR, mkR, [e1R; e2R]) )) + + // Large sequences of let bindings + | Expr.Let (bind,body,_,_) -> + match ConvLetBind cenv env bind with + | None, env -> ConvExprPrimLinear cenv env body contf + | Some(bindR),env -> + // tail recursive + ConvExprLinear cenv env body (contf << (fun bodyR -> E.Let(bindR,bodyR))) + + // Remove initialization checks + // Remove static initialization counter updates + // Remove static initialization counter checks + // + // Put in ConvExprPrimLinear because of the overlap with Expr.Sequential below + // + // TODO: allow clients to see static initialization checks if they want to + | Expr.Sequential(ObjectInitializationCheck cenv.g, x1, NormalSeq, _, _) + | Expr.Sequential (StaticInitializationCount,x1,NormalSeq,_,_) + | Expr.Sequential (StaticInitializationCheck,x1,NormalSeq,_,_) -> + ConvExprPrim cenv env x1 |> contf + + // Large sequences of sequential code + | Expr.Sequential (e1,e2,NormalSeq,_,_) -> + let e1R = ConvExpr cenv env e1 + // tail recursive + ConvExprLinear cenv env e2 (contf << (fun e2R -> E.Sequential(e1R, e2R))) + + | Expr.Sequential (x0,x1,ThenDoSeq,_,_) -> E.Sequential(ConvExpr cenv env x0, ConvExpr cenv env x1) + + | ModuleValueOrMemberUse cenv.g (vref,vFlags,_f,_fty,tyargs,curriedArgs) when (nonNil tyargs || nonNil curriedArgs) && vref.IsMemberOrModuleBinding -> + ConvModuleValueOrMemberUseLinear cenv env (expr,vref,vFlags,tyargs,curriedArgs) contf + + | Expr.Match (_spBind,m,dtree,tgs,_,retTy) -> + let dtreeR = ConvDecisionTree cenv env retTy dtree m + // tailcall + ConvTargetsLinear cenv env (List.ofArray tgs) (contf << fun (targetsR: _ list) -> + let (|E|) (x:FSharpExpr) = x.E + + // If the match is really an "if-then-else" then return it as such. + match dtreeR with + | E(E.IfThenElse(a,E(E.DecisionTreeSuccess(0,[])), E(E.DecisionTreeSuccess(1,[])))) -> E.IfThenElse(a,snd targetsR.[0],snd targetsR.[1]) + | _ -> E.DecisionTree(dtreeR,targetsR)) + + | _ -> + ConvExprPrim cenv env expr |> contf + + + /// A nasty function copied from creflect.fs. Made nastier by taking a continuation to process the + /// arguments to the call in a tail-recursive fashion. + and ConvModuleValueOrMemberUseLinear (cenv:Impl.cenv) env (expr:Expr,vref,vFlags,tyargs,curriedArgs) contf = + let m = expr.Range + + let (numEnclTypeArgs,_,isNewObj,_valUseFlags,_isSelfInit,takesInstanceArg,_isPropGet,_isPropSet) = + GetMemberCallInfo cenv.g (vref,vFlags) + + let isMember,curriedArgInfos = + + match vref.MemberInfo with + | Some _ when not vref.IsExtensionMember -> + // This is an application of a member method + // We only count one argument block for these. + let _tps,curriedArgInfos,_,_ = GetTypeOfMemberInFSharpForm cenv.g vref + true,curriedArgInfos + | _ -> + // This is an application of a module value or extension member + let arities = arityOfVal vref.Deref + let _tps,curriedArgInfos,_,_ = GetTopValTypeInFSharpForm cenv.g arities vref.Type m + false,curriedArgInfos + + // Compute the object arguments as they appear in a compiled call + // Strip off the object argument, if any. The curriedArgInfos are already adjusted to compiled member form + let objArgs,curriedArgs = + match takesInstanceArg,curriedArgs with + | false,curriedArgs -> [],curriedArgs + | true,(objArg::curriedArgs) -> [objArg],curriedArgs + | true,[] -> failwith ("warning: unexpected missing object argument when generating quotation for call to F# object member "+vref.LogicalName) + + // Check to see if there aren't enough arguments or if there is a tuple-arity mismatch + // If so, adjust and try again + if curriedArgs.Length < curriedArgInfos.Length || + ((List.take curriedArgInfos.Length curriedArgs,curriedArgInfos) ||> List.exists2 (fun arg argInfo -> (argInfo.Length > (tryDestRefTupleExpr arg).Length))) then + + // Too few arguments or incorrect tupling? Convert to a lambda and beta-reduce the + // partially applied arguments to 'let' bindings + let topValInfo = + match vref.ValReprInfo with + | None -> failwith ("no arity information found for F# value "+vref.LogicalName) + | Some a -> a + + let expr,exprty = AdjustValForExpectedArity cenv.g m vref vFlags topValInfo + let splitCallExpr = MakeApplicationAndBetaReduce cenv.g (expr,exprty,[tyargs],curriedArgs,m) + // tailcall + ConvExprPrimLinear cenv env splitCallExpr contf + + else + let curriedArgs,laterArgs = List.chop curriedArgInfos.Length curriedArgs + + // detuple the args + let untupledCurriedArgs = + (curriedArgs,curriedArgInfos) ||> List.map2 (fun arg curriedArgInfo -> + let numUntupledArgs = curriedArgInfo.Length + (if numUntupledArgs = 0 then [] + elif numUntupledArgs = 1 then [arg] + else tryDestRefTupleExpr arg)) + + let contf2 = + match laterArgs with + | [] -> contf + | _ -> (fun subCallR -> (subCallR, laterArgs) ||> List.fold (fun fR arg -> E.Application (Mk2 cenv arg fR,[],[ConvExpr cenv env arg])) |> contf) + + if isMember then + let callArgs = (objArgs::untupledCurriedArgs) |> List.concat + let enclTyArgs, methTyArgs = List.splitAfter numEnclTypeArgs tyargs + // tailcall + ConvObjectModelCallLinear cenv env (isNewObj, FSharpMemberOrFunctionOrValue(cenv,vref), enclTyArgs, methTyArgs, callArgs) contf2 + else + let v = FSharpMemberOrFunctionOrValue(cenv, vref) + // tailcall + ConvObjectModelCallLinear cenv env (false, v, [], tyargs, List.concat untupledCurriedArgs) contf2 + + and ConvExprPrim (cenv:Impl.cenv) (env:ExprTranslationEnv) expr = + // Eliminate integer 'for' loops + let expr = DetectAndOptimizeForExpression cenv.g OptimizeIntRangesOnly expr + + // Eliminate subsumption coercions for functions. This must be done post-typechecking because we need + // complete inference types. + let expr = NormalizeAndAdjustPossibleSubsumptionExprs cenv.g expr + + // Remove TExpr_ref nodes + let expr = stripExpr expr + + match expr with + + // Uses of possibly-polymorphic values which were not polymorphic in the end + | Expr.App(InnerExprPat(Expr.Val _ as ve),_fty,[],[],_) -> + ConvExprPrim cenv env ve + + // These cases are the start of a "linear" sequence where we use tail recursion to allow use to + // deal with large expressions. + | Expr.Op(TOp.UnionCase _,_,[_;_],_) // big lists + | Expr.Let _ // big linear sequences of 'let' + | Expr.Match _ // big linear sequences of 'match ... -> ....' + | Expr.Sequential _ -> + ConvExprPrimLinear cenv env expr (fun e -> e) + + | ModuleValueOrMemberUse cenv.g (vref,vFlags,_f,_fty,tyargs,curriedArgs) when (* (nonNil tyargs || nonNil curriedArgs) && *) vref.IsMemberOrModuleBinding -> + // Process applications of top-level values in a tail-recursive way + ConvModuleValueOrMemberUseLinear cenv env (expr,vref,vFlags,tyargs,curriedArgs) (fun e -> e) + + | Expr.Val(vref,_vFlags,m) -> + ConvValRef cenv env m vref + + // Simple applications + | Expr.App(f,_fty,tyargs,args,_m) -> + E.Application (ConvExpr cenv env f, ConvTypes cenv tyargs, ConvExprs cenv env args) + + | Expr.Const(c,m,ty) -> + ConvConst cenv env m c ty + + | Expr.LetRec(binds,body,_,_) -> + let vs = valsOfBinds binds + let vsR = vs |> List.map (ConvVal cenv) + let env = env.BindVals vs + let bodyR = ConvExpr cenv env body + let bindsR = List.zip vsR (binds |> List.map (fun b -> b.Expr |> ConvExpr cenv env)) + E.LetRec(bindsR,bodyR) + + | Expr.Lambda(_,_,_,vs,b,_,_) -> + let v,b = MultiLambdaToTupledLambda cenv.g vs b + let vR = ConvVal cenv v + let bR = ConvExpr cenv (env.BindVal v) b + E.Lambda(vR, bR) + + | Expr.Quote(ast,_,_,_,_) -> + E.Quote(ConvExpr cenv env ast) + + | Expr.TyLambda (_,tps,b,_,_) -> + let gps = [ for tp in tps -> FSharpGenericParameter(cenv,tp) ] + let env = env.BindTypars (Seq.zip tps gps |> Seq.toList) + E.TypeLambda(gps, ConvExpr cenv env b) + + | Expr.Obj (_,typ,_,_,[TObjExprMethod(TSlotSig(_,ctyp, _,_,_,_),_,tps,[tmvs],e,_) as tmethod],_,m) when isDelegateTy cenv.g typ -> + let f = mkLambdas m tps tmvs (e,GetFSharpViewOfReturnType cenv.g (returnTyOfMethod cenv.g tmethod)) + let fR = ConvExpr cenv env f + let tyargR = ConvType cenv ctyp + E.NewDelegate(tyargR, fR) + + | Expr.StaticOptimization (_,_,x,_) -> + ConvExprPrim cenv env x + + | Expr.TyChoose _ -> + ConvExprPrim cenv env (ChooseTyparSolutionsForFreeChoiceTypars cenv.g cenv.amap expr) + + | Expr.Obj (_lambdaId,typ,_basev,basecall,overrides, iimpls,_m) -> + let basecallR = ConvExpr cenv env basecall + let ConvertMethods methods = + [ for (TObjExprMethod(slotsig,_,tps,tmvs,body,_)) in methods -> + let vslR = List.map (List.map (ConvVal cenv)) tmvs + let sgn = FSharpAbstractSignature(cenv, slotsig) + let tpsR = [ for tp in tps -> FSharpGenericParameter(cenv,tp) ] + let env = ExprTranslationEnv.Empty.BindTypars (Seq.zip tps tpsR |> Seq.toList) + let env = env.BindCurriedVals tmvs + let bodyR = ConvExpr cenv env body + FSharpObjectExprOverride(sgn, tpsR, vslR, bodyR) ] + let overridesR = ConvertMethods overrides + let iimplsR = List.map (fun (ty,impls) -> ConvType cenv ty, ConvertMethods impls) iimpls + + E.ObjectExpr(ConvType cenv typ, basecallR, overridesR, iimplsR) + + | Expr.Op(op,tyargs,args,m) -> + match op,tyargs,args with + | TOp.UnionCase ucref,_,_ -> + let mkR = ConvUnionCaseRef cenv ucref + let typR = ConvType cenv (mkAppTy ucref.TyconRef tyargs) + let argsR = ConvExprs cenv env args + E.NewUnionCase(typR, mkR, argsR) + + | TOp.Tuple tupInfo,tyargs,_ -> + let tyR = ConvType cenv (mkAnyTupledTy cenv.g tupInfo tyargs) + let argsR = ConvExprs cenv env args + E.NewTuple(tyR, argsR) + + | TOp.Recd (_,tcref),_,_ -> + let typR = ConvType cenv (mkAppTy tcref tyargs) + let argsR = ConvExprs cenv env args + E.NewRecord(typR, argsR) + + | TOp.UnionCaseFieldGet (ucref,n),tyargs,[e1] -> + let mkR = ConvUnionCaseRef cenv ucref + let typR = ConvType cenv (mkAppTy ucref.TyconRef tyargs) + let projR = FSharpField(cenv, ucref, n) + E.UnionCaseGet(ConvExpr cenv env e1, typR, mkR, projR) + + | TOp.UnionCaseFieldSet (ucref,n),tyargs,[e1;e2] -> + let mkR = ConvUnionCaseRef cenv ucref + let typR = ConvType cenv (mkAppTy ucref.TyconRef tyargs) + let projR = FSharpField(cenv, ucref, n) + E.UnionCaseSet(ConvExpr cenv env e1, typR, mkR, projR, ConvExpr cenv env e2) + + | TOp.UnionCaseFieldGetAddr (_ucref,_n),_tyargs,_ -> + E.AddressOf(ConvLValueExpr cenv env expr) + + | TOp.ValFieldGetAddr(_rfref),_tyargs,_ -> + E.AddressOf(ConvLValueExpr cenv env expr) + + | TOp.ValFieldGet(rfref),tyargs,[] -> + let projR = ConvRecdFieldRef cenv rfref + let typR = ConvType cenv (mkAppTy rfref.TyconRef tyargs) + E.FSharpFieldGet(None, typR, projR) + + | TOp.ValFieldGet(rfref),tyargs,[obj] -> + let objR = ConvLValueExpr cenv env obj + let projR = ConvRecdFieldRef cenv rfref + let typR = ConvType cenv (mkAppTy rfref.TyconRef tyargs) + E.FSharpFieldGet(Some objR, typR, projR) + + | TOp.TupleFieldGet(tupInfo,n),tyargs,[e] -> + let tyR = ConvType cenv (mkAnyTupledTy cenv.g tupInfo tyargs) + E.TupleGet(tyR, n, ConvExpr cenv env e) + + | TOp.ILAsm([ I_ldfld(_,_,fspec) ],_), enclTypeArgs, [obj] -> + let typR = ConvILTypeRefApp cenv m fspec.EnclosingTypeRef enclTypeArgs + let objR = ConvLValueExpr cenv env obj + E.ILFieldGet(Some objR, typR, fspec.Name) + + | TOp.ILAsm(( [ I_ldsfld (_,fspec) ] | [ I_ldsfld (_,fspec); AI_nop ]),_),enclTypeArgs,[] -> + let typR = ConvILTypeRefApp cenv m fspec.EnclosingTypeRef enclTypeArgs + E.ILFieldGet(None, typR, fspec.Name) + + | TOp.ILAsm([ I_stfld(_,_,fspec) ],_),enclTypeArgs,[obj;arg] -> + let typR = ConvILTypeRefApp cenv m fspec.EnclosingTypeRef enclTypeArgs + let objR = ConvLValueExpr cenv env obj + let argR = ConvExpr cenv env arg + E.ILFieldSet(Some objR, typR, fspec.Name, argR) + + | TOp.ILAsm([ I_stsfld(_,fspec) ],_),enclTypeArgs,[arg] -> + let typR = ConvILTypeRefApp cenv m fspec.EnclosingTypeRef enclTypeArgs + let argR = ConvExpr cenv env arg + E.ILFieldSet(None, typR, fspec.Name, argR) + + + | TOp.ILAsm([ AI_ceq ],_),_,[arg1;arg2] -> + let ty = tyOfExpr cenv.g arg1 + let eq = mkCallEqualsOperator cenv.g m ty arg1 arg2 + ConvExprPrim cenv env eq + + | TOp.ILAsm([ I_throw ],_),_,[arg1] -> + let raiseExpr = mkCallRaise cenv.g m (tyOfExpr cenv.g expr) arg1 + ConvExprPrim cenv env raiseExpr + + | TOp.ILAsm(il,_),tyargs,args -> + E.ILAsm(sprintf "%+A" il, ConvTypes cenv tyargs, ConvExprs cenv env args) + + | TOp.ExnConstr tcref,tyargs,args -> + E.NewRecord(ConvType cenv (mkAppTy tcref tyargs), ConvExprs cenv env args) + + | TOp.ValFieldSet rfref, _tinst,[obj;arg] -> + let objR = ConvLValueExpr cenv env obj + let argR = ConvExpr cenv env arg + let typR = ConvType cenv (mkAppTy rfref.TyconRef tyargs) + let projR = ConvRecdFieldRef cenv rfref + E.FSharpFieldSet(Some objR, typR, projR, argR) + + | TOp.ValFieldSet rfref, _tinst,[arg] -> + let argR = ConvExpr cenv env arg + let typR = ConvType cenv (mkAppTy rfref.TyconRef tyargs) + let projR = ConvRecdFieldRef cenv rfref + E.FSharpFieldSet(None, typR, projR, argR) + + | TOp.ExnFieldGet(tcref,i),[],[obj] -> + let exnc = stripExnEqns tcref + let fspec = exnc.TrueInstanceFieldsAsList.[i] + let fref = mkRecdFieldRef tcref fspec.Name + let typR = ConvType cenv (mkAppTy tcref tyargs) + let objR = ConvExpr cenv env (mkCoerceExpr (obj, mkAppTy tcref [], m, cenv.g.exn_ty)) + E.FSharpFieldGet(Some objR, typR, ConvRecdFieldRef cenv fref) + + | TOp.ExnFieldSet(tcref,i),[],[obj;e2] -> + let exnc = stripExnEqns tcref + let fspec = exnc.TrueInstanceFieldsAsList.[i] + let fref = mkRecdFieldRef tcref fspec.Name + let typR = ConvType cenv (mkAppTy tcref tyargs) + let objR = ConvExpr cenv env (mkCoerceExpr (obj, mkAppTy tcref [], m, cenv.g.exn_ty)) + E.FSharpFieldSet(Some objR, typR, ConvRecdFieldRef cenv fref, ConvExpr cenv env e2) + + | TOp.Coerce,[tgtTy;srcTy],[x] -> + if typeEquiv cenv.g tgtTy srcTy then + ConvExprPrim cenv env x + else + E.Coerce(ConvType cenv tgtTy,ConvExpr cenv env x) + + | TOp.Reraise,[toTy],[] -> + // rebuild reraise() and Convert + mkReraiseLibCall cenv.g toTy m |> ConvExprPrim cenv env + + | TOp.LValueOp(LGetAddr,vref),[],[] -> + E.AddressOf(ConvExpr cenv env (exprForValRef m vref)) + + | TOp.LValueOp(LByrefSet,vref),[],[e] -> + E.AddressSet(ConvExpr cenv env (exprForValRef m vref), ConvExpr cenv env e) + + | TOp.LValueOp(LSet,vref),[],[e] -> + E.ValueSet(FSharpMemberOrFunctionOrValue(cenv, vref), ConvExpr cenv env e) + + | TOp.LValueOp(LByrefGet,vref),[],[] -> + ConvValRef cenv env m vref + + | TOp.Array,[ty],xa -> + E.NewArray(ConvType cenv ty,ConvExprs cenv env xa) + + | TOp.While _,[],[Expr.Lambda(_,_,_,[_],test,_,_);Expr.Lambda(_,_,_,[_],body,_,_)] -> + E.WhileLoop(ConvExpr cenv env test, ConvExpr cenv env body) + + | TOp.For(_, (FSharpForLoopUp |FSharpForLoopDown as dir) ), [], [Expr.Lambda(_,_,_,[_], lim0,_,_); Expr.Lambda(_,_,_,[_], SimpleArrayLoopUpperBound, lm,_); SimpleArrayLoopBody cenv.g (arr, elemTy, body)] -> + let lim1 = + let len = mkCallArrayLength cenv.g lm elemTy arr // Array.length arr + mkCallSubtractionOperator cenv.g lm cenv.g.int32_ty len (Expr.Const(Const.Int32 1, m, cenv.g.int32_ty)) // len - 1 + E.FastIntegerForLoop(ConvExpr cenv env lim0, ConvExpr cenv env lim1, ConvExpr cenv env body, (dir = FSharpForLoopUp)) + + | TOp.For(_,dir),[],[Expr.Lambda(_,_,_,[_],lim0,_,_);Expr.Lambda(_,_,_,[_],lim1,_,_);body] -> + match dir with + | FSharpForLoopUp -> E.FastIntegerForLoop(ConvExpr cenv env lim0,ConvExpr cenv env lim1, ConvExpr cenv env body,true) + | FSharpForLoopDown -> E.FastIntegerForLoop(ConvExpr cenv env lim0,ConvExpr cenv env lim1, ConvExpr cenv env body,false) + | _ -> failwith "unexpected for-loop form" + + | TOp.ILCall(_,_,_,isNewObj,valUseFlags,_isProp,_,ilMethRef,enclTypeArgs,methTypeArgs,_tys),[],callArgs -> + ConvILCall cenv env (isNewObj, valUseFlags, ilMethRef, enclTypeArgs, methTypeArgs, callArgs, m) + + | TOp.TryFinally _,[_resty],[Expr.Lambda(_,_,_,[_],e1,_,_); Expr.Lambda(_,_,_,[_],e2,_,_)] -> + E.TryFinally(ConvExpr cenv env e1,ConvExpr cenv env e2) + + | TOp.TryCatch _,[_resty],[Expr.Lambda(_,_,_,[_],e1,_,_); Expr.Lambda(_,_,_,[vf],ef,_,_); Expr.Lambda(_,_,_,[vh],eh,_,_)] -> + let vfR = ConvVal cenv vf + let envf = env.BindVal vf + let vhR = ConvVal cenv vh + let envh = env.BindVal vh + E.TryWith(ConvExpr cenv env e1,vfR,ConvExpr cenv envf ef,vhR,ConvExpr cenv envh eh) + + | TOp.Bytes bytes,[],[] -> E.Const(box bytes, ConvType cenv (tyOfExpr cenv.g expr)) + + | TOp.UInt16s arr,[],[] -> E.Const(box arr, ConvType cenv (tyOfExpr cenv.g expr)) + + | TOp.UnionCaseProof _,_,[e] -> ConvExprPrim cenv env e // Note: we erase the union case proof conversions when converting to quotations + | TOp.UnionCaseTagGet tycr,tyargs,[arg1] -> + let typR = ConvType cenv (mkAppTy tycr tyargs) + E.UnionCaseTag(ConvExpr cenv env arg1, typR) + + | TOp.TraitCall (TTrait(tys,nm,memFlags,argtys,_rty,_colution)),_,_ -> + let tysR = ConvTypes cenv tys + let tyargsR = ConvTypes cenv tyargs + let argtysR = ConvTypes cenv argtys + let argsR = ConvExprs cenv env args + E.TraitCall(tysR, nm, memFlags, argtysR, tyargsR, argsR) + + | TOp.RefAddrGet,[ty],[e] -> + let replExpr = mkRecdFieldGetAddrViaExprAddr(e, mkRefCellContentsRef cenv.g, [ty],m) + ConvExprPrim cenv env replExpr + + | _ -> wfail (sprintf "unhandled construct in AST", m) + | _ -> + wfail (sprintf "unhandled construct in AST", expr.Range) + + + and ConvLetBind cenv env (bind : Binding) = + match bind.Expr with + // Map for values bound by the + // 'let v = isinst e in .... if nonnull v then ...v .... ' + // construct arising out the compilation of pattern matching. We decode these back to the form + // 'if istype e then ...unbox e .... ' + // It's bit annoying that pattern matching does this tranformation. Like all premature optimization we pay a + // cost here to undo it. + | Expr.Op(TOp.ILAsm([ I_isinst _ ],_),[ty],[e],_) -> + None, env.BindIsInstVal bind.Var (ty,e) + + // Remove let = from quotation tree + | Expr.Val _ when bind.Var.IsCompilerGenerated -> + None, env.BindSubstVal bind.Var bind.Expr + + // Remove let = () from quotation tree + | Expr.Const(Const.Unit,_,_) when bind.Var.IsCompilerGenerated -> + None, env.BindSubstVal bind.Var bind.Expr + + // Remove let unionCase = ... from quotation tree + | Expr.Op(TOp.UnionCaseProof _,_,[e],_) -> + None, env.BindSubstVal bind.Var e + + | _ -> + let v = bind.Var + let vR = ConvVal cenv v + let rhsR = ConvExpr cenv env bind.Expr + let envinner = env.BindVal v + Some(vR,rhsR),envinner + + and ConvILCall (cenv:Impl.cenv) env (isNewObj, valUseFlags, ilMethRef, enclTypeArgs, methTypeArgs, callArgs, m) = + let isNewObj = (isNewObj || (match valUseFlags with CtorValUsedAsSuperInit | CtorValUsedAsSelfInit -> true | _ -> false)) + let methName = ilMethRef.Name + let isPropGet = methName.StartsWith("get_",System.StringComparison.Ordinal) + let isPropSet = methName.StartsWith("set_",System.StringComparison.Ordinal) + let isProp = isPropGet || isPropSet + + let tcref, subClass = + // this does not matter currently, type checking fails to resolve it when a TP references a union case subclass + try + // if the type is an union case class, lookup will fail + Import.ImportILTypeRef cenv.amap m ilMethRef.EnclosingTypeRef, None + with _ -> + let e = ilMethRef.EnclosingTypeRef + let parent = ILTypeRef.Create(e.Scope, e.Enclosing.Tail, e.Enclosing.Head) + Import.ImportILTypeRef cenv.amap m parent, Some e.Name + + let enclosingType = generalizedTyconRef tcref + + let makeCall minfo = + ConvObjectModelCallLinear cenv env (isNewObj, minfo, enclTypeArgs, methTypeArgs, callArgs) id + + let makeFSCall isMember (vr: ValRef) = + let memOrVal = + if isMember then + let minfo = MethInfo.FSMeth(cenv.g, enclosingType, vr, None) + FSharpMemberOrFunctionOrValue(cenv, minfo) + else + FSharpMemberOrFunctionOrValue(cenv, vr) + makeCall memOrVal + + // takes a possibly fake ValRef and tries to resolve it to an F# expression + let makeFSExpr isMember (vr: ValRef) = + let nlr = vr.nlr + let enclosingEntity = + try + nlr.EnclosingEntity.Deref + with _ -> + failwithf "Failed to resolve type '%s'" (nlr.EnclosingEntity.CompiledName) + let ccu = nlr.EnclosingEntity.nlr.Ccu + let vName = nlr.ItemKey.PartialKey.LogicalName // this is actually compiled name + let findByName = + enclosingEntity.MembersOfFSharpTyconSorted |> List.filter (fun v -> v.CompiledName = vName) + match findByName with + | [v] -> + makeFSCall isMember v + | [] -> + let typR = ConvType cenv (mkAppTy tcref enclTypeArgs) + if enclosingEntity.IsModuleOrNamespace then + let findModuleMemberByName = + enclosingEntity.ModuleOrNamespaceType.AllValsAndMembers + |> Seq.filter (fun v -> + v.CompiledName = vName && + match v.ActualParent with + | Parent p -> p.PublicPath = enclosingEntity.PublicPath + | _ -> false + ) |> List.ofSeq + match findModuleMemberByName with + | [v] -> + let vr = VRefLocal v + makeFSCall isMember vr + | [] -> + let isPropGet = vName.StartsWith("get_", System.StringComparison.Ordinal) + let isPropSet = vName.StartsWith("set_", System.StringComparison.Ordinal) + if isPropGet || isPropSet then + let name = PrettyNaming.ChopPropertyName vName + let findByName = + enclosingEntity.ModuleOrNamespaceType.AllValsAndMembers + |> Seq.filter (fun v -> v.CompiledName = name) + |> List.ofSeq + match findByName with + | [ v ] -> + let m = FSharpMemberOrFunctionOrValue(cenv, VRefLocal v) + if isPropGet then + E.Value m + else + let valR = ConvExpr cenv env callArgs.Head + E.ValueSet (m, valR) + | _ -> failwith "Failed to resolve module value unambigously" + else + failwith "Failed to resolve module member" + | _ -> + failwith "Failed to resolve overloaded module member" + elif enclosingEntity.IsRecordTycon then + if isProp then + let name = PrettyNaming.ChopPropertyName vName + let projR = ConvRecdFieldRef cenv (RFRef(tcref, name)) + let objR = ConvLValueExpr cenv env callArgs.Head + if isPropGet then + E.FSharpFieldGet(Some objR, typR, projR) + else + let valR = ConvExpr cenv env callArgs.Tail.Head + E.FSharpFieldSet(Some objR, typR, projR, valR) + elif vName = ".ctor" then + let argsR = ConvExprs cenv env callArgs + E.NewRecord(typR, argsR) + else + failwith "Failed to recognize record type member" + elif enclosingEntity.IsUnionTycon then + if vName = "GetTag" || vName = "get_Tag" then + let objR = ConvExpr cenv env callArgs.Head + E.UnionCaseTag(objR, typR) + elif vName.StartsWith("New") then + let name = vName.Substring(3) + let mkR = ConvUnionCaseRef cenv (UCRef(tcref, name)) + let argsR = ConvExprs cenv env callArgs + E.NewUnionCase(typR, mkR, argsR) + elif vName.StartsWith("Is") then + let name = vName.Substring(2) + let mkR = ConvUnionCaseRef cenv (UCRef(tcref, name)) + let objR = ConvExpr cenv env callArgs.Head + E.UnionCaseTest(objR, typR, mkR) + else + match subClass with + | Some name -> + let ucref = UCRef(tcref, name) + let mkR = ConvUnionCaseRef cenv ucref + let objR = ConvLValueExpr cenv env callArgs.Head + let projR = FSharpField(cenv, ucref, ucref.Index) + E.UnionCaseGet(objR, typR, mkR, projR) + | _ -> + failwith "Failed to recognize union type member" + else + let names = enclosingEntity.MembersOfFSharpTyconSorted |> List.map (fun v -> v.CompiledName) |> String.concat ", " + failwithf "Member '%s' not found in type %s, found: %s" vName enclosingEntity.DisplayName names + | _ -> // member is overloaded + match nlr.ItemKey.TypeForLinkage with + | None -> failwith "Type of signature could not be resolved" + | Some keyTy -> + let findBySig = + findByName |> List.tryFind (fun v -> ccu.MemberSignatureEquality(keyTy,v.Type)) + match findBySig with + | Some v -> + makeFSCall isMember v + | _ -> + failwith "Failed to recognize F# member" + + // First try to resolve it to IL metadata + let try1 = + if tcref.IsILTycon then + try + let mdef = resolveILMethodRefWithRescope unscopeILType tcref.ILTyconRawMetadata ilMethRef + let minfo = MethInfo.CreateILMeth(cenv.amap, m, enclosingType, mdef) + FSharpMemberOrFunctionOrValue(cenv, minfo) |> makeCall |> Some + with _ -> + None + else + None + + // Otherwise try to bind it to an F# symbol + match try1 with + | Some res -> res + | None -> + try + // Try to bind the call to an F# method call + let memberParentName = if tcref.IsModuleOrNamespace then None else Some tcref.LogicalName + // this logical name is not correct in the presence of CompiledName + let logicalName = ilMethRef.Name + let isMember = memberParentName.IsSome + if isMember then + match ilMethRef.Name, ilMethRef.EnclosingTypeRef.Name with + | "Invoke", "Microsoft.FSharp.Core.FSharpFunc`2" -> + let objR = ConvLValueExpr cenv env callArgs.Head + let argR = ConvExpr cenv env callArgs.Tail.Head + let typR = ConvType cenv enclTypeArgs.Head + E.Application(objR, [typR], [argR]) + | _ -> + let isCtor = (ilMethRef.Name = ".ctor") + let isStatic = isCtor || ilMethRef.CallingConv.IsStatic + let scoref = ilMethRef.EnclosingTypeRef.Scope + let typars1 = tcref.Typars(m) + let typars2 = [ 1 .. ilMethRef.GenericArity ] |> List.map (fun _ -> NewRigidTypar "T" m) + let tinst1 = typars1 |> generalizeTypars + let tinst2 = typars2 |> generalizeTypars + // TODO: this will not work for curried methods in F# classes. + // This is difficult to solve as the information in the ILMethodRef + // is not sufficient to resolve to a symbol unambiguously in these cases. + let argtys = [ ilMethRef.ArgTypes |> List.map (ImportILTypeFromMetadata cenv.amap m scoref tinst1 tinst2) ] + let rty = + match ImportReturnTypeFromMetaData cenv.amap m ilMethRef.ReturnType scoref tinst1 tinst2 with + | None -> if isCtor then enclosingType else cenv.g.unit_ty + | Some ty -> ty + + let linkageType = + let ty = mkIteratedFunTy (List.map (mkRefTupledTy cenv.g) argtys) rty + let ty = if isStatic then ty else mkFunTy enclosingType ty + tryMkForallTy (typars1 @ typars2) ty + + let argCount = List.sum (List.map List.length argtys) + (if isStatic then 0 else 1) + let key = ValLinkageFullKey({ MemberParentMangledName=memberParentName; MemberIsOverride=false; LogicalName=logicalName; TotalArgCount= argCount },Some linkageType) + + let (PubPath p) = tcref.PublicPath.Value + let enclosingNonLocalRef = mkNonLocalEntityRef tcref.nlr.Ccu p + let vref = mkNonLocalValRef enclosingNonLocalRef key + makeFSExpr isMember vref + + else + let key = ValLinkageFullKey({ MemberParentMangledName=memberParentName; MemberIsOverride=false; LogicalName=logicalName; TotalArgCount= 0 },None) + let vref = mkNonLocalValRef tcref.nlr key + makeFSExpr isMember vref + + with e -> + failwithf "An IL call to '%s' could not be resolved: %s" (ilMethRef.ToString()) e.Message + + and ConvObjectModelCallLinear cenv env (isNewObj, v:FSharpMemberOrFunctionOrValue, enclTyArgs, methTyArgs,callArgs) contf = + let enclTyArgsR = ConvTypes cenv enclTyArgs + let methTyArgsR = ConvTypes cenv methTyArgs + let obj, callArgs = + if v.IsInstanceMember then + match callArgs with + | obj :: rest -> Some obj, rest + | _ -> failwith (sprintf "unexpected shape of arguments: %A" callArgs) + else + None, callArgs + let objR = Option.map (ConvLValueExpr cenv env) obj + // tailcall + ConvExprsLinear cenv env callArgs (contf << fun callArgsR -> + if isNewObj then + E.NewObject(v, enclTyArgsR, callArgsR) + else + E.Call(objR, v, enclTyArgsR, methTyArgsR, callArgsR)) + + + and ConvExprs cenv env args = List.map (ConvExpr cenv env) args + + // Process a list of expressions in a tail-recursive way. Identical to "ConvExprs" but the result is eventually passed to contf. + and ConvExprsLinear cenv env args contf = + match args with + | [] -> contf [] + | [arg] -> ConvExprLinear cenv env arg (fun argR -> contf [argR]) + | arg::rest -> ConvExprLinear cenv env arg (fun argR -> ConvExprsLinear cenv env rest (fun restR -> contf (argR :: restR))) + + and ConvTargetsLinear cenv env tgs contf = + match tgs with + | [] -> contf [] + | TTarget(vars,rhs,_)::rest -> + let varsR = (List.rev vars) |> List.map (ConvVal cenv) + ConvExprLinear cenv env rhs (fun targetR -> + ConvTargetsLinear cenv env rest (fun restR -> + contf ((varsR, targetR) :: restR))) + + and ConvValRef cenv env m (vref:ValRef) = + let v = vref.Deref + if env.isinstVals.ContainsVal v then + let (ty,e) = env.isinstVals.[v] + ConvExprPrim cenv env (mkCallUnbox cenv.g m ty e) + elif env.substVals.ContainsVal v then + let e = env.substVals.[v] + ConvExprPrim cenv env e + elif v.BaseOrThisInfo = CtorThisVal then + E.ThisValue(ConvType cenv v.Type) + elif v.BaseOrThisInfo = BaseVal then + E.BaseValue(ConvType cenv v.Type) + else + E.Value(FSharpMemberOrFunctionOrValue(cenv, vref)) + + and ConvVal cenv (v:Val) = + let vref = mkLocalValRef v + FSharpMemberOrFunctionOrValue(cenv, vref) + + and ConvConst cenv env m c ty = + match TryEliminateDesugaredConstants cenv.g m c with + | Some e -> ConvExprPrim cenv env e + | None -> + let tyR = ConvType cenv ty + match c with + | Const.Bool i -> E.Const(box i, tyR) + | Const.SByte i -> E.Const(box i, tyR) + | Const.Byte i -> E.Const(box i, tyR) + | Const.Int16 i -> E.Const(box i, tyR) + | Const.UInt16 i -> E.Const(box i, tyR) + | Const.Int32 i -> E.Const(box i, tyR) + | Const.UInt32 i -> E.Const(box i, tyR) + | Const.Int64 i -> E.Const(box i, tyR) + | Const.IntPtr i -> E.Const(box (nativeint i), tyR) + | Const.UInt64 i -> E.Const(box i, tyR) + | Const.UIntPtr i -> E.Const(box (unativeint i), tyR) + | Const.Double i -> E.Const(box i, tyR) + | Const.Single i -> E.Const(box i, tyR) + | Const.String i -> E.Const(box i, tyR) + | Const.Char i -> E.Const(box i, tyR) + | Const.Unit -> E.Const(box (), tyR) + | Const.Zero -> E.DefaultValue (ConvType cenv ty) + | _ -> + wfail("FSharp.Compiler.Service cannot yet return this kind of constant", m) + + and ConvDecisionTree cenv env dtreeRetTy x m = + ConvDecisionTreePrim cenv env dtreeRetTy x |> Mk cenv m dtreeRetTy + + and ConvDecisionTreePrim cenv env dtreeRetTy x = + match x with + | TDSwitch(e1,csl,dfltOpt,m) -> + let acc = + match dfltOpt with + | Some d -> ConvDecisionTreePrim cenv env dtreeRetTy d + | None -> wfail( "FSharp.Compiler.Service cannot yet return this kind of pattern match", m) + (csl,acc) ||> List.foldBack (fun (TCase(discrim,dtree)) acc -> + let acc = acc |> Mk cenv m dtreeRetTy + match discrim with + | DecisionTreeTest.UnionCase (ucref, tyargs) -> + let objR = ConvExpr cenv env e1 + let ucR = ConvUnionCaseRef cenv ucref + let utypR = ConvType cenv (mkAppTy ucref.TyconRef tyargs) + E.IfThenElse (E.UnionCaseTest (objR, utypR, ucR) |> Mk cenv m cenv.g.bool_ty, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) + | DecisionTreeTest.Const (Const.Bool true) -> + let e1R = ConvExpr cenv env e1 + E.IfThenElse (e1R, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) + | DecisionTreeTest.Const (Const.Bool false) -> + let e1R = ConvExpr cenv env e1 + // Note, reverse the branches + E.IfThenElse (e1R, acc, ConvDecisionTree cenv env dtreeRetTy dtree m) + | DecisionTreeTest.Const c -> + let ty = tyOfExpr cenv.g e1 + let eq = mkCallEqualsOperator cenv.g m ty e1 (Expr.Const (c, m, ty)) + let eqR = ConvExpr cenv env eq + E.IfThenElse (eqR, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) + | DecisionTreeTest.IsNull -> + // Decompile cached isinst tests + match e1 with + | Expr.Val(vref,_,_) when env.isinstVals.ContainsVal vref.Deref -> + let (ty,e) = env.isinstVals.[vref.Deref] + let tyR = ConvType cenv ty + let eR = ConvExpr cenv env e + // note: reverse the branches - a null test is a failure of an isinst test + E.IfThenElse (E.TypeTest (tyR,eR) |> Mk cenv m cenv.g.bool_ty, acc, ConvDecisionTree cenv env dtreeRetTy dtree m) + | _ -> + let ty = tyOfExpr cenv.g e1 + let eq = mkCallEqualsOperator cenv.g m ty e1 (Expr.Const (Const.Zero, m, ty)) + let eqR = ConvExpr cenv env eq + E.IfThenElse (eqR, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) + | DecisionTreeTest.IsInst (_srcty, tgty) -> + let e1R = ConvExpr cenv env e1 + E.IfThenElse (E.TypeTest (ConvType cenv tgty, e1R) |> Mk cenv m cenv.g.bool_ty, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) + | DecisionTreeTest.ActivePatternCase _ -> wfail("unexpected Test.ActivePatternCase test in quoted expression",m) + | DecisionTreeTest.ArrayLength _ -> wfail("FSharp.Compiler.Service cannot yet return array pattern matching", m)) + + | TDSuccess (args,n) -> + // TAST stores pattern bindings in reverse order for some reason + // Reverse them here to give a good presentation to the user + let args = List.rev args + let argsR = ConvExprs cenv env args + E.DecisionTreeSuccess(n, argsR) + + | TDBind(bind,rest) -> + // The binding may be a compiler-generated binding that gets removed in the quotation presentation + match ConvLetBind cenv env bind with + | None, env -> ConvDecisionTreePrim cenv env dtreeRetTy rest + | Some(bindR),env -> E.Let(bindR,ConvDecisionTree cenv env dtreeRetTy rest bind.Var.Range) + + /// Wrap the conversion in a function to make it on-demand. Any pattern matching on the FSharpExpr will + /// force the evaluation of the entire conversion process eagerly. + let ConvExprOnDemand cenv env expr = + FSharpExpr(cenv, Some(fun () -> ConvExpr cenv env expr), E.Unused, expr.Range, tyOfExpr cenv.g expr) + + + +/// The contents of the F# assembly as provided through the compiler API +type FSharpAssemblyContents(cenv: Impl.cenv, mimpls: TypedImplFile list) = + + new (g, thisCcu, tcImports, mimpls) = FSharpAssemblyContents(Impl.cenv(g,thisCcu,tcImports), mimpls) + + member __.ImplementationFiles = + [ for mimpl in mimpls -> FSharpImplementationFileContents(cenv, mimpl)] + +and FSharpImplementationFileDeclaration = + | Entity of FSharpEntity * FSharpImplementationFileDeclaration list + | MemberOrFunctionOrValue of FSharpMemberOrFunctionOrValue * FSharpMemberOrFunctionOrValue list list * FSharpExpr + | InitAction of FSharpExpr + +and FSharpImplementationFileContents(cenv, mimpl) = + let (TImplFile(qname,_pragmas,ModuleOrNamespaceExprWithSig(_mty,mdef,_),hasExplicitEntryPoint,isScript)) = mimpl + let rec getDecls2 (ModuleOrNamespaceExprWithSig(_mty,def,_m)) = getDecls def + and getBind (bind: Binding) = + let v = bind.Var + assert v.IsCompiledAsTopLevel + let topValInfo = InferArityOfExprBinding cenv.g v bind.Expr + let tps,_ctorThisValOpt,_baseValOpt,vsl,body,_bodyty = IteratedAdjustArityOfLambda cenv.g cenv.amap topValInfo bind.Expr + let v = FSharpMemberOrFunctionOrValue(cenv, mkLocalValRef v) + let gps = v.GenericParameters + let vslR = List.map (List.map (FSharpExprConvert.ConvVal cenv)) vsl + let env = ExprTranslationEnv.Empty.BindTypars (Seq.zip tps gps |> Seq.toList) + let env = env.BindCurriedVals vsl + let e = FSharpExprConvert.ConvExprOnDemand cenv env body + FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(v, vslR, e) + + and getDecls mdef = + match mdef with + | TMDefRec(_isRec,tycons,mbinds,_m) -> + [ for tycon in tycons do + let entity = FSharpEntity(cenv, mkLocalEntityRef tycon) + yield FSharpImplementationFileDeclaration.Entity(entity, []) + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Module(mspec, def) -> + let entity = FSharpEntity(cenv, mkLocalEntityRef mspec) + yield FSharpImplementationFileDeclaration.Entity (entity, getDecls def) + | ModuleOrNamespaceBinding.Binding(bind) -> + yield getBind bind ] + | TMAbstract(mexpr) -> getDecls2 mexpr + | TMDefLet(bind,_m) -> + [ yield getBind bind ] + | TMDefDo(expr,_m) -> + [ let expr = FSharpExprConvert.ConvExprOnDemand cenv ExprTranslationEnv.Empty expr + yield FSharpImplementationFileDeclaration.InitAction(expr) ] + | TMDefs(mdefs) -> + [ for mdef in mdefs do yield! getDecls mdef ] + + member __.QualifiedName = qname.Text + member __.FileName = qname.Range.FileName + member __.Declarations = getDecls mdef + member __.HasExplicitEntryPoint = hasExplicitEntryPoint + member __.IsScript = isScript + + +module BasicPatterns = + let (|Value|_|) (e:FSharpExpr) = match e.E with E.Value (v) -> Some (v) | _ -> None + let (|Const|_|) (e:FSharpExpr) = match e.E with E.Const (v,ty) -> Some (v,ty) | _ -> None + let (|TypeLambda|_|) (e:FSharpExpr) = match e.E with E.TypeLambda (v,e) -> Some (v,e) | _ -> None + let (|Lambda|_|) (e:FSharpExpr) = match e.E with E.Lambda (v,e) -> Some (v,e) | _ -> None + let (|Application|_|) (e:FSharpExpr) = match e.E with E.Application (f,tys,e) -> Some (f,tys,e) | _ -> None + let (|IfThenElse|_|) (e:FSharpExpr) = match e.E with E.IfThenElse (e1,e2,e3) -> Some (e1,e2,e3) | _ -> None + let (|Let|_|) (e:FSharpExpr) = match e.E with E.Let ((v,e),b) -> Some ((v,e),b) | _ -> None + let (|LetRec|_|) (e:FSharpExpr) = match e.E with E.LetRec (ves,b) -> Some (ves,b) | _ -> None + let (|NewRecord|_|) (e:FSharpExpr) = match e.E with E.NewRecord (ty,es) -> Some (ty,es) | _ -> None + let (|NewUnionCase|_|) (e:FSharpExpr) = match e.E with E.NewUnionCase (e,tys,es) -> Some (e,tys,es) | _ -> None + let (|NewTuple|_|) (e:FSharpExpr) = match e.E with E.NewTuple (ty,es) -> Some (ty,es) | _ -> None + let (|TupleGet|_|) (e:FSharpExpr) = match e.E with E.TupleGet (ty,n,es) -> Some (ty,n,es) | _ -> None + let (|Call|_|) (e:FSharpExpr) = match e.E with E.Call (a,b,c,d,e) -> Some (a,b,c,d,e) | _ -> None + let (|NewObject|_|) (e:FSharpExpr) = match e.E with E.NewObject (a,b,c) -> Some (a,b,c) | _ -> None + let (|FSharpFieldGet|_|) (e:FSharpExpr) = match e.E with E.FSharpFieldGet (a,b,c) -> Some (a,b,c) | _ -> None + let (|FSharpFieldSet|_|) (e:FSharpExpr) = match e.E with E.FSharpFieldSet (a,b,c,d) -> Some (a,b,c,d) | _ -> None + let (|UnionCaseGet|_|) (e:FSharpExpr) = match e.E with E.UnionCaseGet (a,b,c,d) -> Some (a,b,c,d) | _ -> None + let (|UnionCaseTag|_|) (e:FSharpExpr) = match e.E with E.UnionCaseTag (a,b) -> Some (a,b) | _ -> None + let (|UnionCaseTest|_|) (e:FSharpExpr) = match e.E with E.UnionCaseTest (a,b,c) -> Some (a,b,c) | _ -> None + let (|NewArray|_|) (e:FSharpExpr) = match e.E with E.NewArray (a,b) -> Some (a,b) | _ -> None + let (|Coerce|_|) (e:FSharpExpr) = match e.E with E.Coerce (a,b) -> Some (a,b) | _ -> None + let (|Quote|_|) (e:FSharpExpr) = match e.E with E.Quote (a) -> Some (a) | _ -> None + let (|TypeTest|_|) (e:FSharpExpr) = match e.E with E.TypeTest (a,b) -> Some (a,b) | _ -> None + let (|Sequential|_|) (e:FSharpExpr) = match e.E with E.Sequential (a,b) -> Some (a,b) | _ -> None + let (|FastIntegerForLoop|_|) (e:FSharpExpr) = match e.E with E.FastIntegerForLoop (a,b,c,d) -> Some (a,b,c,d) | _ -> None + let (|WhileLoop|_|) (e:FSharpExpr) = match e.E with E.WhileLoop (a,b) -> Some (a,b) | _ -> None + let (|TryFinally|_|) (e:FSharpExpr) = match e.E with E.TryFinally (a,b) -> Some (a,b) | _ -> None + let (|TryWith|_|) (e:FSharpExpr) = match e.E with E.TryWith (a,b,c,d,e) -> Some (a,b,c,d,e) | _ -> None + let (|NewDelegate|_|) (e:FSharpExpr) = match e.E with E.NewDelegate (ty,e) -> Some (ty,e) | _ -> None + let (|DefaultValue|_|) (e:FSharpExpr) = match e.E with E.DefaultValue (ty) -> Some (ty) | _ -> None + let (|AddressSet|_|) (e:FSharpExpr) = match e.E with E.AddressSet (a,b) -> Some (a,b) | _ -> None + let (|ValueSet|_|) (e:FSharpExpr) = match e.E with E.ValueSet (a,b) -> Some (a,b) | _ -> None + let (|AddressOf|_|) (e:FSharpExpr) = match e.E with E.AddressOf (a) -> Some (a) | _ -> None + let (|ThisValue|_|) (e:FSharpExpr) = match e.E with E.ThisValue (a) -> Some (a) | _ -> None + let (|BaseValue|_|) (e:FSharpExpr) = match e.E with E.BaseValue (a) -> Some (a) | _ -> None + let (|ILAsm|_|) (e:FSharpExpr) = match e.E with E.ILAsm (a,b,c) -> Some (a,b,c) | _ -> None + let (|ILFieldGet|_|) (e:FSharpExpr) = match e.E with E.ILFieldGet (a,b,c) -> Some (a,b,c) | _ -> None + let (|ILFieldSet|_|) (e:FSharpExpr) = match e.E with E.ILFieldSet (a,b,c,d) -> Some (a,b,c,d) | _ -> None + let (|ObjectExpr|_|) (e:FSharpExpr) = match e.E with E.ObjectExpr (a,b,c,d) -> Some (a,b,c,d) | _ -> None + let (|DecisionTree|_|) (e:FSharpExpr) = match e.E with E.DecisionTree (a,b) -> Some (a,b) | _ -> None + let (|DecisionTreeSuccess|_|) (e:FSharpExpr) = match e.E with E.DecisionTreeSuccess (a,b) -> Some (a,b) | _ -> None + let (|UnionCaseSet|_|) (e:FSharpExpr) = match e.E with E.UnionCaseSet (a,b,c,d,e) -> Some (a,b,c,d,e) | _ -> None + let (|TraitCall|_|) (e:FSharpExpr) = match e.E with E.TraitCall (a,b,c,d,e,f) -> Some (a,b,c,d,e,f) | _ -> None + diff --git a/src/fsharp/symbols/Exprs.fsi b/src/fsharp/symbols/Exprs.fsi new file mode 100644 index 00000000000..15b1002c1d6 --- /dev/null +++ b/src/fsharp/symbols/Exprs.fsi @@ -0,0 +1,235 @@ +// Copyright (c) Microsoft Corpration, Inc. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Compiler.SourceCodeServices + +open System.Collections.Generic +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.CompileOps + + +/// Represents the definitional contents of an assembly, as seen by the F# language +#if COMPILER_PUBLIC_API +type FSharpAssemblyContents = +#else +type internal FSharpAssemblyContents = +#endif + + internal new : tcGlobals: TcGlobals * thisCcu: CcuThunk * tcImports: TcImports * mimpls: TypedImplFile list -> FSharpAssemblyContents + + /// The contents of the implementation files in the assembly + member ImplementationFiles: FSharpImplementationFileContents list + +/// Represents the definitional contents of a single file or fragment in an assembly, as seen by the F# language +#if COMPILER_PUBLIC_API +and [] FSharpImplementationFileContents = +#else +and [] internal FSharpImplementationFileContents = +#endif + + /// The qualified name acts to fully-qualify module specifications and implementations + member QualifiedName: string + + /// Get the system path of the implementation file + member FileName: string + + /// Get the declarations that make up this implementation file + member Declarations : FSharpImplementationFileDeclaration list + + /// Indicates if the implementation file is a script + member IsScript: bool + + /// Indicates if the implementation file has an explicit entry point + member HasExplicitEntryPoint: bool + +/// Represents a declaration in an implementation file, as seen by the F# language +#if COMPILER_PUBLIC_API +and FSharpImplementationFileDeclaration = +#else +and internal FSharpImplementationFileDeclaration = +#endif +/// Represents the declaration of a type + | Entity of FSharpEntity * FSharpImplementationFileDeclaration list + /// Represents the declaration of a member, function or value, including the parameters and body of the member + | MemberOrFunctionOrValue of FSharpMemberOrFunctionOrValue * FSharpMemberOrFunctionOrValue list list * FSharpExpr + /// Represents the declaration of a static initialization action + | InitAction of FSharpExpr + +/// Represents a checked and reduced expression, as seen by the F# language. The active patterns +/// in 'FSharp.Compiler.SourceCodeServices' can be used to analyze information about the expression. +/// +/// Pattern matching is reduced to decision trees and conditional tests. Some other +/// constructs may be represented in reduced form. +#if COMPILER_PUBLIC_API +and [] FSharpExpr = +#else +and [] internal FSharpExpr = +#endif + /// The range of the expression + member Range : range + + /// The type of the expression + member Type : FSharpType + + /// The immediate sub-expressions of the expression. + member ImmediateSubExpressions : FSharpExpr list + +/// Represents a checked method in an object expression, as seen by the F# language. +#if COMPILER_PUBLIC_API +and [] FSharpObjectExprOverride = +#else +and [] internal FSharpObjectExprOverride = +#endif + /// The signature of the implemented abstract slot + member Signature : FSharpAbstractSignature + + /// The generic parameters of the method + member GenericParameters : FSharpGenericParameter list + + /// The parameters of the method + member CurriedParameterGroups : FSharpMemberOrFunctionOrValue list list + + /// The expression that forms the body of the method + member Body : FSharpExpr + +/// A collection of active patterns to analyze expressions +#if COMPILER_PUBLIC_API +module BasicPatterns = +#else +module internal BasicPatterns = +#endif + + /// Matches expressions which are uses of values + val (|Value|_|) : FSharpExpr -> FSharpMemberOrFunctionOrValue option + + /// Matches expressions which are the application of function values + val (|Application|_|) : FSharpExpr -> (FSharpExpr * FSharpType list * FSharpExpr list) option + + /// Matches expressions which are type abstractions + val (|TypeLambda|_|) : FSharpExpr -> (FSharpGenericParameter list * FSharpExpr) option + + /// Matches expressions with a decision expression, each branch of which ends in DecisionTreeSuccess pasing control and values to one of the targets. + val (|DecisionTree|_|) : FSharpExpr -> (FSharpExpr * (FSharpMemberOrFunctionOrValue list * FSharpExpr) list) option + + /// Special expressions at the end of a conditional decision structure in the decision expression node of a DecisionTree . + /// The given expressions are passed as values to the decision tree target. + val (|DecisionTreeSuccess|_|) : FSharpExpr -> (int * FSharpExpr list) option + + /// Matches expressions which are lambda abstractions + val (|Lambda|_|) : FSharpExpr -> (FSharpMemberOrFunctionOrValue * FSharpExpr) option + + /// Matches expressions which are conditionals + val (|IfThenElse|_|) : FSharpExpr -> (FSharpExpr * FSharpExpr * FSharpExpr) option + + /// Matches expressions which are let definitions + val (|Let|_|) : FSharpExpr -> ((FSharpMemberOrFunctionOrValue * FSharpExpr) * FSharpExpr) option + + /// Matches expressions which are calls to members or module-defined functions. When calling curried functions and members the + /// arguments are collapsed to a single collection of arguments, as done in the compiled version of these. + val (|Call|_|) : FSharpExpr -> (FSharpExpr option * FSharpMemberOrFunctionOrValue * FSharpType list * FSharpType list * FSharpExpr list) option + + /// Matches expressions which are calls to object constructors + val (|NewObject|_|) : FSharpExpr -> (FSharpMemberOrFunctionOrValue * FSharpType list * FSharpExpr list) option + + /// Matches expressions which are uses of the 'this' value + val (|ThisValue|_|) : FSharpExpr -> FSharpType option + + /// Matches expressions which are uses of the 'base' value + val (|BaseValue|_|) : FSharpExpr -> FSharpType option + + /// Matches expressions which are quotation literals + val (|Quote|_|) : FSharpExpr -> FSharpExpr option + + /// Matches expressions which are let-rec definitions + val (|LetRec|_|) : FSharpExpr -> ((FSharpMemberOrFunctionOrValue * FSharpExpr) list * FSharpExpr) option + + /// Matches record expressions + val (|NewRecord|_|) : FSharpExpr -> (FSharpType * FSharpExpr list) option + + /// Matches expressions which get a field from a record or class + val (|FSharpFieldGet|_|) : FSharpExpr -> (FSharpExpr option * FSharpType * FSharpField) option + + /// Matches expressions which set a field in a record or class + val (|FSharpFieldSet|_|) : FSharpExpr -> (FSharpExpr option * FSharpType * FSharpField * FSharpExpr) option + + /// Matches expressions which create an object corresponding to a union case + val (|NewUnionCase|_|) : FSharpExpr -> (FSharpType * FSharpUnionCase * FSharpExpr list) option + + /// Matches expressions which get a field from a union case + val (|UnionCaseGet|_|) : FSharpExpr -> (FSharpExpr * FSharpType * FSharpUnionCase * FSharpField) option + + /// Matches expressions which set a field from a union case (only used in FSharp.Core itself) + val (|UnionCaseSet|_|) : FSharpExpr -> (FSharpExpr * FSharpType * FSharpUnionCase * FSharpField * FSharpExpr) option + + /// Matches expressions which gets the tag for a union case + val (|UnionCaseTag|_|) : FSharpExpr -> (FSharpExpr * FSharpType) option + + /// Matches expressions which test if an expression corresponds to a particular union case + val (|UnionCaseTest|_|) : FSharpExpr -> (FSharpExpr * FSharpType * FSharpUnionCase) option + + /// Matches tuple expressions + val (|NewTuple|_|) : FSharpExpr -> (FSharpType * FSharpExpr list) option + + /// Matches expressions which get a value from a tuple + val (|TupleGet|_|) : FSharpExpr -> (FSharpType * int * FSharpExpr) option + + /// Matches expressions which coerce the type of a value + val (|Coerce|_|) : FSharpExpr -> (FSharpType * FSharpExpr) option + + /// Matches array expressions + val (|NewArray|_|) : FSharpExpr -> (FSharpType * FSharpExpr list) option + + /// Matches expressions which test the runtime type of a value + val (|TypeTest|_|) : FSharpExpr -> (FSharpType * FSharpExpr) option + + /// Matches expressions which set the contents of an address + val (|AddressSet|_|) : FSharpExpr -> (FSharpExpr * FSharpExpr) option + + /// Matches expressions which set the contents of a mutable variable + val (|ValueSet|_|) : FSharpExpr -> (FSharpMemberOrFunctionOrValue * FSharpExpr) option + + /// Matches default-value expressions, including null expressions + val (|DefaultValue|_|) : FSharpExpr -> FSharpType option + + /// Matches constant expressions, including signed and unsigned integers, strings, characters, booleans, arrays + /// of bytes and arrays of unit16. + val (|Const|_|) : FSharpExpr -> (obj * FSharpType) option + + /// Matches expressions which take the address of a location + val (|AddressOf|_|) : FSharpExpr -> FSharpExpr option + + /// Matches sequential expressions + val (|Sequential|_|) : FSharpExpr -> (FSharpExpr * FSharpExpr) option + + /// Matches fast-integer loops (up or down) + val (|FastIntegerForLoop|_|) : FSharpExpr -> (FSharpExpr * FSharpExpr * FSharpExpr * bool) option + + /// Matches while loops + val (|WhileLoop|_|) : FSharpExpr -> (FSharpExpr * FSharpExpr) option + + /// Matches try/finally expressions + val (|TryFinally|_|) : FSharpExpr -> (FSharpExpr * FSharpExpr) option + + /// Matches try/with expressions + val (|TryWith|_|) : FSharpExpr -> (FSharpExpr * FSharpMemberOrFunctionOrValue * FSharpExpr * FSharpMemberOrFunctionOrValue * FSharpExpr) option + + /// Matches expressions which create an instance of a delegate type + val (|NewDelegate|_|) : FSharpExpr -> (FSharpType * FSharpExpr) option + + /// Matches expressions which are IL assembly code + val (|ILAsm|_|) : FSharpExpr -> (string * FSharpType list * FSharpExpr list) option + + /// Matches expressions which fetch a field from a .NET type + val (|ILFieldGet|_|) : FSharpExpr -> (FSharpExpr option * FSharpType * string) option + + /// Matches expressions which set a field in a .NET type + val (|ILFieldSet|_|) : FSharpExpr -> (FSharpExpr option * FSharpType * string * FSharpExpr) option + + /// Matches object expressions, returning the base type, the base call, the overrides and the interface implementations + val (|ObjectExpr|_|) : FSharpExpr -> (FSharpType * FSharpExpr * FSharpObjectExprOverride list * (FSharpType * FSharpObjectExprOverride list) list) option + + /// Matches expressions for an unresolved call to a trait + val (|TraitCall|_|) : FSharpExpr -> (FSharpType list * string * Ast.MemberFlags * FSharpType list * FSharpType list * FSharpExpr list) option + diff --git a/src/fsharp/vs/ServiceDeclarations.fs b/src/fsharp/symbols/SymbolHelpers.fs similarity index 59% rename from src/fsharp/vs/ServiceDeclarations.fs rename to src/fsharp/symbols/SymbolHelpers.fs index f547ff01df3..d36f9c92df8 100644 --- a/src/fsharp/vs/ServiceDeclarations.fs +++ b/src/fsharp/symbols/SymbolHelpers.fs @@ -31,34 +31,172 @@ open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.InfoReader - -type internal Layout = layout +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.CompileOps module EnvMisc2 = let maxMembers = GetEnvInteger "FCS_MaxMembersInQuickInfo" 10 - /// dataTipSpinWaitTime limits how long we block the UI thread while a tooltip pops up next to a selected item in an IntelliSense completion list. - /// This time appears to be somewhat amortized by the time it takes the VS completion UI to actually bring up the tooltip after selecting an item in the first place. - let dataTipSpinWaitTime = GetEnvInteger "FCS_ToolTipSpinWaitTime" 300 - //---------------------------------------------------------------------------- -// Display characteristics of typechecking items -//-------------------------------------------------------------------------- +// Object model for diagnostics + +[] +type FSharpErrorSeverity = + | Warning + | Error + +type FSharpErrorInfo(fileName, s:pos, e:pos, severity: FSharpErrorSeverity, message: string, subcategory: string, errorNum: int) = + member __.StartLine = Line.toZ s.Line + member __.StartLineAlternate = s.Line + member __.EndLine = Line.toZ e.Line + member __.EndLineAlternate = e.Line + member __.StartColumn = s.Column + member __.EndColumn = e.Column + member __.Severity = severity + member __.Message = message + member __.Subcategory = subcategory + member __.FileName = fileName + member __.ErrorNumber = errorNum + member __.WithStart(newStart) = FSharpErrorInfo(fileName, newStart, e, severity, message, subcategory, errorNum) + member __.WithEnd(newEnd) = FSharpErrorInfo(fileName, s, newEnd, severity, message, subcategory, errorNum) + override __.ToString()= sprintf "%s (%d,%d)-(%d,%d) %s %s %s" fileName (int s.Line) (s.Column + 1) (int e.Line) (e.Column + 1) subcategory (if severity=FSharpErrorSeverity.Warning then "warning" else "error") message + + /// Decompose a warning or error into parts: position, severity, message, error number + static member CreateFromException(exn, isError, trim:bool, fallbackRange:range) = + let m = match GetRangeOfDiagnostic exn with Some m -> m | None -> fallbackRange + let e = if trim then m.Start else m.End + let msg = bufs (fun buf -> OutputPhasedDiagnostic buf exn false) + let errorNum = GetDiagnosticNumber exn + FSharpErrorInfo(m.FileName, m.Start, e, (if isError then FSharpErrorSeverity.Error else FSharpErrorSeverity.Warning), msg, exn.Subcategory(), errorNum) + + /// Decompose a warning or error into parts: position, severity, message, error number + static member CreateFromExceptionAndAdjustEof(exn, isError, trim:bool, fallbackRange:range, (linesCount:int, lastLength:int)) = + let r = FSharpErrorInfo.CreateFromException(exn,isError,trim,fallbackRange) + + // Adjust to make sure that errors reported at Eof are shown at the linesCount + let startline, schange = min (r.StartLineAlternate, false) (linesCount, true) + let endline, echange = min (r.EndLineAlternate, false) (linesCount, true) + + if not (schange || echange) then r + else + let r = if schange then r.WithStart(mkPos startline lastLength) else r + if echange then r.WithEnd(mkPos endline (1 + lastLength)) else r + + +/// Use to reset error and warning handlers +[] +type ErrorScope() = + let mutable errors = [] + static let mutable mostRecentError = None + let unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck + let unwindEL = + PushErrorLoggerPhaseUntilUnwind (fun _oldLogger -> + { new ErrorLogger("ErrorScope") with + member x.DiagnosticSink(exn, isError) = + let err = FSharpErrorInfo.CreateFromException(exn,isError,false,range.Zero) + errors <- err :: errors + if isError then + mostRecentError <- Some err + member x.ErrorCount = errors.Length }) + + member x.Errors = errors |> List.filter (fun error -> error.Severity = FSharpErrorSeverity.Error) + member x.Warnings = errors |> List.filter (fun error -> error.Severity = FSharpErrorSeverity.Warning) + member x.Diagnostics = errors + member x.TryGetFirstErrorText() = + match x.Errors with + | error :: _ -> Some error.Message + | [] -> None + + interface IDisposable with + member d.Dispose() = + unwindEL.Dispose() (* unwind pushes when ErrorScope disposes *) + unwindBP.Dispose() -/// Interface that defines methods for comparing objects using partial equality relation -type IPartialEqualityComparer<'T> = - inherit IEqualityComparer<'T> - /// Can the specified object be tested for equality? - abstract InEqualityRelation : 'T -> bool - -module IPartialEqualityComparer = - let On f (c: IPartialEqualityComparer<_>) = - { new IPartialEqualityComparer<_> with - member __.InEqualityRelation x = c.InEqualityRelation (f x) - member __.Equals(x, y) = c.Equals(f x, f y) - member __.GetHashCode x = c.GetHashCode(f x) } + static member MostRecentError = mostRecentError + static member Protect<'a> (m:range) (f:unit->'a) (err:string->'a): 'a = + use errorScope = new ErrorScope() + let res = + try + Some (f()) + with e -> errorRecovery e m; None + match res with + | Some res ->res + | None -> + match errorScope.TryGetFirstErrorText() with + | Some text -> err text + | None -> err "" + + static member ProtectWithDefault m f dflt = + ErrorScope.Protect m f (fun _ -> dflt) + + static member ProtectAndDiscard m f = + ErrorScope.Protect m f (fun _ -> ()) + + +/// An error logger that capture errors, filtering them according to warning levels etc. +type internal CompilationErrorLogger (debugName:string, tcConfig:TcConfig) = + inherit ErrorLogger("CompilationErrorLogger("+debugName+")") + + let mutable errorCount = 0 + let diagnostics = new ResizeArray<_>() + + override x.DiagnosticSink(exn, isError) = + if isError || ReportWarningAsError (tcConfig.globalWarnLevel, tcConfig.specificWarnOff, tcConfig.specificWarnOn, tcConfig.specificWarnAsError, tcConfig.specificWarnAsWarn, tcConfig.globalWarnAsError) exn then + diagnostics.Add(exn, isError) + errorCount <- errorCount + 1 + else if ReportWarning (tcConfig.globalWarnLevel, tcConfig.specificWarnOff, tcConfig.specificWarnOn) exn then + diagnostics.Add(exn, isError) + + override x.ErrorCount = errorCount + + member x.GetErrors() = + [ for (e,isError) in diagnostics -> e, (if isError then FSharpErrorSeverity.Error else FSharpErrorSeverity.Warning) ] + + +/// This represents the global state established as each task function runs as part of the build. +/// +/// Use to reset error and warning handlers. +type CompilationGlobalsScope(errorLogger:ErrorLogger, phase: BuildPhase) = + let unwindEL = PushErrorLoggerPhaseUntilUnwind(fun _ -> errorLogger) + let unwindBP = PushThreadBuildPhaseUntilUnwind phase + // Return the disposable object that cleans up + interface IDisposable with + member d.Dispose() = + unwindBP.Dispose() + unwindEL.Dispose() + +module ErrorHelpers = + let ReportError (tcConfig:TcConfig, allErrors, mainInputFileName, fileInfo, (exn, sev)) = + [ let isError = (sev = FSharpErrorSeverity.Error) || ReportWarningAsError (tcConfig.globalWarnLevel, tcConfig.specificWarnOff, tcConfig.specificWarnOn, tcConfig.specificWarnAsError, tcConfig.specificWarnAsWarn, tcConfig.globalWarnAsError) exn + if (isError || ReportWarning (tcConfig.globalWarnLevel, tcConfig.specificWarnOff, tcConfig.specificWarnOn) exn) then + let oneError trim exn = + [ // We use the first line of the file as a fallbackRange for reporting unexpected errors. + // Not ideal, but it's hard to see what else to do. + let fallbackRange = rangeN mainInputFileName 1 + let ei = FSharpErrorInfo.CreateFromExceptionAndAdjustEof (exn, isError, trim, fallbackRange, fileInfo) + if allErrors || (ei.FileName=mainInputFileName) || (ei.FileName=Microsoft.FSharp.Compiler.TcGlobals.DummyFileNameForRangesWithoutASpecificLocation) then + yield ei ] + + let mainError,relatedErrors = SplitRelatedDiagnostics exn + yield! oneError false mainError + for e in relatedErrors do + yield! oneError true e ] + + let CreateErrorInfos (tcConfig:TcConfig, allErrors, mainInputFileName, errors) = + let fileInfo = (Int32.MaxValue, Int32.MaxValue) + [| for (exn,isError) in errors do + yield! ReportError (tcConfig, allErrors, mainInputFileName, fileInfo, (exn, isError)) |] + + +//---------------------------------------------------------------------------- +// Object model for tooltips and helpers for their generation from items +#if COMPILER_PUBLIC_API +type Layout = Internal.Utilities.StructuredFormat.Layout +#else +type internal Layout = Internal.Utilities.StructuredFormat.Layout +#endif /// Describe a comment as either a block of text or a file+signature reference into an intellidoc file. [] @@ -94,22 +232,34 @@ type FSharpToolTipElement<'T> = Group [ FSharpToolTipElementData<'T>.Create(layout,xml,?typeMapping=typeMapping,?paramName=paramName,?remarks=remarks) ] /// A single data tip display element with where text is expressed as string +#if COMPILER_PUBLIC_API type FSharpToolTipElement = FSharpToolTipElement +#else +type internal FSharpToolTipElement = FSharpToolTipElement +#endif + /// A single data tip display element with where text is expressed as +#if COMPILER_PUBLIC_API +type FSharpStructuredToolTipElement = FSharpToolTipElement +#else type internal FSharpStructuredToolTipElement = FSharpToolTipElement +#endif /// Information for building a data tip box. type FSharpToolTipText<'T> = /// A list of data tip elements to display. | FSharpToolTipText of FSharpToolTipElement<'T> list -// specialization that stores data as strings +#if COMPILER_PUBLIC_API type FSharpToolTipText = FSharpToolTipText -// specialization that stores data as +type FSharpStructuredToolTipText = FSharpToolTipText +#else +type internal FSharpToolTipText = FSharpToolTipText type internal FSharpStructuredToolTipText = FSharpToolTipText +#endif -module internal Tooltips = +module Tooltips = let ToFSharpToolTipElement tooltip = match tooltip with | FSharpStructuredToolTipElement.None -> @@ -152,16 +302,8 @@ type CompletionItem = member x.Item = x.ItemWithInst.Item -[] -type FSharpMethodGroupItemParameter(name: string, canonicalTypeTextForSorting: string, display: Layout, isOptional: bool) = - member __.ParameterName = name - member __.CanonicalTypeTextForSorting = canonicalTypeTextForSorting - member __.StructuredDisplay = display - member __.Display = showL display - member __.IsOptional = isOptional - [] -module internal ItemDescriptionsImpl = +module internal SymbolHelpers = let isFunction g typ = let _,tau = tryDestForallTy g typ @@ -340,8 +482,11 @@ module internal ItemDescriptionsImpl = // Generalize to get a formal signature let formalTypars = tcref.Typars(m) let formalTypeInst = generalizeTypars formalTypars - let formalTypeInfo = ILTypeInfo.FromType g (TType_app(tcref,formalTypeInst)) - Some(nlref.Ccu.FileName,formalTypars,formalTypeInfo) + let ty = TType_app(tcref,formalTypeInst) + if isILAppTy g ty then + let formalTypeInfo = ILTypeInfo.FromType g ty + Some(nlref.Ccu.FileName,formalTypars,formalTypeInfo) + else None let mkXmlComment thing = match thing with @@ -532,25 +677,6 @@ module internal ItemDescriptionsImpl = let pubpathOfTyconRef (x:TyconRef) = x.PublicPath - // Wrapper type for use by the 'partialDistinctBy' function - [] - type WrapType<'T> = Wrap of 'T - - // Like Seq.distinctBy but only filters out duplicates for some of the elements - let partialDistinctBy (per:IPartialEqualityComparer<'T>) seq = - let wper = - { new IPartialEqualityComparer> with - member __.InEqualityRelation (Wrap x) = per.InEqualityRelation (x) - member __.Equals(Wrap x, Wrap y) = per.Equals(x, y) - member __.GetHashCode (Wrap x) = per.GetHashCode(x) } - // Wrap a Wrap _ around all keys in case the key type is itself a type using null as a representation - let dict = Dictionary,obj>(wper) - seq |> List.filter (fun v -> - let key = Wrap(v) - if (per.InEqualityRelation(v)) then - if dict.ContainsKey(key) then false else (dict.[key] <- null; true) - else true) - let (|ItemWhereTypIsPreferred|_|) item = match item with | Item.DelegateCtor ty @@ -678,7 +804,7 @@ module internal ItemDescriptionsImpl = // Remove items containing the same module references let RemoveDuplicateModuleRefs modrefs = - modrefs |> partialDistinctBy + modrefs |> IPartialEqualityComparer.partialDistinctBy { new IPartialEqualityComparer with member x.InEqualityRelation _ = true member x.Equals(item1, item2) = (fullDisplayTextOfModRef item1 = fullDisplayTextOfModRef item2) @@ -686,11 +812,11 @@ module internal ItemDescriptionsImpl = /// Remove all duplicate items let RemoveDuplicateItems g (items: ItemWithInst list) = - items |> partialDistinctBy (IPartialEqualityComparer.On (fun item -> item.Item) (ItemDisplayPartialEquality g)) + items |> IPartialEqualityComparer.partialDistinctBy (IPartialEqualityComparer.On (fun item -> item.Item) (ItemDisplayPartialEquality g)) /// Remove all duplicate items let RemoveDuplicateCompletionItems g items = - items |> partialDistinctBy (CompletionItemDisplayPartialEquality g) + items |> IPartialEqualityComparer.partialDistinctBy (CompletionItemDisplayPartialEquality g) let IsExplicitlySuppressed (g: TcGlobals) (item: Item) = // This may explore assemblies that are not in the reference set. @@ -1085,115 +1211,6 @@ module internal ItemDescriptionsImpl = | _ -> FSharpStructuredToolTipElement.None - let printCanonicalizedTypeName g (denv:DisplayEnv) tau = - // get rid of F# abbreviations and such - let strippedType = stripTyEqnsWrtErasure EraseAll g tau - // pretend no namespaces are open - let denv = denv.SetOpenPaths([]) - // now printing will see a .NET-like canonical representation, that is good for sorting overloads into a reasonable order (see bug 94520) - NicePrint.stringOfTy denv strippedType - - let PrettyParamOfRecdField g denv (f: RecdField) = - FSharpMethodGroupItemParameter( - name = f.Name, - canonicalTypeTextForSorting = printCanonicalizedTypeName g denv f.FormalType, - // Note: the instantiation of any type parameters is currently incorporated directly into the type - // rather than being returned separately. - display = NicePrint.prettyLayoutOfType denv f.FormalType, - isOptional=false) - - let PrettyParamOfUnionCaseField g denv isGenerated (i: int) (f: RecdField) = - let initial = PrettyParamOfRecdField g denv f - let display = - if isGenerated i f then - initial.StructuredDisplay - else - // TODO: in this case ucinst is ignored - it gives the instantiation of the type parameters of - // the union type containing this case. - NicePrint.layoutOfParamData denv (ParamData(false, false, NotOptional, NoCallerInfo, Some f.Id, ReflectedArgInfo.None, f.FormalType)) - FSharpMethodGroupItemParameter( - name=initial.ParameterName, - canonicalTypeTextForSorting=initial.CanonicalTypeTextForSorting, - display=display, - isOptional=false) - - let ParamOfParamData g denv (ParamData(_isParamArrayArg, _isOutArg, optArgInfo, _callerInfoInfo, nmOpt, _reflArgInfo, pty) as paramData) = - FSharpMethodGroupItemParameter( - name = (match nmOpt with None -> "" | Some pn -> pn.idText), - canonicalTypeTextForSorting = printCanonicalizedTypeName g denv pty, - display = NicePrint.layoutOfParamData denv paramData, - isOptional=optArgInfo.IsOptional) - - // TODO this code is similar to NicePrint.fs:formatParamDataToBuffer, refactor or figure out why different? - let PrettyParamsOfParamDatas g denv typarInst (paramDatas:ParamData list) rty = - let paramInfo,paramTypes = - paramDatas - |> List.map (fun (ParamData(isParamArrayArg, _isOutArg, optArgInfo, _callerInfoInfo, nmOpt, _reflArgInfo, pty)) -> - let isOptArg = optArgInfo.IsOptional - match nmOpt, isOptArg, tryDestOptionTy denv.g pty with - // Layout an optional argument - | Some id, true, ptyOpt -> - let nm = id.idText - // detect parameter type, if ptyOpt is None - this is .NET style optional argument - let pty = defaultArg ptyOpt pty - (nm, isOptArg, SepL.questionMark ^^ (wordL (TaggedTextOps.tagParameter nm))), pty - // Layout an unnamed argument - | None, _,_ -> - ("", isOptArg, emptyL), pty - // Layout a named argument - | Some id,_,_ -> - let nm = id.idText - let prefix = - if isParamArrayArg then - NicePrint.PrintUtilities.layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute ^^ - wordL (TaggedTextOps.tagParameter nm) ^^ - RightL.colon - //sprintf "%s %s: " (NicePrint.PrintUtilities.layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute |> showL) nm - else - wordL (TaggedTextOps.tagParameter nm) ^^ - RightL.colon - //sprintf "%s: " nm - (nm,isOptArg, prefix),pty) - |> List.unzip - - // Prettify everything - let prettyTyparInst, (prettyParamTys, _prettyRetTy), (prettyParamTysL, prettyRetTyL), prettyConstraintsL = - NicePrint.prettyLayoutOfInstAndSig denv (typarInst, paramTypes, rty) - - // Remake the params using the prettified versions - let prettyParams = - (paramInfo,prettyParamTys,prettyParamTysL) |||> List.map3 (fun (nm,isOptArg,paramPrefix) tau tyL -> - FSharpMethodGroupItemParameter( - name = nm, - canonicalTypeTextForSorting = printCanonicalizedTypeName g denv tau, - display = paramPrefix ^^ tyL, - isOptional=isOptArg - )) - - prettyTyparInst, prettyParams, prettyRetTyL, prettyConstraintsL - - let PrettyParamsOfTypes g denv typarInst paramTys retTy = - - // Prettify everything - let prettyTyparInst, (prettyParamTys, _prettyRetTy), (prettyParamTysL, prettyRetTyL), prettyConstraintsL = - NicePrint.prettyLayoutOfInstAndSig denv (typarInst, paramTys, retTy) - - // Remake the params using the prettified versions - let parameters = - (prettyParamTys,prettyParamTysL) - ||> List.zip - |> List.map (fun (tau, tyL) -> - FSharpMethodGroupItemParameter( - name = "", - canonicalTypeTextForSorting = printCanonicalizedTypeName g denv tau, - display = tyL, - isOptional=false - )) - - // Return the results - prettyTyparInst, parameters, prettyRetTyL, prettyConstraintsL - - #if EXTENSIONTYPING /// Determine if an item is a provided type @@ -1248,188 +1265,9 @@ module internal ItemDescriptionsImpl = | ItemIsProvidedTypeWithStaticArguments m g staticParameters -> Some staticParameters | ItemIsProvidedMethodWithStaticArguments staticParameters -> Some staticParameters | _ -> None -#endif - /// Get the set of static parameters associated with an item - let StaticParamsOfItem (infoReader:InfoReader) m denv item = - let amap = infoReader.amap - let g = infoReader.g - match item with -#if EXTENSIONTYPING - | ItemIsWithStaticArguments m g staticParameters -> - staticParameters - |> Array.map (fun sp -> - let typ = Import.ImportProvidedType amap m (sp.PApply((fun x -> x.ParameterType),m)) - let spKind = NicePrint.prettyLayoutOfType denv typ - let spName = sp.PUntaint((fun sp -> sp.Name), m) - let spOpt = sp.PUntaint((fun sp -> sp.IsOptional), m) - FSharpMethodGroupItemParameter( - name = spName, - canonicalTypeTextForSorting = showL spKind, - display = (if spOpt then SepL.questionMark else emptyL) ^^ wordL (TaggedTextOps.tagParameter spName) ^^ RightL.colon ^^ spKind, - //display = sprintf "%s%s: %s" (if spOpt then "?" else "") spName spKind, - isOptional=spOpt)) #endif - | _ -> [| |] - - /// Get all the information about parameters and "prettify" the types by choosing nice type variable - /// names. This is similar to the other variations on "show me an item" code. This version is - /// is used when presenting groups of methods (see FSharpMethodGroup). It is possible these different - /// versions could be better unified. - let rec PrettyParamsAndReturnTypeOfItem (infoReader:InfoReader) m denv (item: ItemWithInst) = - let amap = infoReader.amap - let g = infoReader.g - let denv = {SimplerDisplayEnv denv with useColonForReturnType=true} - match item.Item with - | Item.Value vref -> - let getPrettyParamsOfTypes() = - let tau = vref.TauType - match tryDestFunTy denv.g tau with - | Some(arg,rtau) -> - let args = tryDestRefTupleTy denv.g arg - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfTypes g denv item.TyparInst args rtau - // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned - // for display as part of the method group - prettyParams, prettyRetTyL - | None -> - let _prettyTyparInst, prettyTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] tau - [], prettyTyL - - match vref.ValReprInfo with - | None -> - // ValReprInfo = None i.e. in let bindings defined in types or in local functions - // in this case use old approach and return only information about types - getPrettyParamsOfTypes () - - | Some valRefInfo -> - // ValReprInfo will exist for top-level syntactic functions - // per spec: binding is considered to define a syntactic function if it is either a function or its immediate right-hand-side is a anonymous function - let (_, argInfos, lastRetTy, _) = GetTopValTypeInFSharpForm g valRefInfo vref.Type m - match argInfos with - | [] -> - // handles cases like 'let foo = List.map' - getPrettyParamsOfTypes() - | firstCurriedArgInfo::_ -> - // result 'paramDatas' collection corresponds to the first argument of curried function - // i.e. let func (a : int) (b : int) = a + b - // paramDatas will contain information about a and retTy will be: int -> int - // This is good enough as we don't provide ways to display info for the second curried argument - let firstCurriedParamDatas = - firstCurriedArgInfo - |> List.map ParamNameAndType.FromArgInfo - |> List.map (fun (ParamNameAndType(nmOpt, pty)) -> ParamData(false, false, NotOptional, NoCallerInfo, nmOpt, ReflectedArgInfo.None, pty)) - - // Adjust the return type so it only strips the first argument - let curriedRetTy = - match tryDestFunTy denv.g vref.TauType with - | Some(_,rtau) -> rtau - | None -> lastRetTy - - let _prettyTyparInst, prettyFirstCurriedParams, prettyCurriedRetTyL, prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst firstCurriedParamDatas curriedRetTy - - let prettyCurriedRetTyL = prettyCurriedRetTyL ^^ SepL.space ^^ prettyConstraintsL - - prettyFirstCurriedParams, prettyCurriedRetTyL - - | Item.UnionCase(ucinfo,_) -> - let prettyParams = - match ucinfo.UnionCase.RecdFields with - | [f] -> [PrettyParamOfUnionCaseField g denv NicePrint.isGeneratedUnionCaseField -1 f] - | fs -> fs |> List.mapi (PrettyParamOfUnionCaseField g denv NicePrint.isGeneratedUnionCaseField) - let rty = generalizedTyconRef ucinfo.TyconRef - let rtyL = NicePrint.layoutType denv rty - prettyParams, rtyL - - | Item.ActivePatternCase(apref) -> - let v = apref.ActivePatternVal - let tau = v.TauType - let args, resTy = stripFunTy denv.g tau - - let apinfo = Option.get (TryGetActivePatternInfo v) - let aparity = apinfo.Names.Length - - let rty = if aparity <= 1 then resTy else (argsOfAppTy g resTy).[apref.CaseIndex] - - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfTypes g denv item.TyparInst args rty - // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned - // for display as part of the method group - prettyParams, prettyRetTyL - - | Item.ExnCase ecref -> - let prettyParams = ecref |> recdFieldsOfExnDefRef |> List.mapi (PrettyParamOfUnionCaseField g denv NicePrint.isGeneratedExceptionField) - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] g.exn_ty - prettyParams, prettyRetTyL - - | Item.RecdField rfinfo -> - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] rfinfo.FieldType - [], prettyRetTyL - - | Item.ILField finfo -> - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] (finfo.FieldType(amap,m)) - [], prettyRetTyL - - | Item.Event einfo -> - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] (PropTypOfEventInfo infoReader m AccessibleFromSomewhere einfo) - [], prettyRetTyL - - | Item.Property(_,pinfo :: _) -> - let paramDatas = pinfo.GetParamDatas(amap,m) - let rty = pinfo.GetPropertyType(amap,m) - - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst paramDatas rty - // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned - // for display as part of the method group - prettyParams, prettyRetTyL - - | Item.CtorGroup(_,(minfo :: _)) - | Item.MethodGroup(_,(minfo :: _),_) -> - let paramDatas = minfo.GetParamDatas(amap, m, minfo.FormalMethodInst) |> List.head - let rty = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst paramDatas rty - // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned - // for display as part of the method group - prettyParams, prettyRetTyL - - | Item.CustomBuilder (_,vref) -> - PrettyParamsAndReturnTypeOfItem infoReader m denv { item with Item = Item.Value vref } - - | Item.TypeVar _ -> - [], emptyL - - | Item.CustomOperation (_,usageText, Some minfo) -> - match usageText() with - | None -> - let argNamesAndTys = ParamNameAndTypesOfUnaryCustomOperation g minfo - let argTys, _ = PrettyTypes.PrettifyTypes g (argNamesAndTys |> List.map (fun (ParamNameAndType(_,ty)) -> ty)) - let paramDatas = (argNamesAndTys, argTys) ||> List.map2 (fun (ParamNameAndType(nmOpt, _)) argTy -> ParamData(false, false, NotOptional, NoCallerInfo, nmOpt, ReflectedArgInfo.None,argTy)) - let rty = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst paramDatas rty - // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned - // for display as part of the method group - prettyParams, prettyRetTyL - - | Some _ -> - let rty = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] rty - [], prettyRetTyL // no parameter data available for binary operators like 'zip', 'join' and 'groupJoin' since they use bespoke syntax - - | Item.FakeInterfaceCtor typ -> - let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] typ - [], prettyRetTyL - - | Item.DelegateCtor delty -> - let (SigOfFunctionForDelegate(_, _, _, fty)) = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomeFSharpCode - - // No need to pass more generic type information in here since the instanitations have already been applied - let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst [ParamData(false, false, NotOptional, NoCallerInfo, None, ReflectedArgInfo.None, fty)] delty - - // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned - // for display as part of the method group - prettyParams, prettyRetTyL - - | _ -> - [], emptyL /// Get the "F1 Keyword" associated with an item, for looking up documentatio help indexes on the web let rec GetF1Keyword g item = @@ -1593,94 +1431,6 @@ module internal ItemDescriptionsImpl = (fun () -> FormatItemDescriptionToToolTipElement isListItem infoReader m denv item) (fun err -> FSharpStructuredToolTipElement.CompositionError(err)) - /// Compute the index of the VS glyph shown with an item in the Intellisense menu - let GlyphOfItem(denv, item) : FSharpGlyph = - /// Find the glyph for the given representation. - let reprToGlyph repr = - match repr with - | TFSharpObjectRepr om -> - match om.fsobjmodel_kind with - | TTyconClass -> FSharpGlyph.Class - | TTyconInterface -> FSharpGlyph.Interface - | TTyconStruct -> FSharpGlyph.Struct - | TTyconDelegate _ -> FSharpGlyph.Delegate - | TTyconEnum _ -> FSharpGlyph.Enum - | TRecdRepr _ -> FSharpGlyph.Type - | TUnionRepr _ -> FSharpGlyph.Union - | TILObjectRepr (TILObjectReprData (_,_,td)) -> - match td.tdKind with - | ILTypeDefKind.Class -> FSharpGlyph.Class - | ILTypeDefKind.ValueType -> FSharpGlyph.Struct - | ILTypeDefKind.Interface -> FSharpGlyph.Interface - | ILTypeDefKind.Enum -> FSharpGlyph.Enum - | ILTypeDefKind.Delegate -> FSharpGlyph.Delegate - | TAsmRepr _ -> FSharpGlyph.Typedef - | TMeasureableRepr _-> FSharpGlyph.Typedef -#if EXTENSIONTYPING - | TProvidedTypeExtensionPoint _-> FSharpGlyph.Typedef - | TProvidedNamespaceExtensionPoint _-> FSharpGlyph.Typedef -#endif - | TNoRepr -> FSharpGlyph.Class - - /// Find the glyph for the given type representation. - let typeToGlyph typ = - if isAppTy denv.g typ then - let tcref = tcrefOfAppTy denv.g typ - tcref.TypeReprInfo |> reprToGlyph - elif isStructTupleTy denv.g typ then FSharpGlyph.Struct - elif isRefTupleTy denv.g typ then FSharpGlyph.Class - elif isFunction denv.g typ then FSharpGlyph.Delegate - elif isTyparTy denv.g typ then FSharpGlyph.Struct - else FSharpGlyph.Typedef - - // This may explore assemblies that are not in the reference set, - // e.g. for type abbreviations to types not in the reference set. - // In this case just use GlyphMajor.Class. - protectAssemblyExploration FSharpGlyph.Class (fun () -> - match item with - | Item.Value(vref) | Item.CustomBuilder (_,vref) -> - if isFunction denv.g vref.Type then FSharpGlyph.Method - elif vref.LiteralValue.IsSome then FSharpGlyph.Constant - else FSharpGlyph.Variable - | Item.Types(_,typ::_) -> typeToGlyph (stripTyEqns denv.g typ) - | Item.UnionCase _ - | Item.ActivePatternCase _ -> FSharpGlyph.EnumMember - | Item.ExnCase _ -> FSharpGlyph.Exception - | Item.RecdField _ -> FSharpGlyph.Field - | Item.ILField _ -> FSharpGlyph.Field - | Item.Event _ -> FSharpGlyph.Event - | Item.Property _ -> FSharpGlyph.Property - | Item.CtorGroup _ - | Item.DelegateCtor _ - | Item.FakeInterfaceCtor _ - | Item.CustomOperation _ -> FSharpGlyph.Method - | Item.MethodGroup (_, minfos, _) when minfos |> List.forall (fun minfo -> minfo.IsExtensionMember) -> FSharpGlyph.ExtensionMethod - | Item.MethodGroup _ -> FSharpGlyph.Method - | Item.TypeVar _ - | Item.Types _ -> FSharpGlyph.Class - | Item.UnqualifiedType (tcref :: _) -> - if tcref.IsEnumTycon || tcref.IsILEnumTycon then FSharpGlyph.Enum - elif tcref.IsExceptionDecl then FSharpGlyph.Exception - elif tcref.IsFSharpDelegateTycon then FSharpGlyph.Delegate - elif tcref.IsFSharpInterfaceTycon then FSharpGlyph.Interface - elif tcref.IsFSharpStructOrEnumTycon then FSharpGlyph.Struct - elif tcref.IsModule then FSharpGlyph.Module - elif tcref.IsNamespace then FSharpGlyph.NameSpace - elif tcref.IsUnionTycon then FSharpGlyph.Union - elif tcref.IsILTycon then - let (TILObjectReprData (_, _, tydef)) = tcref.ILTyconInfo - if tydef.IsInterface then FSharpGlyph.Interface - elif tydef.IsDelegate then FSharpGlyph.Delegate - elif tydef.IsEnum then FSharpGlyph.Enum - elif tydef.IsStructOrEnum then FSharpGlyph.Struct - else FSharpGlyph.Class - else FSharpGlyph.Class - | Item.ModuleOrNamespaces(modref::_) -> - if modref.IsNamespace then FSharpGlyph.NameSpace else FSharpGlyph.Module - | Item.ArgName _ -> FSharpGlyph.Variable - | Item.SetterArg _ -> FSharpGlyph.Variable - | _ -> FSharpGlyph.Error) - /// Get rid of groups of overloads an replace them with single items. let FlattenItems g m item = match item with @@ -1706,380 +1456,3 @@ module internal ItemDescriptionsImpl = | Item.CustomBuilder _ -> [] | _ -> [] - /// Get rid of groups of overloads an replace them with single items. - /// (This looks like it is doing the a similar thing as FlattenItems, this code - /// duplication could potentially be removed) - let AnotherFlattenItems g m item = - match item with - | Item.CtorGroup(nm,cinfos) -> List.map (fun minfo -> Item.CtorGroup(nm,[minfo])) cinfos - | Item.FakeInterfaceCtor _ - | Item.DelegateCtor _ -> [item] - | Item.NewDef _ - | Item.ILField _ -> [] - | Item.Event _ -> [] - | Item.RecdField(rfinfo) -> - if isFunction g rfinfo.FieldType then [item] else [] - | Item.Value v -> - if isFunction g v.Type then [item] else [] - | Item.UnionCase(ucr,_) -> - if not ucr.UnionCase.IsNullary then [item] else [] - | Item.ExnCase(ecr) -> - if isNil (recdFieldsOfExnDefRef ecr) then [] else [item] - | Item.Property(_,pinfos) -> - let pinfo = List.head pinfos - if pinfo.IsIndexer then [item] else [] -#if EXTENSIONTYPING - | ItemIsWithStaticArguments m g _ -> - // we pretend that provided-types-with-static-args are method-like in order to get ParamInfo for them - [item] -#endif - | Item.MethodGroup(nm,minfos,orig) -> minfos |> List.map (fun minfo -> Item.MethodGroup(nm,[minfo],orig)) - | Item.CustomOperation(_name, _helpText, _minfo) -> [item] - | Item.TypeVar _ -> [] - | Item.CustomBuilder _ -> [] - | _ -> [] - -type FSharpAccessibility(a:Accessibility, ?isProtected) = - let isProtected = defaultArg isProtected false - - let isInternalCompPath x = - match x with - | CompPath(ILScopeRef.Local,[]) -> true - | _ -> false - - let (|Public|Internal|Private|) (TAccess p) = - match p with - | [] -> Public - | _ when List.forall isInternalCompPath p -> Internal - | _ -> Private - - member __.IsPublic = not isProtected && match a with Public -> true | _ -> false - - member __.IsPrivate = not isProtected && match a with Private -> true | _ -> false - - member __.IsInternal = not isProtected && match a with Internal -> true | _ -> false - - member __.IsProtected = isProtected - - member __.Contents = a - - override __.ToString() = - let (TAccess paths) = a - let mangledTextOfCompPath (CompPath(scoref,path)) = getNameOfScopeRef scoref + "/" + textOfPath (List.map fst path) - String.concat ";" (List.map mangledTextOfCompPath paths) - -/// An intellisense declaration -[] -type FSharpDeclarationListItem(name: string, nameInCode: string, fullName: string, glyph: FSharpGlyph, info, accessibility: FSharpAccessibility option, - kind: CompletionItemKind, isOwnMember: bool, priority: int, isResolved: bool, namespaceToOpen: string option) = - - let mutable descriptionTextHolder: FSharpToolTipText<_> option = None - let mutable task = null - - member __.Name = name - member __.NameInCode = nameInCode - - member __.StructuredDescriptionTextAsync = - match info with - | Choice1Of2 (items: CompletionItem list, infoReader, m, denv, reactor:IReactorOperations, checkAlive) -> - // reactor causes the lambda to execute on the background compiler thread, through the Reactor - reactor.EnqueueAndAwaitOpAsync ("StructuredDescriptionTextAsync", fun ctok -> - RequireCompilationThread ctok - // This is where we do some work which may touch TAST data structures owned by the IncrementalBuilder - infoReader, item etc. - // It is written to be robust to a disposal of an IncrementalBuilder, in which case it will just return the empty string. - // It is best to think of this as a "weak reference" to the IncrementalBuilder, i.e. this code is written to be robust to its - // disposal. Yes, you are right to scratch your head here, but this is ok. - cancellable.Return( - if checkAlive() then - FSharpToolTipText(items |> List.map (fun x -> ItemDescriptionsImpl.FormatStructuredDescriptionOfItem true infoReader m denv x.ItemWithInst)) - else - FSharpToolTipText [ FSharpStructuredToolTipElement.Single(wordL (tagText (FSComp.SR.descriptionUnavailable())), FSharpXmlDoc.None) ])) - | Choice2Of2 result -> - async.Return result - - member decl.DescriptionTextAsync = - decl.StructuredDescriptionTextAsync - |> Tooltips.Map Tooltips.ToFSharpToolTipText - - member decl.StructuredDescriptionText = - match descriptionTextHolder with - | Some descriptionText -> descriptionText - | None -> - match info with - | Choice1Of2 _ -> - - // The dataTipSpinWaitTime limits how long we block the UI thread while a tooltip pops up next to a selected item in an IntelliSense completion list. - // This time appears to be somewhat amortized by the time it takes the VS completion UI to actually bring up the tooltip after selecting an item in the first place. - if isNull task then - // kick off the actual (non-cooperative) work - task <- System.Threading.Tasks.Task.Factory.StartNew(fun() -> - let text = decl.StructuredDescriptionTextAsync |> Async.RunSynchronously - descriptionTextHolder <- Some text) - - // The dataTipSpinWaitTime limits how long we block the UI thread while a tooltip pops up next to a selected item in an IntelliSense completion list. - // This time appears to be somewhat amortized by the time it takes the VS completion UI to actually bring up the tooltip after selecting an item in the first place. - task.Wait EnvMisc2.dataTipSpinWaitTime |> ignore - match descriptionTextHolder with - | Some text -> text - | None -> FSharpToolTipText [ FSharpStructuredToolTipElement.Single(wordL (tagText (FSComp.SR.loadingDescription())), FSharpXmlDoc.None) ] - - | Choice2Of2 result -> - result - - member decl.DescriptionText = decl.StructuredDescriptionText |> Tooltips.ToFSharpToolTipText - member __.Glyph = glyph - member __.Accessibility = accessibility - member __.Kind = kind - member __.IsOwnMember = isOwnMember - member __.MinorPriority = priority - member __.FullName = fullName - member __.IsResolved = isResolved - member __.NamespaceToOpen = namespaceToOpen - -/// A table of declarations for Intellisense completion -[] -type FSharpDeclarationListInfo(declarations: FSharpDeclarationListItem[], isForType: bool, isError: bool) = - member __.Items = declarations - member __.IsForType = isForType - member __.IsError = isError - - // Make a 'Declarations' object for a set of selected items - static member Create(infoReader:InfoReader, m, denv, getAccessibility, items: CompletionItem list, reactor, currentNamespaceOrModule: string[] option, isAttributeApplicationContext: bool, checkAlive) = - let g = infoReader.g - let isForType = items |> List.exists (fun x -> x.Type.IsSome) - let items = items |> ItemDescriptionsImpl.RemoveExplicitlySuppressedCompletionItems g - - let tyconRefOptEq tref1 tref2 = - match tref1 with - | Some tref1 -> tyconRefEq g tref1 tref2 - | None -> false - - // Adjust items priority. Sort by name. For things with the same name, - // - show types with fewer generic parameters first - // - show types before over other related items - they usually have very useful XmlDocs - let _, _, items = - items - |> List.map (fun x -> - match x.Item with - | Item.Types (_,(TType_app(tcref,_) :: _)) -> { x with MinorPriority = 1 + tcref.TyparsNoRange.Length } - // Put delegate ctors after types, sorted by #typars. RemoveDuplicateItems will remove FakeInterfaceCtor and DelegateCtor if an earlier type is also reported with this name - | Item.FakeInterfaceCtor (TType_app(tcref,_)) - | Item.DelegateCtor (TType_app(tcref,_)) -> { x with MinorPriority = 1000 + tcref.TyparsNoRange.Length } - // Put type ctors after types, sorted by #typars. RemoveDuplicateItems will remove DefaultStructCtors if a type is also reported with this name - | Item.CtorGroup (_, (cinfo :: _)) -> { x with MinorPriority = 1000 + 10 * (tcrefOfAppTy g cinfo.EnclosingType).TyparsNoRange.Length } - | Item.MethodGroup(_, minfo :: _, _) -> { x with IsOwnMember = tyconRefOptEq x.Type minfo.DeclaringEntityRef } - | Item.Property(_, pinfo :: _) -> { x with IsOwnMember = tyconRefOptEq x.Type (tcrefOfAppTy g pinfo.EnclosingType) } - | Item.ILField finfo -> { x with IsOwnMember = tyconRefOptEq x.Type (tcrefOfAppTy g finfo.EnclosingType) } - | _ -> x) - |> List.sortBy (fun x -> x.MinorPriority) - |> List.fold (fun (prevRealPrior, prevNormalizedPrior, acc) x -> - if x.MinorPriority = prevRealPrior then - prevRealPrior, prevNormalizedPrior, x :: acc - else - let normalizedPrior = prevNormalizedPrior + 1 - x.MinorPriority, normalizedPrior, { x with MinorPriority = normalizedPrior } :: acc - ) (0, 0, []) - - if verbose then dprintf "service.ml: mkDecls: %d found groups after filtering\n" (List.length items); - - // Group by full name for unresolved items and by display name for resolved ones. - let items = - items - |> List.rev - // Prefer items from file check results to ones from referenced assemblies via GetAssemblyContent ("all entities") - |> List.sortBy (fun x -> x.Unresolved.IsSome) - // Remove all duplicates. We've put the types first, so this removes the DelegateCtor and DefaultStructCtor's. - |> RemoveDuplicateCompletionItems g - |> List.groupBy (fun x -> - match x.Unresolved with - | Some u -> - match u.Namespace with - | [||] -> u.DisplayName - | ns -> (ns |> String.concat ".") + "." + u.DisplayName - | None -> x.Item.DisplayName) - |> List.map (fun (_, items) -> - let item = items.Head - let name = - match item.Unresolved with - | Some u -> u.DisplayName - | None -> item.Item.DisplayName - name, items) - - // Filter out operators (and list) - let items = - // Check whether this item looks like an operator. - let isOperatorItem(name, items: CompletionItem list) = - match items |> List.map (fun x -> x.Item) with - | [Item.Value _ | Item.MethodGroup _ | Item.UnionCase _] -> IsOperatorName name - | _ -> false - let isFSharpList name = (name = "[]") // list shows up as a Type and a UnionCase, only such entity with a symbolic name, but want to filter out of intellisense - items |> List.filter (fun (displayName, items) -> not (isOperatorItem(displayName, items)) && not (isFSharpList displayName)) - - let decls = - items - |> List.map (fun (displayName, itemsWithSameFullName) -> - match itemsWithSameFullName with - | [] -> failwith "Unexpected empty bag" - | _ -> - let items = - match itemsWithSameFullName |> List.partition (fun x -> x.Unresolved.IsNone) with - | [], unresolved -> unresolved - // if there are resolvable items, throw out unresolved to prevent duplicates like `Set` and `FSharp.Collections.Set`. - | resolved, _ -> resolved - - let item = items.Head - let glyph = ItemDescriptionsImpl.GlyphOfItem(denv, item.Item) - - let name, nameInCode = - if displayName.StartsWith "( " && displayName.EndsWith " )" then - let cleanName = displayName.[2..displayName.Length - 3] - cleanName, - if IsOperatorName displayName then cleanName else "``" + cleanName + "``" - else - displayName, - match item.Unresolved with - | Some _ -> displayName - | None -> Lexhelp.Keywords.QuoteIdentifierIfNeeded displayName - - let isAttribute = ItemDescriptionsImpl.IsAttribute infoReader item.Item - - let cutAttributeSuffix (name: string) = - if isAttributeApplicationContext && isAttribute && name <> "Attribute" && name.EndsWith "Attribute" then - name.[0..name.Length - "Attribute".Length - 1] - else name - - let name = cutAttributeSuffix name - let nameInCode = cutAttributeSuffix nameInCode - let fullName = ItemDescriptionsImpl.FullNameOfItem g item.Item - - let namespaceToOpen = - item.Unresolved - |> Option.map (fun x -> x.Namespace) - |> Option.bind (fun ns -> - if ns |> Array.startsWith [|"Microsoft"; "FSharp"|] then None - else Some ns) - |> Option.map (fun ns -> - match currentNamespaceOrModule with - | Some currentNs -> - if ns |> Array.startsWith currentNs then - ns.[currentNs.Length..] - else ns - | None -> ns) - |> Option.bind (function - | [||] -> None - | ns -> Some (ns |> String.concat ".")) - - FSharpDeclarationListItem( - name, nameInCode, fullName, glyph, Choice1Of2 (items, infoReader, m, denv, reactor, checkAlive), getAccessibility item.Item, - item.Kind, item.IsOwnMember, item.MinorPriority, item.Unresolved.IsNone, namespaceToOpen)) - - new FSharpDeclarationListInfo(Array.ofList decls, isForType, false) - - static member Error msg = - new FSharpDeclarationListInfo( - [| FSharpDeclarationListItem("", "", "", FSharpGlyph.Error, Choice2Of2 (FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError msg]), - None, CompletionItemKind.Other, false, 0, false, None) |], false, true) - - static member Empty = FSharpDeclarationListInfo([| |], false, false) - - - -/// A single method for Intellisense completion -[] -// Note: instances of this type do not hold any references to any compiler resources. -type FSharpMethodGroupItem(description: FSharpToolTipText, xmlDoc: FSharpXmlDoc, returnType: Layout, parameters: FSharpMethodGroupItemParameter[], hasParameters: bool, hasParamArrayArg: bool, staticParameters: FSharpMethodGroupItemParameter[]) = - member __.StructuredDescription = description - member __.Description = Tooltips.ToFSharpToolTipText description - member __.XmlDoc = xmlDoc - member __.StructuredReturnTypeText = returnType - member __.ReturnTypeText = showL returnType - member __.Parameters = parameters - member __.HasParameters = hasParameters - member __.HasParamArrayArg = hasParamArrayArg - // Does the type name or method support a static arguments list, like TP<42,"foo"> or conn.CreateCommand<42, "foo">(arg1, arg2)? - member __.StaticParameters = staticParameters - - -/// A table of methods for Intellisense completion -// -// Note: this type does not hold any strong references to any compiler resources, nor does evaluating any of the properties execute any -// code on the compiler thread. -[] -type FSharpMethodGroup( name: string, unsortedMethods: FSharpMethodGroupItem[] ) = - // BUG 413009 : [ParameterInfo] takes about 3 seconds to move from one overload parameter to another - // cache allows to avoid recomputing parameterinfo for the same item -#if !FX_NO_WEAKTABLE - static let methodOverloadsCache = System.Runtime.CompilerServices.ConditionalWeakTable() -#endif - - let methods = - unsortedMethods - // Methods with zero arguments show up here as taking a single argument of type 'unit'. Patch them now to appear as having zero arguments. - |> Array.map (fun meth -> - let parms = meth.Parameters - if parms.Length = 1 && parms.[0].CanonicalTypeTextForSorting="Microsoft.FSharp.Core.Unit" then - FSharpMethodGroupItem(meth.StructuredDescription, meth.XmlDoc, meth.StructuredReturnTypeText, [||], true, meth.HasParamArrayArg, meth.StaticParameters) - else - meth) - // Fix the order of methods, to be stable for unit testing. - |> Array.sortBy (fun meth -> - let parms = meth.Parameters - parms.Length, (parms |> Array.map (fun p -> p.CanonicalTypeTextForSorting))) - - member __.MethodName = name - - member __.Methods = methods - - static member Create (infoReader: InfoReader, m, denv, items:ItemWithInst list) = - let g = infoReader.g - if isNil items then new FSharpMethodGroup("", [| |]) else - let name = items.Head.Item.DisplayName - - let methods = - [| for item in items do -#if !FX_NO_WEAKTABLE - match methodOverloadsCache.TryGetValue item with - | true, res -> yield! res - | false, _ -> -#endif - let flatItems = AnotherFlattenItems g m item.Item - - let methods = - flatItems |> Array.ofList |> Array.map (fun flatItem -> - let prettyParams, prettyRetTyL = - ErrorScope.Protect m - (fun () -> PrettyParamsAndReturnTypeOfItem infoReader m denv { item with Item = flatItem }) - (fun err -> [], wordL (tagText err)) - - let description = FSharpToolTipText [FormatStructuredDescriptionOfItem true infoReader m denv { item with Item = flatItem }] - - let hasParamArrayArg = - match flatItem with - | Item.CtorGroup(_,[meth]) - | Item.MethodGroup(_,[meth],_) -> meth.HasParamArrayArg(infoReader.amap, m, meth.FormalMethodInst) - | _ -> false - - let hasStaticParameters = - match flatItem with - | ItemIsProvidedTypeWithStaticArguments m g _ -> false - | _ -> true - - FSharpMethodGroupItem( - description = description, - returnType = prettyRetTyL, - xmlDoc = GetXmlCommentForItem infoReader m flatItem, - parameters = (prettyParams |> Array.ofList), - hasParameters = hasStaticParameters, - hasParamArrayArg = hasParamArrayArg, - staticParameters = StaticParamsOfItem infoReader m denv flatItem - )) -#if !FX_NO_WEAKTABLE - methodOverloadsCache.Add(item, methods) -#endif - yield! methods - |] - - new FSharpMethodGroup(name, methods) - - - diff --git a/src/fsharp/symbols/SymbolHelpers.fsi b/src/fsharp/symbols/SymbolHelpers.fsi new file mode 100755 index 00000000000..fe74e76a072 --- /dev/null +++ b/src/fsharp/symbols/SymbolHelpers.fsi @@ -0,0 +1,254 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +//---------------------------------------------------------------------------- +// Helpers for quick info and information about items +//---------------------------------------------------------------------------- + +namespace Microsoft.FSharp.Compiler.SourceCodeServices + +open System +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.ErrorLogger + +//---------------------------------------------------------------------------- +// Object model for diagnostics + + +[] +#if COMPILER_PUBLIC_API +type FSharpErrorSeverity = +#else +type internal FSharpErrorSeverity = +#endif +| Warning + | Error + +[] +#if COMPILER_PUBLIC_API +type FSharpErrorInfo = +#else +type internal FSharpErrorInfo = +#endif + member FileName: string + member StartLineAlternate:int + member EndLineAlternate:int + member StartColumn:int + member EndColumn:int + member Severity:FSharpErrorSeverity + member Message:string + member Subcategory:string + member ErrorNumber:int + static member internal CreateFromExceptionAndAdjustEof : PhasedDiagnostic * isError: bool * trim: bool * range * lastPosInFile:(int*int) -> FSharpErrorInfo + static member internal CreateFromException : PhasedDiagnostic * isError: bool * trim: bool * range -> FSharpErrorInfo + +//---------------------------------------------------------------------------- +// Object model for quick info + +/// Describe a comment as either a block of text or a file+signature reference into an intellidoc file. +// +// Note: instances of this type do not hold any references to any compiler resources. +[] +#if COMPILER_PUBLIC_API +type FSharpXmlDoc = +#else +type internal FSharpXmlDoc = +#endif + /// No documentation is available + | None + + /// The text for documentation + | Text of string + + /// Indicates that the text for the documentation can be found in a .xml documentation file, using the given signature key + | XmlDocFileSignature of (*File:*) string * (*Signature:*)string + +#if COMPILER_PUBLIC_API +type Layout = Internal.Utilities.StructuredFormat.Layout +#else +type internal Layout = Internal.Utilities.StructuredFormat.Layout +#endif + +/// A single data tip display element +[] +#if COMPILER_PUBLIC_API +type FSharpToolTipElementData<'T> = +#else +type internal FSharpToolTipElementData<'T> = +#endif + { MainDescription: 'T + XmlDoc: FSharpXmlDoc + /// typar insantiation text, to go after xml + TypeMapping: 'T list + /// Extra text, goes at the end + Remarks: 'T option + /// Parameter name + ParamName : string option } + +/// A single tool tip display element +// +// Note: instances of this type do not hold any references to any compiler resources. +[] +#if COMPILER_PUBLIC_API +type FSharpToolTipElement<'T> = +#else +type internal FSharpToolTipElement<'T> = +#endif + | None + + /// A single type, method, etc with comment. May represent a method overload group. + | Group of FSharpToolTipElementData<'T> list + + /// An error occurred formatting this element + | CompositionError of string + static member Single : 'T * FSharpXmlDoc * ?typeMapping: 'T list * ?paramName: string * ?remarks : 'T -> FSharpToolTipElement<'T> + +/// A single data tip display element with where text is expressed as string +#if COMPILER_PUBLIC_API +type FSharpToolTipElement = FSharpToolTipElement +#else +type internal FSharpToolTipElement = FSharpToolTipElement +#endif + + +/// A single data tip display element with where text is expressed as +#if COMPILER_PUBLIC_API +type FSharpStructuredToolTipElement = FSharpToolTipElement +#else +type internal FSharpStructuredToolTipElement = FSharpToolTipElement +#endif + +/// Information for building a tool tip box. +// +// Note: instances of this type do not hold any references to any compiler resources. +#if COMPILER_PUBLIC_API +type FSharpToolTipText<'T> = +#else +type internal FSharpToolTipText<'T> = +#endif + /// A list of data tip elements to display. + | FSharpToolTipText of FSharpToolTipElement<'T> list + +#if COMPILER_PUBLIC_API +type FSharpToolTipText = FSharpToolTipText +type FSharpStructuredToolTipText = FSharpToolTipText +#else +type internal FSharpToolTipText = FSharpToolTipText +type internal FSharpStructuredToolTipText = FSharpToolTipText +#endif + +//---------------------------------------------------------------------------- +// Object model for completion list entries (one of several in the API...) + + +[] +#if COMPILER_PUBLIC_API +type CompletionItemKind = +#else +type internal CompletionItemKind = +#endif + | Field + | Property + | Method of isExtension : bool + | Event + | Argument + | Other + +type internal UnresolvedSymbol = + { DisplayName: string + Namespace: string[] } + +type internal CompletionItem = + { ItemWithInst: ItemWithInst + Kind: CompletionItemKind + IsOwnMember: bool + MinorPriority: int + Type: TyconRef option + Unresolved: UnresolvedSymbol option } + member Item : Item + +#if COMPILER_PUBLIC_API +module Tooltips = +#else +module internal Tooltips = +#endif + val ToFSharpToolTipElement: FSharpStructuredToolTipElement -> FSharpToolTipElement + val ToFSharpToolTipText: FSharpStructuredToolTipText -> FSharpToolTipText + val Map: f: ('T1 -> 'T2) -> a: Async<'T1> -> Async<'T2> + +// Implementation details used by other code in the compiler +module internal SymbolHelpers = + val isFunction : TcGlobals -> TType -> bool + val ParamNameAndTypesOfUnaryCustomOperation : TcGlobals -> MethInfo -> ParamNameAndType list + + val GetXmlDocSigOfEntityRef : InfoReader -> range -> EntityRef -> (string option * string) option + val GetXmlDocSigOfScopedValRef : TcGlobals -> TyconRef -> ValRef -> (string option * string) option + val GetXmlDocSigOfILFieldInfo : InfoReader -> range -> ILFieldInfo -> (string option * string) option + val GetXmlDocSigOfRecdFieldInfo : RecdFieldInfo -> (string option * string) option + val GetXmlDocSigOfUnionCaseInfo : UnionCaseInfo -> (string option * string) option + val GetXmlDocSigOfMethInfo : InfoReader -> range -> MethInfo -> (string option * string) option + val GetXmlDocSigOfValRef : TcGlobals -> ValRef -> (string option * string) option + val GetXmlDocSigOfProp : InfoReader -> range -> PropInfo -> (string option * string) option + val GetXmlDocSigOfEvent : InfoReader -> range -> EventInfo -> (string option * string) option + val GetXmlCommentForItem : InfoReader -> range -> Item -> FSharpXmlDoc + val FormatStructuredDescriptionOfItem : isDecl:bool -> InfoReader -> range -> DisplayEnv -> ItemWithInst -> FSharpStructuredToolTipElement + val RemoveDuplicateItems : TcGlobals -> ItemWithInst list -> ItemWithInst list + val RemoveExplicitlySuppressed : TcGlobals -> ItemWithInst list -> ItemWithInst list + val RemoveDuplicateCompletionItems : TcGlobals -> CompletionItem list -> CompletionItem list + val RemoveExplicitlySuppressedCompletionItems : TcGlobals -> CompletionItem list -> CompletionItem list + val GetF1Keyword : TcGlobals -> Item -> string option + val rangeOfItem : TcGlobals -> bool option -> Item -> range option + val fileNameOfItem : TcGlobals -> string option -> range -> Item -> string + val FullNameOfItem : TcGlobals -> Item -> string + val ccuOfItem : TcGlobals -> Item -> CcuThunk option + val mutable ToolTipFault : string option + val IsAttribute : InfoReader -> Item -> bool + val IsExplicitlySuppressed : TcGlobals -> Item -> bool + val FlattenItems : TcGlobals -> range -> Item -> Item list +#if EXTENSIONTYPING + val (|ItemIsProvidedType|_|) : TcGlobals -> Item -> TyconRef option + val (|ItemIsWithStaticArguments|_|): range -> TcGlobals -> Item -> Tainted[] option + val (|ItemIsProvidedTypeWithStaticArguments|_|): range -> TcGlobals -> Item -> Tainted[] option +#endif + val SimplerDisplayEnv : DisplayEnv -> DisplayEnv + +//---------------------------------------------------------------------------- +// Internal only + +// Implementation details used by other code in the compiler +[] +type internal ErrorScope = + interface IDisposable + new : unit -> ErrorScope + member Diagnostics : FSharpErrorInfo list + static member Protect<'a> : range -> (unit->'a) -> (string->'a) -> 'a + static member ProtectWithDefault<'a> : range -> (unit -> 'a) -> 'a -> 'a + static member ProtectAndDiscard : range -> (unit -> unit) -> unit + +/// An error logger that capture errors, filtering them according to warning levels etc. +type internal CompilationErrorLogger = + inherit ErrorLogger + + /// Create the error logger + new : debugName:string * tcConfig:TcConfig -> CompilationErrorLogger + + /// Get the captured errors + member GetErrors : unit -> (PhasedDiagnostic * FSharpErrorSeverity) list + +/// This represents the global state established as each task function runs as part of the build. +/// +/// Use to reset error and warning handlers. +type internal CompilationGlobalsScope = + new : ErrorLogger * BuildPhase -> CompilationGlobalsScope + interface IDisposable + +module internal ErrorHelpers = + val ReportError: TcConfig * allErrors: bool * mainInputFileName: string * fileInfo: (int * int) * (PhasedDiagnostic * FSharpErrorSeverity) -> FSharpErrorInfo list + val CreateErrorInfos: TcConfig * allErrors: bool * mainInputFileName: string * seq<(PhasedDiagnostic * FSharpErrorSeverity)> -> FSharpErrorInfo[] diff --git a/src/fsharp/vs/Symbols.fs b/src/fsharp/symbols/Symbols.fs similarity index 93% rename from src/fsharp/vs/Symbols.fs rename to src/fsharp/symbols/Symbols.fs index b533c3e0c34..484ba7185c8 100644 --- a/src/fsharp/vs/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -21,6 +21,35 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.PrettyNaming open Internal.Utilities +type FSharpAccessibility(a:Accessibility, ?isProtected) = + let isProtected = defaultArg isProtected false + + let isInternalCompPath x = + match x with + | CompPath(ILScopeRef.Local,[]) -> true + | _ -> false + + let (|Public|Internal|Private|) (TAccess p) = + match p with + | [] -> Public + | _ when List.forall isInternalCompPath p -> Internal + | _ -> Private + + member __.IsPublic = not isProtected && match a with Public -> true | _ -> false + + member __.IsPrivate = not isProtected && match a with Private -> true | _ -> false + + member __.IsInternal = not isProtected && match a with Internal -> true | _ -> false + + member __.IsProtected = isProtected + + member internal __.Contents = a + + override __.ToString() = + let (TAccess paths) = a + let mangledTextOfCompPath (CompPath(scoref,path)) = getNameOfScopeRef scoref + "/" + textOfPath (List.map fst path) + String.concat ";" (List.map mangledTextOfCompPath paths) + [] module Impl = let protect f = @@ -99,9 +128,11 @@ module Impl = /// Convert an IL type definition accessibility into an F# accessibility let getApproxFSharpAccessibilityOfEntity (entity: EntityRef) = match metadataOfTycon entity.Deref with +#if EXTENSIONTYPING | ProvidedTypeMetadata _info -> // This is an approximation - for generative type providers some type definitions can be private. taccessPublic +#endif | ILTypeMetadata (TILObjectReprData(_,_,td)) -> match td.Access with @@ -147,7 +178,7 @@ module Impl = member __.tcImports = tcImports let getXmlDocSigForEntity (cenv: cenv) (ent:EntityRef)= - match ItemDescriptionsImpl.GetXmlDocSigOfEntityRef cenv.infoReader ent.Range ent with + match SymbolHelpers.GetXmlDocSigOfEntityRef cenv.infoReader ent.Range ent with | Some (_, docsig) -> docsig | _ -> "" @@ -160,20 +191,20 @@ type FSharpDisplayContext(denv: TcGlobals -> DisplayEnv) = type FSharpSymbol(cenv:cenv, item: (unit -> Item), access: (FSharpSymbol -> CcuThunk -> AccessorDomain -> bool)) = member x.Assembly = - let ccu = defaultArg (ItemDescriptionsImpl.ccuOfItem cenv.g x.Item) cenv.thisCcu + let ccu = defaultArg (SymbolHelpers.ccuOfItem cenv.g x.Item) cenv.thisCcu FSharpAssembly(cenv, ccu) member x.IsAccessible(rights: FSharpAccessibilityRights) = access x rights.ThisCcu rights.Contents - member x.IsExplicitlySuppressed = ItemDescriptionsImpl.IsExplicitlySuppressed cenv.g x.Item + member x.IsExplicitlySuppressed = SymbolHelpers.IsExplicitlySuppressed cenv.g x.Item - member x.FullName = ItemDescriptionsImpl.FullNameOfItem cenv.g x.Item + member x.FullName = SymbolHelpers.FullNameOfItem cenv.g x.Item - member x.DeclarationLocation = ItemDescriptionsImpl.rangeOfItem cenv.g None x.Item + member x.DeclarationLocation = SymbolHelpers.rangeOfItem cenv.g None x.Item - member x.ImplementationLocation = ItemDescriptionsImpl.rangeOfItem cenv.g (Some(false)) x.Item + member x.ImplementationLocation = SymbolHelpers.rangeOfItem cenv.g (Some(false)) x.Item - member x.SignatureLocation = ItemDescriptionsImpl.rangeOfItem cenv.g (Some(true)) x.Item + member x.SignatureLocation = SymbolHelpers.rangeOfItem cenv.g (Some(true)) x.Item member x.IsEffectivelySameAs(y:FSharpSymbol) = x.Equals(y) || ItemsAreEffectivelyEqual cenv.g x.Item y.Item @@ -257,7 +288,11 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member x.QualifiedName = checkIsResolved() let fail() = invalidOp (sprintf "the type '%s' does not have a qualified name" x.LogicalName) +#if EXTENSIONTYPING if entity.IsTypeAbbrev || entity.IsProvidedErasedTycon || entity.IsNamespace then fail() + #else + if entity.IsTypeAbbrev || entity.IsNamespace then fail() +#endif match entity.CompiledRepresentation with | CompiledTypeRepr.ILAsmNamed(tref,_,_) -> tref.QualifiedName | CompiledTypeRepr.ILAsmOpen _ -> fail() @@ -270,7 +305,11 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member x.TryFullName = if isUnresolved() then None +#if EXTENSIONTYPING elif entity.IsTypeAbbrev || entity.IsProvidedErasedTycon then None + #else + elif entity.IsTypeAbbrev then None +#endif elif entity.IsNamespace then Some entity.DemangledModuleOrNamespaceName else match entity.CompiledRepresentation with @@ -304,6 +343,10 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = isResolved() && isArrayTyconRef cenv.g entity + member __.ArrayRank = + checkIsResolved() + rankOfArrayTyconRef cenv.g entity +#if EXTENSIONTYPING member __.IsProvided = isResolved() && entity.IsProvided @@ -319,11 +362,13 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member __.IsProvidedAndGenerated = isResolved() && entity.IsProvidedGeneratedTycon - +#endif member __.IsClass = isResolved() && - match metadataOfTycon entity.Deref with + match metadataOfTycon entity.Deref with +#if EXTENSIONTYPING | ProvidedTypeMetadata info -> info.IsClass +#endif | ILTypeMetadata (TILObjectReprData(_,_,td)) -> (td.tdKind = ILTypeDefKind.Class) | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> entity.Deref.IsFSharpClassTycon @@ -342,7 +387,9 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member __.IsDelegate = isResolved() && match metadataOfTycon entity.Deref with +#if EXTENSIONTYPING | ProvidedTypeMetadata info -> info.IsDelegate () +#endif | ILTypeMetadata (TILObjectReprData(_,_,td)) -> (td.tdKind = ILTypeDefKind.Delegate) | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> entity.IsFSharpDelegateTycon @@ -480,12 +527,14 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member x.StaticParameters = match entity.TypeReprInfo with +#if EXTENSIONTYPING | TProvidedTypeExtensionPoint info -> let m = x.DeclarationLocation let typeBeforeArguments = info.ProvidedType let staticParameters = typeBeforeArguments.PApplyWithProvider((fun (typeBeforeArguments,provider) -> typeBeforeArguments.GetStaticParameters(provider)), range=m) let staticParameters = staticParameters.PApplyArray(id, "GetStaticParameters", m) [| for p in staticParameters -> FSharpStaticParameter(cenv, p, m) |] +#endif | _ -> [| |] |> makeReadOnlyCollection @@ -505,10 +554,22 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member x.RecordFields = x.FSharpFields member x.FSharpFields = if isUnresolved() then makeReadOnlyCollection[] else + + if entity.IsILEnumTycon then + let (TILObjectReprData(_scoref,_enc,tdef)) = entity.ILTyconInfo + let formalTypars = entity.Typars(range.Zero) + let formalTypeInst = generalizeTypars formalTypars + let ty = TType_app(entity,formalTypeInst) + let formalTypeInfo = ILTypeInfo.FromType cenv.g ty + tdef.Fields.AsList + |> List.map (fun tdef -> let ilFieldInfo = ILFieldInfo(formalTypeInfo, tdef) + FSharpField(cenv, FSharpFieldData.ILField(cenv.g, ilFieldInfo) )) + |> makeReadOnlyCollection - entity.AllFieldsAsList - |> List.map (fun x -> FSharpField(cenv, mkRecdFieldRef entity x.Name)) - |> makeReadOnlyCollection + else + entity.AllFieldsAsList + |> List.map (fun x -> FSharpField(cenv, mkRecdFieldRef entity x.Name)) + |> makeReadOnlyCollection member x.AbbreviatedType = checkIsResolved() @@ -611,7 +672,7 @@ and FSharpUnionCase(cenv, v: UnionCaseRef) = member __.XmlDocSig = checkIsResolved() let unionCase = UnionCaseInfo(generalizeTypars v.TyconRef.TyparsNoRange,v) - match ItemDescriptionsImpl.GetXmlDocSigOfUnionCaseInfo unionCase with + match SymbolHelpers.GetXmlDocSigOfUnionCaseInfo unionCase with | Some (_, docsig) -> docsig | _ -> "" @@ -654,7 +715,7 @@ and FSharpFieldData = | Union (v,_) -> v.TyconRef | ILField (g,f) -> tcrefOfAppTy g f.EnclosingType -and FSharpField(cenv, d: FSharpFieldData) = +and FSharpField(cenv: cenv, d: FSharpFieldData) = inherit FSharpSymbol (cenv, (fun () -> match d with @@ -737,12 +798,12 @@ and FSharpField(cenv, d: FSharpFieldData) = match d with | RecdOrClass v -> let recd = RecdFieldInfo(generalizeTypars v.TyconRef.TyparsNoRange,v) - ItemDescriptionsImpl.GetXmlDocSigOfRecdFieldInfo recd + SymbolHelpers.GetXmlDocSigOfRecdFieldInfo recd | Union (v,_) -> let unionCase = UnionCaseInfo(generalizeTypars v.TyconRef.TyparsNoRange,v) - ItemDescriptionsImpl.GetXmlDocSigOfUnionCaseInfo unionCase + SymbolHelpers.GetXmlDocSigOfUnionCaseInfo unionCase | ILField (_,f) -> - ItemDescriptionsImpl.GetXmlDocSigOfILFieldInfo cenv.infoReader range0 f + SymbolHelpers.GetXmlDocSigOfILFieldInfo cenv.infoReader range0 f match xmlsig with | Some (_, docsig) -> docsig | _ -> "" @@ -822,6 +883,8 @@ and FSharpField(cenv, d: FSharpFieldData) = override x.GetHashCode() = hash x.Name override x.ToString() = "field " + x.Name +and [] FSharpRecordField = FSharpField + and [] FSharpAccessibilityRights(thisCcu: CcuThunk, ad:AccessorDomain) = member internal __.ThisCcu = thisCcu member internal __.Contents = ad @@ -846,7 +909,7 @@ and FSharpActivePatternCase(cenv, apinfo: PrettyNaming.ActivePatternInfo, typ, n member __.XmlDocSig = let xmlsig = match valOpt with - | Some valref -> ItemDescriptionsImpl.GetXmlDocSigOfValRef cenv.g valref + | Some valref -> SymbolHelpers.GetXmlDocSigOfValRef cenv.g valref | None -> None match xmlsig with | Some (_, docsig) -> docsig @@ -1511,23 +1574,23 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = match d with | E e -> let range = defaultArg __.DeclarationLocationOpt range0 - match ItemDescriptionsImpl.GetXmlDocSigOfEvent cenv.infoReader range e with + match SymbolHelpers.GetXmlDocSigOfEvent cenv.infoReader range e with | Some (_, docsig) -> docsig | _ -> "" | P p -> let range = defaultArg __.DeclarationLocationOpt range0 - match ItemDescriptionsImpl.GetXmlDocSigOfProp cenv.infoReader range p with + match SymbolHelpers.GetXmlDocSigOfProp cenv.infoReader range p with | Some (_, docsig) -> docsig | _ -> "" | M m | C m -> let range = defaultArg __.DeclarationLocationOpt range0 - match ItemDescriptionsImpl.GetXmlDocSigOfMethInfo cenv.infoReader range m with + match SymbolHelpers.GetXmlDocSigOfMethInfo cenv.infoReader range m with | Some (_, docsig) -> docsig | _ -> "" | V v -> match v.ActualParent with | Parent entityRef -> - match ItemDescriptionsImpl.GetXmlDocSigOfScopedValRef cenv.g entityRef v with + match SymbolHelpers.GetXmlDocSigOfScopedValRef cenv.g entityRef v with | Some (_, docsig) -> docsig | _ -> "" | ParentNone -> "" @@ -1725,6 +1788,11 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = member x.Data = d + member x.IsValCompiledAsMethod = + match d with + | V valRef -> IlxGen.IsValCompiledAsMethod cenv.g valRef.Deref + | _ -> false + override x.Equals(other : obj) = box x === other || match other with @@ -1866,13 +1934,26 @@ and FSharpType(cenv, typ:TType) = member private typ.AdjustType(t) = FSharpType(typ.cenv, t) + // Note: This equivalence relation is modulo type abbreviations override x.Equals(other : obj) = box x === other || match other with | :? FSharpType as t -> typeEquiv cenv.g typ t.V | _ -> false - override x.GetHashCode() = hash x + // Note: This equivalence relation is modulo type abbreviations. The hash is less than perfect. + override x.GetHashCode() = + let rec hashType typ = + let typ = stripTyEqnsWrtErasure EraseNone cenv.g typ + match typ with + | TType_forall _ -> 10000 + | TType_var tp -> 10100 + int32 tp.Stamp + | TType_app (tc1,b1) -> 10200 + int32 tc1.Stamp + List.sumBy hashType b1 + | TType_ucase _ -> 10300 // shouldn't occur in symbols + | TType_tuple (_,l1) -> 10400 + List.sumBy hashType l1 + | TType_fun (dty,rty) -> 10500 + hashType dty + hashType rty + | TType_measure _ -> 10600 + hashType typ member x.Format(denv: FSharpDisplayContext) = protect <| fun () -> @@ -1962,7 +2043,7 @@ and FSharpAttribute(cenv: cenv, attrib: AttribInfo) = override __.ToString() = if entityIsUnresolved attrib.TyconRef then "attribute ???" else "attribute " + attrib.TyconRef.CompiledName + "(...)" - +#if EXTENSIONTYPING and FSharpStaticParameter(cenv, sp: Tainted< ExtensionTyping.ProvidedParameterInfo >, m) = inherit FSharpSymbol(cenv, (fun () -> @@ -2001,7 +2082,7 @@ and FSharpStaticParameter(cenv, sp: Tainted< ExtensionTyping.ProvidedParameterI override x.GetHashCode() = hash x.Name override x.ToString() = "static parameter " + x.Name - +#endif and FSharpParameter(cenv, typ:TType, topArgInfo:ArgReprInfo, mOpt, isParamArrayArg, isOutArg, isOptionalArg) = inherit FSharpSymbol(cenv, (fun () -> @@ -2073,7 +2154,9 @@ and FSharpAssembly internal (cenv, ccu: CcuThunk) = member __.CodeLocation = ccu.SourceCodeDirectory member __.FileName = ccu.FileName member __.SimpleName = ccu.AssemblyName + #if EXTENSIONTYPING member __.IsProviderGenerated = ccu.IsProviderGenerated + #endif member __.Contents = FSharpAssemblySignature(cenv, ccu) override x.ToString() = x.QualifiedName @@ -2158,4 +2241,27 @@ type FSharpSymbol with | :? FSharpField as x -> Some x.Accessibility | :? FSharpUnionCase as x -> Some x.Accessibility | :? FSharpMemberFunctionOrValue as x -> Some x.Accessibility - | _ -> None \ No newline at end of file + | _ -> None + +[] +type FSharpSymbolUse(g:TcGlobals, denv: DisplayEnv, symbol:FSharpSymbol, itemOcc, range: range) = + member __.Symbol = symbol + member __.DisplayContext = FSharpDisplayContext(fun _ -> denv) + member x.IsDefinition = x.IsFromDefinition + member __.IsFromDefinition = (match itemOcc with ItemOccurence.Binding -> true | _ -> false) + member __.IsFromPattern = (match itemOcc with ItemOccurence.Pattern -> true | _ -> false) + member __.IsFromType = (match itemOcc with ItemOccurence.UseInType -> true | _ -> false) + member __.IsFromAttribute = (match itemOcc with ItemOccurence.UseInAttribute -> true | _ -> false) + member __.IsFromDispatchSlotImplementation = (match itemOcc with ItemOccurence.Implemented -> true | _ -> false) + member __.IsFromComputationExpression = + match symbol.Item, itemOcc with + // 'seq' in 'seq { ... }' gets colored as keywords + | (Item.Value vref), ItemOccurence.Use when valRefEq g g.seq_vref vref -> true + // custom builders, custom operations get colored as keywords + | (Item.CustomBuilder _ | Item.CustomOperation _), ItemOccurence.Use -> true + | _ -> false + + member __.FileName = range.FileName + member __.Range = Range.toZ range + member __.RangeAlternate = range + diff --git a/src/fsharp/vs/Symbols.fsi b/src/fsharp/symbols/Symbols.fsi similarity index 86% rename from src/fsharp/vs/Symbols.fsi rename to src/fsharp/symbols/Symbols.fsi index 10be0a23f90..92307bbf7d1 100644 --- a/src/fsharp/vs/Symbols.fsi +++ b/src/fsharp/symbols/Symbols.fsi @@ -18,19 +18,46 @@ open Microsoft.FSharp.Compiler.CompileOps open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.NameResolution +// Implementation details used by other code in the compiler module internal Impl = type internal cenv = new : TcGlobals * thisCcu:CcuThunk * tcImports: TcImports -> cenv member amap: Import.ImportMap member g: TcGlobals +/// Indicates the accessibility of a symbol, as seen by the F# language +#if COMPILER_PUBLIC_API +type FSharpAccessibility = +#else +type internal FSharpAccessibility = +#endif + internal new: Accessibility * ?isProtected: bool -> FSharpAccessibility + + /// Indicates the symbol has public accessibility + member IsPublic : bool + + /// Indicates the symbol has private accessibility + member IsPrivate : bool + + /// Indicates the symbol has internal accessibility + member IsInternal : bool + + /// The underlying Accessibility + member internal Contents : Accessibility + + /// Represents the information needed to format types and other information in a style /// suitable for use in F# source text at a particular source location. /// /// Acquired via GetDisplayEnvAtLocationAlternate and similar methods. May be passed /// to the Format method on FSharpType and other methods. +#if COMPILER_PUBLIC_API +type [] FSharpDisplayContext = +#else type [] internal FSharpDisplayContext = +#endif internal new : denv: (TcGlobals -> Tastops.DisplayEnv) -> FSharpDisplayContext static member Empty: FSharpDisplayContext @@ -39,7 +66,11 @@ type [] internal FSharpDisplayContext = /// The subtype of the symbol may reveal further information and can be one of FSharpEntity, FSharpUnionCase /// FSharpField, FSharpGenericParameter, FSharpStaticParameter, FSharpMemberOrFunctionOrValue, FSharpParameter, /// or FSharpActivePatternCase. +#if COMPILER_PUBLIC_API +type [] FSharpSymbol = +#else type [] internal FSharpSymbol = +#endif /// Internal use only. static member internal Create : g:TcGlobals * thisCcu: CcuThunk * tcImports: TcImports * item:NameResolution.Item -> FSharpSymbol @@ -79,13 +110,20 @@ type [] internal FSharpSymbol = static member GetAccessibility : FSharpSymbol -> FSharpAccessibility option /// Represents an assembly as seen by the F# language +#if COMPILER_PUBLIC_API +and [] FSharpAssembly = +#else and [] internal FSharpAssembly = +#endif internal new : tcGlobals: TcGlobals * tcImports: TcImports * ccu: CcuThunk -> FSharpAssembly /// The qualified name of the assembly member QualifiedName: string + [] + member CodeLocation: string + /// The contents of the this assembly member Contents: FSharpAssemblySignature @@ -94,13 +132,17 @@ and [] internal FSharpAssembly = /// The simple name for the assembly member SimpleName : string - +#if EXTENSIONTYPING /// Indicates if the assembly was generated by a type provider and is due for static linking member IsProviderGenerated : bool - +#endif /// Represents an inferred signature of part of an assembly as seen by the F# language +#if COMPILER_PUBLIC_API +and [] FSharpAssemblySignature = +#else and [] internal FSharpAssemblySignature = +#endif internal new : tcGlobals: TcGlobals * thisCcu: CcuThunk * tcImports: TcImports * topAttribs: TypeChecker.TopAttribs option * contents: ModuleOrNamespaceType -> FSharpAssemblySignature @@ -113,7 +155,11 @@ and [] internal FSharpAssemblySignature = /// A subtype of FSharpSymbol that represents a type definition or module as seen by the F# language +#if COMPILER_PUBLIC_API +and [] FSharpEntity = +#else and [] internal FSharpEntity = +#endif inherit FSharpSymbol internal new : Impl.cenv * EntityRef -> FSharpEntity @@ -165,6 +211,9 @@ and [] internal FSharpEntity = /// Indicates if the entity is an array type member IsArrayType : bool + /// Get the rank of an array type + member ArrayRank : int +#if EXTENSIONTYPING /// Indicates if the entity is a 'fake' symbol related to a static instantiation of a type provider member IsStaticInstantiation : bool @@ -176,16 +225,16 @@ and [] internal FSharpEntity = /// Indicates if the entity is a generated provided type member IsProvidedAndGenerated : bool - +#endif /// Indicates if the entity is an F# module definition member IsFSharpModule: bool /// Get the generic parameters, possibly including unit-of-measure parameters member GenericParameters: IList - +#if EXTENSIONTYPING /// Get the static parameters for a provided type member StaticParameters: IList - +#endif /// Indicates that a module is compiled to a class with the given mangled name. The mangling is reversed during lookup member HasFSharpModuleSuffix : bool @@ -253,6 +302,9 @@ and [] internal FSharpEntity = /// Get the properties, events and methods of a type definitions, or the functions and values of a module member MembersFunctionsAndValues : IList + [] + member MembersOrValues : IList + /// Get the modules and types defined in a module, or the nested types of a type member NestedEntities : IList @@ -261,6 +313,9 @@ and [] internal FSharpEntity = /// For classes, the list may include compiler generated fields implied by the use of primary constructors. member FSharpFields : IList + [] + member RecordFields : IList + /// Get the type abbreviated by an F# type abbreviation member AbbreviatedType : FSharpType @@ -281,7 +336,11 @@ and [] internal FSharpEntity = member AllCompilationPaths : string list /// Represents a delegate signature in an F# symbol +#if COMPILER_PUBLIC_API +and [] FSharpDelegateSignature = +#else and [] internal FSharpDelegateSignature = +#endif /// Get the argument types of the delegate signature member DelegateArguments : IList @@ -289,7 +348,11 @@ and [] internal FSharpDelegateSignature = member DelegateReturnType : FSharpType /// Represents a parameter in an abstract method of a class or interface +#if COMPILER_PUBLIC_API +and [] FSharpAbstractParameter = +#else and [] internal FSharpAbstractParameter = +#endif /// The optional name of the parameter member Name : string option @@ -310,7 +373,11 @@ and [] internal FSharpAbstractParameter = member Attributes : IList /// Represents the signature of an abstract slot of a class or interface +#if COMPILER_PUBLIC_API +and [] FSharpAbstractSignature = +#else and [] internal FSharpAbstractSignature = +#endif internal new : Impl.cenv * SlotSig -> FSharpAbstractSignature /// Get the arguments of the abstract slot @@ -332,7 +399,11 @@ and [] internal FSharpAbstractSignature = member DeclaringType : FSharpType /// A subtype of FSharpSymbol that represents a union case as seen by the F# language +#if COMPILER_PUBLIC_API +and [] FSharpUnionCase = +#else and [] internal FSharpUnionCase = +#endif inherit FSharpSymbol internal new : Impl.cenv * UnionCaseRef -> FSharpUnionCase @@ -367,8 +438,13 @@ and [] internal FSharpUnionCase = member IsUnresolved : bool + /// A subtype of FSharpSymbol that represents a record or union case field as seen by the F# language +#if COMPILER_PUBLIC_API +and [] FSharpField = +#else and [] internal FSharpField = +#endif inherit FSharpSymbol internal new : Impl.cenv * RecdFieldRef -> FSharpField @@ -426,12 +502,20 @@ and [] internal FSharpField = member IsUnresolved : bool /// Represents the rights of a compilation to access symbols +#if COMPILER_PUBLIC_API +and [] FSharpAccessibilityRights = +#else and [] internal FSharpAccessibilityRights = +#endif internal new : CcuThunk * AccessorDomain -> FSharpAccessibilityRights member internal Contents : AccessorDomain /// A subtype of FSharpSymbol that represents a generic parameter for an FSharpSymbol +#if COMPILER_PUBLIC_API +and [] FSharpGenericParameter = +#else and [] internal FSharpGenericParameter = +#endif inherit FSharpSymbol internal new : Impl.cenv * Typar -> FSharpGenericParameter @@ -460,8 +544,14 @@ and [] internal FSharpGenericParameter = /// Get the declared or inferred constraints for the type parameter member Constraints: IList + +#if EXTENSIONTYPING /// A subtype of FSharpSymbol that represents a static parameter to an F# type provider +#if COMPILER_PUBLIC_API +and [] FSharpStaticParameter = +#else and [] internal FSharpStaticParameter = +#endif inherit FSharpSymbol @@ -480,10 +570,16 @@ and [] internal FSharpStaticParameter = /// Indicates if the static parameter is optional member IsOptional : bool + [] + member HasDefaultValue : bool +#endif /// Represents further information about a member constraint on a generic type parameter -and [] - FSharpGenericParameterMemberConstraint = +#if COMPILER_PUBLIC_API +and [] FSharpGenericParameterMemberConstraint = +#else +and [] internal FSharpGenericParameterMemberConstraint = +#endif /// Get the types that may be used to satisfy the constraint member MemberSources : IList @@ -501,7 +597,11 @@ and [] member MemberReturnType : FSharpType /// Represents further information about a delegate constraint on a generic type parameter +#if COMPILER_PUBLIC_API +and [] FSharpGenericParameterDelegateConstraint = +#else and [] internal FSharpGenericParameterDelegateConstraint = +#endif /// Get the tupled argument type required by the constraint member DelegateTupledArgumentType : FSharpType @@ -510,7 +610,11 @@ and [] internal FSharpGenericParameterDelegateC member DelegateReturnType : FSharpType /// Represents further information about a 'defaults to' constraint on a generic type parameter +#if COMPILER_PUBLIC_API +and [] FSharpGenericParameterDefaultsToConstraint = +#else and [] internal FSharpGenericParameterDefaultsToConstraint = +#endif /// Get the priority off the 'defaults to' constraint member DefaultsToPriority : int @@ -519,7 +623,11 @@ and [] internal FSharpGenericParameterDefaultsT member DefaultsToTarget : FSharpType /// Represents a constraint on a generic type parameter +#if COMPILER_PUBLIC_API +and [] FSharpGenericParameterConstraint = +#else and [] internal FSharpGenericParameterConstraint = +#endif /// Indicates a constraint that a type is a subtype of the given type member IsCoercesToConstraint : bool @@ -578,7 +686,11 @@ and [] internal FSharpGenericParameterConstrain member DelegateConstraintData : FSharpGenericParameterDelegateConstraint +#if COMPILER_PUBLIC_API +and [] FSharpInlineAnnotation = +#else and [] internal FSharpInlineAnnotation = +#endif /// Indictes the value is inlined and compiled code for the function does not exist | PseudoValue /// Indictes the value is inlined but compiled code for the function still exists, e.g. to satisfy interfaces on objects, but that it is also always inlined @@ -589,7 +701,11 @@ and [] internal FSharpInlineAnnotation = | NeverInline /// A subtype of F# symbol that represents an F# method, property, event, function or value, including extension members. +#if COMPILER_PUBLIC_API +and [] FSharpMemberOrFunctionOrValue = +#else and [] internal FSharpMemberOrFunctionOrValue = +#endif inherit FSharpSymbol internal new : Impl.cenv * ValRef -> FSharpMemberOrFunctionOrValue @@ -625,6 +741,9 @@ and [] internal FSharpMemberOrFunctionOrValue = /// Indicates if this is an extension member? member IsExtensionMember : bool + [] + member IsOverrideOrExplicitMember : bool + /// Indicates if this is an 'override', 'default' or an explicit implementation of an interface member member IsOverrideOrExplicitInterfaceImplementation : bool @@ -679,6 +798,14 @@ and [] internal FSharpMemberOrFunctionOrValue = /// Indicates if this is an abstract member? member IsDispatchSlot : bool + /// Indicates if this is a getter method for a property, or a use of a property in getter mode + [] + member IsGetterMethod: bool + + /// Indicates if this is a setter method for a property, or a use of a property in setter mode + [] + member IsSetterMethod: bool + /// Indicates if this is a getter method for a property, or a use of a property in getter mode member IsPropertyGetterMethod: bool @@ -754,12 +881,19 @@ and [] internal FSharpMemberOrFunctionOrValue = /// Get the accessibility information for the member, function or value member Accessibility : FSharpAccessibility + /// Indicated if this is a value compiled to a method + member IsValCompiledAsMethod : bool + /// Indicates if this is a constructor. member IsConstructor : bool /// A subtype of FSharpSymbol that represents a parameter +#if COMPILER_PUBLIC_API +and [] FSharpParameter = +#else and [] internal FSharpParameter = +#endif inherit FSharpSymbol /// The optional name of the parameter @@ -785,7 +919,12 @@ and [] internal FSharpParameter = /// A subtype of FSharpSymbol that represents a single case within an active pattern +#if COMPILER_PUBLIC_API +and [] FSharpActivePatternCase = +#else and [] internal FSharpActivePatternCase = +#endif + inherit FSharpSymbol /// The name of the active pattern case @@ -804,7 +943,11 @@ and [] internal FSharpActivePatternCase = member XmlDocSig: string /// Represents all cases within an active pattern +#if COMPILER_PUBLIC_API +and [] FSharpActivePatternGroup = +#else and [] internal FSharpActivePatternGroup = +#endif /// The names of the active pattern cases member Names: IList @@ -817,7 +960,11 @@ and [] internal FSharpActivePatternGroup = /// Try to get the enclosing entity of the active pattern member EnclosingEntity : FSharpEntity option +#if COMPILER_PUBLIC_API +and [] FSharpType = +#else and [] internal FSharpType = +#endif /// Internal use only. Create a ground type. internal new : g:TcGlobals * thisCcu: CcuThunk * tcImports: TcImports * typ:TType -> FSharpType internal new : Impl.cenv * typ:TType -> FSharpType @@ -893,10 +1040,20 @@ and [] internal FSharpType = /// systematically with lower-case type inference variables such as 'a. static member Prettify : parameters: IList> * returnParameter: FSharpParameter -> IList> * FSharpParameter + [] + member IsNamedType : bool + + [] + member NamedEntity : FSharpEntity + /// Represents a custom attribute attached to F# source code or a compiler .NET component +#if COMPILER_PUBLIC_API +and [] FSharpAttribute = +#else and [] internal FSharpAttribute = - +#endif + /// The type of the attribute member AttributeType : FSharpEntity @@ -914,3 +1071,44 @@ and [] internal FSharpAttribute = +/// Represents the use of an F# symbol from F# source code +[] +#if COMPILER_PUBLIC_API +type FSharpSymbolUse = +#else +type internal FSharpSymbolUse = +#endif + // For internal use only + internal new : g:TcGlobals * denv: Tastops.DisplayEnv * symbol:FSharpSymbol * itemOcc:ItemOccurence * range: range -> FSharpSymbolUse + + /// The symbol referenced + member Symbol : FSharpSymbol + + /// The display context active at the point where the symbol is used. Can be passed to FSharpType.Format + /// and other methods to format items in a way that is suitable for a specific source code location. + member DisplayContext : FSharpDisplayContext + + /// Indicates if the reference is a definition for the symbol, either in a signature or implementation + member IsFromDefinition : bool + + /// Indicates if the reference is in a pattern + member IsFromPattern : bool + + /// Indicates if the reference is in a syntactic type + member IsFromType : bool + + /// Indicates if the reference is in an attribute + member IsFromAttribute : bool + + /// Indicates if the reference is via the member being implemented in a class or object expression + member IsFromDispatchSlotImplementation : bool + + /// Indicates if the reference is either a builder or a custom operation in a computation expression + member IsFromComputationExpression : bool + + /// The file name the reference occurs in + member FileName: string + + /// The range of text representing the reference to the symbol + member RangeAlternate: range + diff --git a/src/fsharp/vs/IncrementalBuild.fs b/src/fsharp/vs/IncrementalBuild.fs index 3f069560961..d354780872a 100755 --- a/src/fsharp/vs/IncrementalBuild.fs +++ b/src/fsharp/vs/IncrementalBuild.fs @@ -23,6 +23,7 @@ open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.TypeChecker open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.SourceCodeServices open Internal.Utilities open Internal.Utilities.Collections @@ -860,7 +861,7 @@ module internal IncrementalBuild = | None->None /// Given an input value, find the corresponding slot. - let TryGetSlotByInput<'T>(node:Vector<'T>,input:'T,build:PartialBuild,equals:'T->'T->bool): int option = + let TryGetSlotByInput<'T>(node:Vector<'T>,build:PartialBuild,found:'T->bool): int option = let expr = GetExprByName(build,node) let id = expr.Id match build.Results.TryFind id with @@ -872,7 +873,7 @@ module internal IncrementalBuild = match result with | Available(o,_,_) -> let o = o :?> 'T - if equals o input then Some slot else acc + if found o then Some slot else acc | _ -> acc let slotOption = rv.FoldLeft MatchNames None slotOption @@ -951,6 +952,8 @@ module internal IncrementalBuild = let AsScalar (taskname:string) (input:Vector<'I>): Scalar<'I array> = Demultiplex taskname (fun _ctok x -> cancellable.Return x) input + let VectorInput(node:Vector<'T>, values: 'T list) = (node.Name, values.Length, List.map box values) + /// Declare build outputs and bind them to real values. type BuildDescriptionScope() = let mutable outputs = [] @@ -965,100 +968,6 @@ module internal IncrementalBuild = ToBound(ToBuild outputs,inputs) -[] -type FSharpErrorSeverity = - | Warning - | Error - -type FSharpErrorInfo(fileName, s:pos, e:pos, severity: FSharpErrorSeverity, message: string, subcategory: string, errorNum: int) = - member __.StartLine = Line.toZ s.Line - member __.StartLineAlternate = s.Line - member __.EndLine = Line.toZ e.Line - member __.EndLineAlternate = e.Line - member __.StartColumn = s.Column - member __.EndColumn = e.Column - member __.Severity = severity - member __.Message = message - member __.Subcategory = subcategory - member __.FileName = fileName - member __.ErrorNumber = errorNum - member __.WithStart(newStart) = FSharpErrorInfo(fileName, newStart, e, severity, message, subcategory, errorNum) - member __.WithEnd(newEnd) = FSharpErrorInfo(fileName, s, newEnd, severity, message, subcategory, errorNum) - override __.ToString()= sprintf "%s (%d,%d)-(%d,%d) %s %s %s" fileName (int s.Line) (s.Column + 1) (int e.Line) (e.Column + 1) subcategory (if severity=FSharpErrorSeverity.Warning then "warning" else "error") message - - /// Decompose a warning or error into parts: position, severity, message, error number - static member (*internal*) CreateFromException(exn, isError, trim:bool, fallbackRange:range) = - let m = match GetRangeOfDiagnostic exn with Some m -> m | None -> fallbackRange - let e = if trim then m.Start else m.End - let msg = bufs (fun buf -> OutputPhasedDiagnostic buf exn false) - let errorNum = GetDiagnosticNumber exn - FSharpErrorInfo(m.FileName, m.Start, e, (if isError then FSharpErrorSeverity.Error else FSharpErrorSeverity.Warning), msg, exn.Subcategory(), errorNum) - - /// Decompose a warning or error into parts: position, severity, message, error number - static member internal CreateFromExceptionAndAdjustEof(exn, isError, trim:bool, fallbackRange:range, (linesCount:int, lastLength:int)) = - let r = FSharpErrorInfo.CreateFromException(exn,isError,trim,fallbackRange) - - // Adjust to make sure that errors reported at Eof are shown at the linesCount - let startline, schange = min (r.StartLineAlternate, false) (linesCount, true) - let endline, echange = min (r.EndLineAlternate, false) (linesCount, true) - - if not (schange || echange) then r - else - let r = if schange then r.WithStart(mkPos startline lastLength) else r - if echange then r.WithEnd(mkPos endline (1 + lastLength)) else r - - -/// Use to reset error and warning handlers -[] -type ErrorScope() = - let mutable errors = [] - static let mutable mostRecentError = None - let unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck - let unwindEL = - PushErrorLoggerPhaseUntilUnwind (fun _oldLogger -> - { new ErrorLogger("ErrorScope") with - member x.DiagnosticSink(exn, isError) = - let err = FSharpErrorInfo.CreateFromException(exn,isError,false,range.Zero) - errors <- err :: errors - if isError then - mostRecentError <- Some err - member x.ErrorCount = errors.Length }) - - member x.Errors = errors |> List.filter (fun error -> error.Severity = FSharpErrorSeverity.Error) - member x.Warnings = errors |> List.filter (fun error -> error.Severity = FSharpErrorSeverity.Warning) - member x.Diagnostics = errors - member x.TryGetFirstErrorText() = - match x.Errors with - | error :: _ -> Some error.Message - | [] -> None - - interface IDisposable with - member d.Dispose() = - unwindEL.Dispose() (* unwind pushes when ErrorScope disposes *) - unwindBP.Dispose() - - static member MostRecentError = mostRecentError - - static member Protect<'a> (m:range) (f:unit->'a) (err:string->'a): 'a = - use errorScope = new ErrorScope() - let res = - try - Some (f()) - with e -> errorRecovery e m; None - match res with - | Some res ->res - | None -> - match errorScope.TryGetFirstErrorText() with - | Some text -> err text - | None -> err "" - - static member ProtectWithDefault m f dflt = - ErrorScope.Protect m f (fun _ -> dflt) - - static member ProtectAndDiscard m f = - ErrorScope.Protect m f (fun _ -> ()) - - // Record the most recent IncrementalBuilder events, so we can more easily unittest/debug the @@ -1118,6 +1027,7 @@ type TypeCheckAccumulator = tcSymbolUses: TcSymbolUses list topAttribs:TopAttribs option typedImplFiles:TypedImplFile list + tcDependencyFiles: string list tcErrors:(PhasedDiagnostic * FSharpErrorSeverity) list } // errors=true, warnings=false @@ -1165,38 +1075,6 @@ type FrameworkImportsCache(keepStrongly) = return tcGlobals,frameworkTcImports,nonFrameworkResolutions,unresolved } -/// An error logger that capture errors, filtering them according to warning levels etc. -type internal CompilationErrorLogger (debugName:string, tcConfig:TcConfig) = - inherit ErrorLogger("CompilationErrorLogger("+debugName+")") - - let mutable errorCount = 0 - let diagnostics = new ResizeArray<_>() - - override x.DiagnosticSink(exn, isError) = - if isError || ReportWarningAsError (tcConfig.globalWarnLevel, tcConfig.specificWarnOff, tcConfig.specificWarnOn, tcConfig.specificWarnAsError, tcConfig.specificWarnAsWarn, tcConfig.globalWarnAsError) exn then - diagnostics.Add(exn, isError) - errorCount <- errorCount + 1 - else if ReportWarning (tcConfig.globalWarnLevel, tcConfig.specificWarnOff, tcConfig.specificWarnOn) exn then - diagnostics.Add(exn, isError) - - override x.ErrorCount = errorCount - - member x.GetErrors() = - [ for (e,isError) in diagnostics -> e, (if isError then FSharpErrorSeverity.Error else FSharpErrorSeverity.Warning) ] - - -/// This represents the global state established as each task function runs as part of the build. -/// -/// Use to reset error and warning handlers. -type CompilationGlobalsScope(errorLogger:ErrorLogger, phase: BuildPhase) = - let unwindEL = PushErrorLoggerPhaseUntilUnwind(fun _ -> errorLogger) - let unwindBP = PushThreadBuildPhaseUntilUnwind phase - // Return the disposable object that cleans up - interface IDisposable with - member d.Dispose() = - unwindBP.Dispose() - unwindEL.Dispose() - //------------------------------------------------------------------------------------ // Rules for reactive building. @@ -1215,6 +1093,7 @@ type PartialCheckResults = Errors: (PhasedDiagnostic * FSharpErrorSeverity) list TcResolutions: TcResolutions list TcSymbolUses: TcSymbolUses list + TcDependencyFiles: string list TopAttribs: TopAttribs option TimeStamp: System.DateTime } @@ -1227,6 +1106,7 @@ type PartialCheckResults = Errors = tcAcc.tcErrors TcResolutions = tcAcc.tcResolutions TcSymbolUses = tcAcc.tcSymbolUses + TcDependencyFiles = tcAcc.tcDependencyFiles TopAttribs = tcAcc.topAttribs TimeStamp = timestamp } @@ -1299,6 +1179,21 @@ type IncrementalBuilder(tcGlobals,frameworkTcImports, nonFrameworkAssemblyInputs let defaultTimeStamp = DateTime.Now + let basicDependencies = + [ for (UnresolvedAssemblyReference(referenceText, _)) in unresolvedReferences do + // Exclude things that are definitely not a file name + if not(FileSystem.IsInvalidPathShim(referenceText)) then + let file = if FileSystem.IsPathRootedShim(referenceText) then referenceText else Path.Combine(projectDirectory,referenceText) + yield file + + for r in nonFrameworkResolutions do + yield r.resolvedPath ] + + let allDependencies = + [ yield! basicDependencies + for (_,f,_) in sourceFiles do + yield f ] + // The IncrementalBuilder needs to hold up to one item that needs to be disposed, which is the tcImports for the incremental // build. let mutable cleanupItem = None: TcImports option @@ -1423,6 +1318,7 @@ type IncrementalBuilder(tcGlobals,frameworkTcImports, nonFrameworkAssemblyInputs tcSymbolUses=[] topAttribs=None typedImplFiles=[] + tcDependencyFiles=basicDependencies tcErrors = loadClosureErrors @ errorLogger.GetErrors() } return tcAcc } @@ -1468,7 +1364,8 @@ type IncrementalBuilder(tcGlobals,frameworkTcImports, nonFrameworkAssemblyInputs typedImplFiles=typedImplFiles tcResolutions=tcAcc.tcResolutions @ [tcResolutions] tcSymbolUses=tcAcc.tcSymbolUses @ [tcSymbolUses] - tcErrors = tcAcc.tcErrors @ parseErrors @ capturingErrorLogger.GetErrors() } + tcErrors = tcAcc.tcErrors @ parseErrors @ capturingErrorLogger.GetErrors() + tcDependencyFiles = filename :: tcAcc.tcDependencyFiles } } // Run part of the Eventually<_> computation until a timeout is reached. If not complete, @@ -1605,27 +1502,13 @@ type IncrementalBuilder(tcGlobals,frameworkTcImports, nonFrameworkAssemblyInputs // END OF BUILD DESCRIPTION // --------------------------------------------------------------------------------------------- - - let fileDependencies = - [ for (UnresolvedAssemblyReference(referenceText, _)) in unresolvedReferences do - // Exclude things that are definitely not a file name - if not(FileSystem.IsInvalidPathShim(referenceText)) then - let file = if FileSystem.IsPathRootedShim(referenceText) then referenceText else Path.Combine(projectDirectory,referenceText) - yield file - - for r in nonFrameworkResolutions do - yield r.resolvedPath - - for (_,f,_) in sourceFiles do - yield f - ] - do IncrementalBuilderEventTesting.MRU.Add(IncrementalBuilderEventTesting.IBECreated) + let buildInputs = [ BuildInput.VectorInput (fileNamesNode, sourceFiles) BuildInput.VectorInput (referencedAssembliesNode, nonFrameworkAssemblyInputs) ] // This is the initial representation of progress through the build, i.e. we have made no progress. - let mutable partialBuild = buildDescription.GetInitialPartialBuild buildInputs + let mutable partialBuild = buildDescription.GetInitialPartialBuild (buildInputs) let SavePartialBuild (ctok: CompilationThreadToken) b = RequireCompilationThread ctok // modifying state @@ -1636,13 +1519,13 @@ type IncrementalBuilder(tcGlobals,frameworkTcImports, nonFrameworkAssemblyInputs member this.IncrementUsageCount() = assertNotDisposed() - referenceCount <- referenceCount + 1 + System.Threading.Interlocked.Increment(&referenceCount) |> ignore { new System.IDisposable with member x.Dispose() = this.DecrementUsageCount() } member this.DecrementUsageCount() = assertNotDisposed() - referenceCount <- referenceCount - 1 - if referenceCount = 0 then + let currentValue = System.Threading.Interlocked.Decrement(&referenceCount) + if currentValue = 0 then disposed <- true disposeCleanupItem() @@ -1654,7 +1537,8 @@ type IncrementalBuilder(tcGlobals,frameworkTcImports, nonFrameworkAssemblyInputs member __.FileChecked = fileChecked.Publish member __.ProjectChecked = projectChecked.Publish member __.ImportedCcusInvalidated = importsInvalidated.Publish - member __.Dependencies = fileDependencies + member __.AllDependenciesDeprecated = allDependencies + #if EXTENSIONTYPING member __.ThereAreLiveTypeProviders = let liveTPs = @@ -1749,18 +1633,18 @@ type IncrementalBuilder(tcGlobals,frameworkTcImports, nonFrameworkAssemblyInputs member __.GetSlotOfFileName(filename:string) = // Get the slot of the given file and force it to build. - let CompareFileNames (_,f1,_) (_,f2,_) = + let CompareFileNames (_,f2,_) = let result = - System.String.Compare(f1,f2,StringComparison.CurrentCultureIgnoreCase)=0 - || System.String.Compare(FileSystem.GetFullPathShim(f1),FileSystem.GetFullPathShim(f2),StringComparison.CurrentCultureIgnoreCase)=0 + String.Compare(filename,f2,StringComparison.CurrentCultureIgnoreCase)=0 + || String.Compare(FileSystem.GetFullPathShim(filename),FileSystem.GetFullPathShim(f2),StringComparison.CurrentCultureIgnoreCase)=0 result - match TryGetSlotByInput(fileNamesNode,(rangeStartup,filename,(false,false)),partialBuild,CompareFileNames) with + match TryGetSlotByInput(fileNamesNode,partialBuild,CompareFileNames) with | Some slot -> slot | None -> failwith (sprintf "The file '%s' was not part of the project. Did you call InvalidateConfiguration when the list of files in the project changed?" filename) member __.GetSlotsCount () = let expr = GetExprByName(partialBuild,fileNamesNode) - match partialBuild.Results.TryFind (expr.Id) with + match partialBuild.Results.TryFind(expr.Id) with | Some (VectorResult vr) -> vr.Size | _ -> failwith "Failed to find sizes" @@ -1830,7 +1714,9 @@ type IncrementalBuilder(tcGlobals,frameworkTcImports, nonFrameworkAssemblyInputs define::tcConfigB.conditionalCompilationDefines tcConfigB.projectReferences <- projectReferences - +#if COMPILER_SERVICE_DLL && NETSTANDARD1_6 + tcConfigB.useSimpleResolution <- true // turn off msbuild resolution +#endif // Apply command-line arguments and collect more source files if they are in the arguments let sourceFilesNew = try @@ -1920,3 +1806,4 @@ type IncrementalBuilder(tcGlobals,frameworkTcImports, nonFrameworkAssemblyInputs | None -> { new System.IDisposable with member __.Dispose() = () } member builder.IsBeingKeptAliveApartFromCacheEntry = (referenceCount >= 2) + diff --git a/src/fsharp/vs/IncrementalBuild.fsi b/src/fsharp/vs/IncrementalBuild.fsi index 70da8a445a8..f20b5d4c06a 100755 --- a/src/fsharp/vs/IncrementalBuild.fsi +++ b/src/fsharp/vs/IncrementalBuild.fsi @@ -14,40 +14,7 @@ open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.CompileOps open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.Tast - - -[] -type internal FSharpErrorSeverity = - | Warning - | Error - -[] -type internal FSharpErrorInfo = - member FileName: string - member StartLineAlternate:int - member EndLineAlternate:int - [] - member StartLine:Line0 - [] - member EndLine:Line0 - member StartColumn:int - member EndColumn:int - member Severity:FSharpErrorSeverity - member Message:string - member Subcategory:string - member ErrorNumber:int - static member internal CreateFromExceptionAndAdjustEof : PhasedDiagnostic * isError: bool * trim: bool * range * lastPosInFile:(int*int) -> FSharpErrorInfo - static member internal CreateFromException : PhasedDiagnostic * isError: bool * trim: bool * range -> FSharpErrorInfo - -// Implementation details used by other code in the compiler -[] -type internal ErrorScope = - interface IDisposable - new : unit -> ErrorScope - member Diagnostics : FSharpErrorInfo list - static member Protect<'a> : range -> (unit->'a) -> (string->'a) -> 'a - static member ProtectWithDefault<'a> : range -> (unit -> 'a) -> 'a -> 'a - static member ProtectAndDiscard : range -> (unit -> unit) -> unit +open Microsoft.FSharp.Compiler.SourceCodeServices /// Lookup the global static cache for building the FrameworkTcImports type internal FrameworkImportsCache = @@ -67,16 +34,6 @@ module internal IncrementalBuilderEventTesting = val GetMostRecentIncrementalBuildEvents : int -> IBEvent list val GetCurrentIncrementalBuildEventNum : unit -> int -/// An error logger that capture errors, filtering them according to warning levels etc. -type internal CompilationErrorLogger = - inherit ErrorLogger - - /// Create the error logger - new : debugName:string * tcConfig:TcConfig -> CompilationErrorLogger - - /// Get the captured errors - member GetErrors : unit -> (PhasedDiagnostic * FSharpErrorSeverity) list - /// Represents the state in the incremental graph associated with checking a file type internal PartialCheckResults = { /// This field is None if a major unrecovered error occurred when preparing the initial state @@ -97,7 +54,9 @@ type internal PartialCheckResults = /// Represents the collected uses of symbols from type checking TcSymbolUses: TcSymbolUses list - /// Represents the collected attributes to apply to the module of assembly generates + TcDependencyFiles: string list + + /// Represents the collected attributes to apply to the module of assuembly generates TopAttribs: TypeChecker.TopAttribs option TimeStamp: DateTime } @@ -138,7 +97,7 @@ type internal IncrementalBuilder = member ImportedCcusInvalidated : IEvent /// The list of files the build depends on - member Dependencies : string list + member AllDependenciesDeprecated : string list #if EXTENSIONTYPING /// Whether there are any 'live' type providers that may need a refresh when a project is Cleaned member ThereAreLiveTypeProviders : bool @@ -286,9 +245,3 @@ module internal IncrementalBuild = /// Set the concrete inputs for this build. member GetInitialPartialBuild : vectorinputs: BuildInput list -> PartialBuild -/// This represents the global state established as each task function runs as part of the build. -/// -/// Use to reset error and warning handlers. -type internal CompilationGlobalsScope = - new : ErrorLogger * BuildPhase -> CompilationGlobalsScope - interface IDisposable \ No newline at end of file diff --git a/src/fsharp/vs/ServiceAssemblyContent.fs b/src/fsharp/vs/ServiceAssemblyContent.fs index 5ca9beefade..008106818ef 100644 --- a/src/fsharp/vs/ServiceAssemblyContent.fs +++ b/src/fsharp/vs/ServiceAssemblyContent.fs @@ -283,7 +283,10 @@ module AssemblyContentProvider = let rec private traverseEntity contentType (parent: Parent) (entity: FSharpEntity) = - seq { if not entity.IsProvided then + seq { +#if EXTENSIONTYPING + if not entity.IsProvided then +#endif match contentType, entity.Accessibility.IsPublic with | Full, _ | Public, true -> let ns = entity.Namespace |> Option.map (fun x -> x.Split '.') |> Option.orElse parent.Namespace @@ -357,7 +360,11 @@ module AssemblyContentProvider = // on-demand. However a more compete review may be warranted. use _ignoreAllDiagnostics = new ErrorScope() +#if EXTENSIONTYPING match assemblies |> List.filter (fun x -> not x.IsProviderGenerated), fileName with +#else + match assemblies, fileName with +#endif | [], _ -> [] | assemblies, Some fileName -> let fileWriteTime = FileInfo(fileName).LastWriteTime @@ -392,13 +399,13 @@ type EntityCache() = member __.Clear() = dic.Clear() member x.Locking f = lock dic <| fun _ -> f (x :> IAssemblyContentCache) -type LongIdent = string +type StringLongIdent = string type Entity = - { FullRelativeName: LongIdent - Qualifier: LongIdent - Namespace: LongIdent option - Name: LongIdent + { FullRelativeName: StringLongIdent + Qualifier: StringLongIdent + Namespace: StringLongIdent option + Name: StringLongIdent LastIdent: string } override x.ToString() = sprintf "%A" x diff --git a/src/fsharp/vs/ServiceAssemblyContent.fsi b/src/fsharp/vs/ServiceAssemblyContent.fsi index 0a9d9b71d9f..c9135afa3a5 100644 --- a/src/fsharp/vs/ServiceAssemblyContent.fsi +++ b/src/fsharp/vs/ServiceAssemblyContent.fsi @@ -10,36 +10,69 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range /// Assembly content type. +#if COMPILER_PUBLIC_API +type AssemblyContentType = +#else type internal AssemblyContentType = - /// Public assembly content only. +#endif +/// Public assembly content only. | Public /// All assembly content. | Full /// Short identifier, i.e. an identifier that contains no dots. +#if COMPILER_PUBLIC_API +type ShortIdent = string +#else type internal ShortIdent = string +#endif /// An array of `ShortIdent`. +#if COMPILER_PUBLIC_API +type Idents = ShortIdent[] +#else type internal Idents = ShortIdent[] +#endif /// `ShortIdent` with a flag indicating if it's resolved in some scope. -type internal MaybeUnresolvedIdent = { Ident: ShortIdent; Resolved: bool } +#if COMPILER_PUBLIC_API +type MaybeUnresolvedIdent = +#else +type internal MaybeUnresolvedIdent = +#endif + { Ident: ShortIdent; Resolved: bool } /// Array of `MaybeUnresolvedIdent`. +#if COMPILER_PUBLIC_API +type MaybeUnresolvedIdents = MaybeUnresolvedIdent[] +#else type internal MaybeUnresolvedIdents = MaybeUnresolvedIdent[] +#endif /// Entity lookup type. [] +#if COMPILER_PUBLIC_API +type LookupType = +#else type internal LookupType = +#endif | Fuzzy | Precise /// Assembly path. +#if COMPILER_PUBLIC_API +type AssemblyPath = string +#else type internal AssemblyPath = string +#endif /// Represents type, module, member, function or value in a compiled assembly. [] +#if COMPILER_PUBLIC_API +type AssemblySymbol = +#else type internal AssemblySymbol = +#endif { /// Full entity name as it's seen in compiled code (raw FSharpEntity.FullName, FSharpValueOrFunction.FullName). FullName: string /// Entity name parts with removed module suffixes (Ns.M1Module.M2Module.M3.entity -> Ns.M1.M2.M3.entity) @@ -69,14 +102,22 @@ type internal AssemblyContentCacheEntry = /// Assembly content cache. [] +#if COMPILER_PUBLIC_API +type IAssemblyContentCache = +#else type internal IAssemblyContentCache = +#endif /// Try get an assembly cached content. abstract TryGet: AssemblyPath -> AssemblyContentCacheEntry option /// Store an assembly content. abstract Set: AssemblyPath -> AssemblyContentCacheEntry -> unit /// Thread safe wrapper over `IAssemblyContentCache`. +#if COMPILER_PUBLIC_API +type EntityCache = +#else type internal EntityCache = +#endif interface IAssemblyContentCache new : unit -> EntityCache /// Clears the cache. @@ -84,24 +125,36 @@ type internal EntityCache = /// Performs an operation on the cache in thread safe manner. member Locking : (IAssemblyContentCache -> 'T) -> 'T -/// Long identifier (i.e. it may contain dots). -type internal LongIdent = string - -/// Helper data structure representing a symbol, suitable for implementing unresolved identifiers resolution code fixes. +/// Lond identifier (i.e. it may contain dots). +#if COMPILER_PUBLIC_API +type StringLongIdent = string +#else +type internal StringLongIdent = string +#endif + +/// Helper data structure representing a symbol, sutable for implementing unresolved identifiers resolution code fixes. +#if COMPILER_PUBLIC_API +type Entity = +#else type internal Entity = +#endif { /// Full name, relative to the current scope. - FullRelativeName: LongIdent + FullRelativeName: StringLongIdent /// Ident parts needed to append to the current ident to make it resolvable in current scope. - Qualifier: LongIdent + Qualifier: StringLongIdent /// Namespace that is needed to open to make the entity resolvable in the current scope. - Namespace: LongIdent option + Namespace: StringLongIdent option /// Full display name (i.e. last ident plus modules with `RequireQualifiedAccess` attribute prefixed). - Name: LongIdent + Name: StringLongIdent /// Last part of the entity's full name. LastIdent: string } /// Provides assembly content. +#if COMPILER_PUBLIC_API +module AssemblyContentProvider = +#else module internal AssemblyContentProvider = +#endif /// Given a `FSharpAssemblySignature`, returns assembly content. val getAssemblySignatureContent : AssemblyContentType -> FSharpAssemblySignature -> AssemblySymbol list @@ -114,7 +167,11 @@ module internal AssemblyContentProvider = -> AssemblySymbol list /// Kind of lexical scope. +#if COMPILER_PUBLIC_API +type ScopeKind = +#else type internal ScopeKind = +#endif | Namespace | TopModule | NestedModule @@ -122,19 +179,31 @@ type internal ScopeKind = | HashDirective /// Insert open namespace context. +#if COMPILER_PUBLIC_API +type InsertContext = +#else type internal InsertContext = +#endif { /// Current scope kind. ScopeKind: ScopeKind /// Current position (F# compiler line number). Pos: pos } /// Where open statements should be added. +#if COMPILER_PUBLIC_API +type OpenStatementInsertionPoint = +#else type internal OpenStatementInsertionPoint = +#endif | TopLevel | Nearest /// Parse AST helpers. +#if COMPILER_PUBLIC_API +module ParsedInput = +#else module internal ParsedInput = +#endif /// Returns `InsertContext` based on current position and symbol idents. val tryFindInsertionContext : @@ -153,7 +222,11 @@ module internal ParsedInput = val adjustInsertionPoint : getLineStr: (int -> string) -> ctx: InsertContext -> pos [] +#if COMPILER_PUBLIC_API +module Extensions = +#else module internal Extensions = +#endif type FSharpEntity with /// Safe version of `FullName`. member TryGetFullName : unit -> string option diff --git a/src/fsharp/vs/ServiceDeclarationLists.fs b/src/fsharp/vs/ServiceDeclarationLists.fs new file mode 100644 index 00000000000..137589bd78c --- /dev/null +++ b/src/fsharp/vs/ServiceDeclarationLists.fs @@ -0,0 +1,788 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +//---------------------------------------------------------------------------- +// Open up the compiler as an incremental service for parsing, +// type checking and intellisense-like environment-reporting. +//-------------------------------------------------------------------------- + +namespace Microsoft.FSharp.Compiler.SourceCodeServices + +open System +open System.Collections.Generic +open System.IO + +open Microsoft.FSharp.Core.Printf +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics + +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Layout.TaggedTextOps +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.InfoReader + +[] +module EnvMisc3 = + /// dataTipSpinWaitTime limits how long we block the UI thread while a tooltip pops up next to a selected item in an IntelliSense completion list. + /// This time appears to be somewhat amortized by the time it takes the VS completion UI to actually bring up the tooltip after selecting an item in the first place. + let dataTipSpinWaitTime = GetEnvInteger "FCS_ToolTipSpinWaitTime" 300 + + +[] +type FSharpMethodGroupItemParameter(name: string, canonicalTypeTextForSorting: string, display: layout, isOptional: bool) = + member __.ParameterName = name + member __.CanonicalTypeTextForSorting = canonicalTypeTextForSorting + member __.StructuredDisplay = display + member __.Display = showL display + member __.IsOptional = isOptional + +[] +module internal DescriptionListsImpl = + + let isFunction g typ = + let _,tau = tryDestForallTy g typ + isFunTy g tau + + let printCanonicalizedTypeName g (denv:DisplayEnv) tau = + // get rid of F# abbreviations and such + let strippedType = stripTyEqnsWrtErasure EraseAll g tau + // pretend no namespaces are open + let denv = denv.SetOpenPaths([]) + // now printing will see a .NET-like canonical representation, that is good for sorting overloads into a reasonable order (see bug 94520) + NicePrint.stringOfTy denv strippedType + + let PrettyParamOfRecdField g denv (f: RecdField) = + FSharpMethodGroupItemParameter( + name = f.Name, + canonicalTypeTextForSorting = printCanonicalizedTypeName g denv f.FormalType, + // Note: the instantiation of any type parameters is currently incorporated directly into the type + // rather than being returned separately. + display = NicePrint.prettyLayoutOfType denv f.FormalType, + isOptional=false) + + let PrettyParamOfUnionCaseField g denv isGenerated (i: int) (f: RecdField) = + let initial = PrettyParamOfRecdField g denv f + let display = + if isGenerated i f then + initial.StructuredDisplay + else + // TODO: in this case ucinst is ignored - it gives the instantiation of the type parameters of + // the union type containing this case. + NicePrint.layoutOfParamData denv (ParamData(false, false, NotOptional, NoCallerInfo, Some f.Id, ReflectedArgInfo.None, f.FormalType)) + FSharpMethodGroupItemParameter( + name=initial.ParameterName, + canonicalTypeTextForSorting=initial.CanonicalTypeTextForSorting, + display=display, + isOptional=false) + + let ParamOfParamData g denv (ParamData(_isParamArrayArg, _isOutArg, optArgInfo, _callerInfoInfo, nmOpt, _reflArgInfo, pty) as paramData) = + FSharpMethodGroupItemParameter( + name = (match nmOpt with None -> "" | Some pn -> pn.idText), + canonicalTypeTextForSorting = printCanonicalizedTypeName g denv pty, + display = NicePrint.layoutOfParamData denv paramData, + isOptional=optArgInfo.IsOptional) + + // TODO this code is similar to NicePrint.fs:formatParamDataToBuffer, refactor or figure out why different? + let PrettyParamsOfParamDatas g denv typarInst (paramDatas:ParamData list) rty = + let paramInfo,paramTypes = + paramDatas + |> List.map (fun (ParamData(isParamArrayArg, _isOutArg, optArgInfo, _callerInfoInfo, nmOpt, _reflArgInfo, pty)) -> + let isOptArg = optArgInfo.IsOptional + match nmOpt, isOptArg, tryDestOptionTy denv.g pty with + // Layout an optional argument + | Some id, true, ptyOpt -> + let nm = id.idText + // detect parameter type, if ptyOpt is None - this is .NET style optional argument + let pty = defaultArg ptyOpt pty + (nm, isOptArg, SepL.questionMark ^^ (wordL (TaggedTextOps.tagParameter nm))), pty + // Layout an unnamed argument + | None, _,_ -> + ("", isOptArg, emptyL), pty + // Layout a named argument + | Some id,_,_ -> + let nm = id.idText + let prefix = + if isParamArrayArg then + NicePrint.PrintUtilities.layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute ^^ + wordL (TaggedTextOps.tagParameter nm) ^^ + RightL.colon + //sprintf "%s %s: " (NicePrint.PrintUtilities.layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute |> showL) nm + else + wordL (TaggedTextOps.tagParameter nm) ^^ + RightL.colon + //sprintf "%s: " nm + (nm,isOptArg, prefix),pty) + |> List.unzip + + // Prettify everything + let prettyTyparInst, (prettyParamTys, _prettyRetTy), (prettyParamTysL, prettyRetTyL), prettyConstraintsL = + NicePrint.prettyLayoutOfInstAndSig denv (typarInst, paramTypes, rty) + + // Remake the params using the prettified versions + let prettyParams = + (paramInfo,prettyParamTys,prettyParamTysL) |||> List.map3 (fun (nm,isOptArg,paramPrefix) tau tyL -> + FSharpMethodGroupItemParameter( + name = nm, + canonicalTypeTextForSorting = printCanonicalizedTypeName g denv tau, + display = paramPrefix ^^ tyL, + isOptional=isOptArg + )) + + prettyTyparInst, prettyParams, prettyRetTyL, prettyConstraintsL + + let PrettyParamsOfTypes g denv typarInst paramTys retTy = + + // Prettify everything + let prettyTyparInst, (prettyParamTys, _prettyRetTy), (prettyParamTysL, prettyRetTyL), prettyConstraintsL = + NicePrint.prettyLayoutOfInstAndSig denv (typarInst, paramTys, retTy) + + // Remake the params using the prettified versions + let parameters = + (prettyParamTys,prettyParamTysL) + ||> List.zip + |> List.map (fun (tau, tyL) -> + FSharpMethodGroupItemParameter( + name = "", + canonicalTypeTextForSorting = printCanonicalizedTypeName g denv tau, + display = tyL, + isOptional=false + )) + + // Return the results + prettyTyparInst, parameters, prettyRetTyL, prettyConstraintsL + + +#if EXTENSIONTYPING + + /// Get the set of static parameters associated with an item + let StaticParamsOfItem (infoReader:InfoReader) m denv item = + let amap = infoReader.amap + let g = infoReader.g + match item with + | SymbolHelpers.ItemIsWithStaticArguments m g staticParameters -> + staticParameters + |> Array.map (fun sp -> + let typ = Import.ImportProvidedType amap m (sp.PApply((fun x -> x.ParameterType),m)) + let spKind = NicePrint.prettyLayoutOfType denv typ + let spName = sp.PUntaint((fun sp -> sp.Name), m) + let spOpt = sp.PUntaint((fun sp -> sp.IsOptional), m) + FSharpMethodGroupItemParameter( + name = spName, + canonicalTypeTextForSorting = showL spKind, + display = (if spOpt then SepL.questionMark else emptyL) ^^ wordL (TaggedTextOps.tagParameter spName) ^^ RightL.colon ^^ spKind, + //display = sprintf "%s%s: %s" (if spOpt then "?" else "") spName spKind, + isOptional=spOpt)) + | _ -> [| |] +#endif + + /// Get all the information about parameters and "prettify" the types by choosing nice type variable + /// names. This is similar to the other variations on "show me an item" code. This version is + /// is used when presenting groups of methods (see FSharpMethodGroup). It is possible these different + /// versions could be better unified. + let rec PrettyParamsAndReturnTypeOfItem (infoReader:InfoReader) m denv (item: ItemWithInst) = + let amap = infoReader.amap + let g = infoReader.g + let denv = { SymbolHelpers.SimplerDisplayEnv denv with useColonForReturnType=true} + match item.Item with + | Item.Value vref -> + let getPrettyParamsOfTypes() = + let tau = vref.TauType + match tryDestFunTy denv.g tau with + | Some(arg,rtau) -> + let args = tryDestRefTupleTy denv.g arg + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfTypes g denv item.TyparInst args rtau + // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned + // for display as part of the method group + prettyParams, prettyRetTyL + | None -> + let _prettyTyparInst, prettyTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] tau + [], prettyTyL + + match vref.ValReprInfo with + | None -> + // ValReprInfo = None i.e. in let bindings defined in types or in local functions + // in this case use old approach and return only information about types + getPrettyParamsOfTypes () + + | Some valRefInfo -> + // ValReprInfo will exist for top-level syntactic functions + // per spec: binding is considered to define a syntactic function if it is either a function or its immediate right-hand-side is a anonymous function + let (_, argInfos, lastRetTy, _) = GetTopValTypeInFSharpForm g valRefInfo vref.Type m + match argInfos with + | [] -> + // handles cases like 'let foo = List.map' + getPrettyParamsOfTypes() + | firstCurriedArgInfo::_ -> + // result 'paramDatas' collection corresponds to the first argument of curried function + // i.e. let func (a : int) (b : int) = a + b + // paramDatas will contain information about a and retTy will be: int -> int + // This is good enough as we don't provide ways to display info for the second curried argument + let firstCurriedParamDatas = + firstCurriedArgInfo + |> List.map ParamNameAndType.FromArgInfo + |> List.map (fun (ParamNameAndType(nmOpt, pty)) -> ParamData(false, false, NotOptional, NoCallerInfo, nmOpt, ReflectedArgInfo.None, pty)) + + // Adjust the return type so it only strips the first argument + let curriedRetTy = + match tryDestFunTy denv.g vref.TauType with + | Some(_,rtau) -> rtau + | None -> lastRetTy + + let _prettyTyparInst, prettyFirstCurriedParams, prettyCurriedRetTyL, prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst firstCurriedParamDatas curriedRetTy + + let prettyCurriedRetTyL = prettyCurriedRetTyL ^^ SepL.space ^^ prettyConstraintsL + + prettyFirstCurriedParams, prettyCurriedRetTyL + + | Item.UnionCase(ucinfo,_) -> + let prettyParams = + match ucinfo.UnionCase.RecdFields with + | [f] -> [PrettyParamOfUnionCaseField g denv NicePrint.isGeneratedUnionCaseField -1 f] + | fs -> fs |> List.mapi (PrettyParamOfUnionCaseField g denv NicePrint.isGeneratedUnionCaseField) + let rty = generalizedTyconRef ucinfo.TyconRef + let rtyL = NicePrint.layoutType denv rty + prettyParams, rtyL + + | Item.ActivePatternCase(apref) -> + let v = apref.ActivePatternVal + let tau = v.TauType + let args, resTy = stripFunTy denv.g tau + + let apinfo = Option.get (TryGetActivePatternInfo v) + let aparity = apinfo.Names.Length + + let rty = if aparity <= 1 then resTy else (argsOfAppTy g resTy).[apref.CaseIndex] + + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfTypes g denv item.TyparInst args rty + // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned + // for display as part of the method group + prettyParams, prettyRetTyL + + | Item.ExnCase ecref -> + let prettyParams = ecref |> recdFieldsOfExnDefRef |> List.mapi (PrettyParamOfUnionCaseField g denv NicePrint.isGeneratedExceptionField) + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] g.exn_ty + prettyParams, prettyRetTyL + + | Item.RecdField rfinfo -> + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] rfinfo.FieldType + [], prettyRetTyL + + | Item.ILField finfo -> + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] (finfo.FieldType(amap,m)) + [], prettyRetTyL + + | Item.Event einfo -> + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] (PropTypOfEventInfo infoReader m AccessibleFromSomewhere einfo) + [], prettyRetTyL + + | Item.Property(_,pinfo :: _) -> + let paramDatas = pinfo.GetParamDatas(amap,m) + let rty = pinfo.GetPropertyType(amap,m) + + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst paramDatas rty + // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned + // for display as part of the method group + prettyParams, prettyRetTyL + + | Item.CtorGroup(_,(minfo :: _)) + | Item.MethodGroup(_,(minfo :: _),_) -> + let paramDatas = minfo.GetParamDatas(amap, m, minfo.FormalMethodInst) |> List.head + let rty = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst paramDatas rty + // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned + // for display as part of the method group + prettyParams, prettyRetTyL + + | Item.CustomBuilder (_,vref) -> + PrettyParamsAndReturnTypeOfItem infoReader m denv { item with Item = Item.Value vref } + + | Item.TypeVar _ -> + [], emptyL + + | Item.CustomOperation (_,usageText, Some minfo) -> + match usageText() with + | None -> + let argNamesAndTys = SymbolHelpers.ParamNameAndTypesOfUnaryCustomOperation g minfo + let argTys, _ = PrettyTypes.PrettifyTypes g (argNamesAndTys |> List.map (fun (ParamNameAndType(_,ty)) -> ty)) + let paramDatas = (argNamesAndTys, argTys) ||> List.map2 (fun (ParamNameAndType(nmOpt, _)) argTy -> ParamData(false, false, NotOptional, NoCallerInfo, nmOpt, ReflectedArgInfo.None,argTy)) + let rty = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst paramDatas rty + + // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned + // for display as part of the method group + prettyParams, prettyRetTyL + + | Some _ -> + let rty = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] rty + [], prettyRetTyL // no parameter data available for binary operators like 'zip', 'join' and 'groupJoin' since they use bespoke syntax + + | Item.FakeInterfaceCtor typ -> + let _prettyTyparInst, prettyRetTyL = NicePrint.prettyLayoutOfUncurriedSig denv item.TyparInst [] typ + [], prettyRetTyL + + | Item.DelegateCtor delty -> + let (SigOfFunctionForDelegate(_, _, _, fty)) = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomeFSharpCode + + // No need to pass more generic type information in here since the instanitations have already been applied + let _prettyTyparInst, prettyParams, prettyRetTyL, _prettyConstraintsL = PrettyParamsOfParamDatas g denv item.TyparInst [ParamData(false, false, NotOptional, NoCallerInfo, None, ReflectedArgInfo.None, fty)] delty + + // FUTURE: prettyTyparInst is the pretty version of the known instantiations of type parameters in the output. It could be returned + // for display as part of the method group + prettyParams, prettyRetTyL + + | _ -> + [], emptyL + + + /// Compute the index of the VS glyph shown with an item in the Intellisense menu + let GlyphOfItem(denv, item) : FSharpGlyph = + /// Find the glyph for the given representation. + let reprToGlyph repr = + match repr with + | TFSharpObjectRepr om -> + match om.fsobjmodel_kind with + | TTyconClass -> FSharpGlyph.Class + | TTyconInterface -> FSharpGlyph.Interface + | TTyconStruct -> FSharpGlyph.Struct + | TTyconDelegate _ -> FSharpGlyph.Delegate + | TTyconEnum _ -> FSharpGlyph.Enum + | TRecdRepr _ -> FSharpGlyph.Type + | TUnionRepr _ -> FSharpGlyph.Union + | TILObjectRepr (TILObjectReprData (_,_,td)) -> + match td.tdKind with + | ILTypeDefKind.Class -> FSharpGlyph.Class + | ILTypeDefKind.ValueType -> FSharpGlyph.Struct + | ILTypeDefKind.Interface -> FSharpGlyph.Interface + | ILTypeDefKind.Enum -> FSharpGlyph.Enum + | ILTypeDefKind.Delegate -> FSharpGlyph.Delegate + | TAsmRepr _ -> FSharpGlyph.Typedef + | TMeasureableRepr _-> FSharpGlyph.Typedef +#if EXTENSIONTYPING + | TProvidedTypeExtensionPoint _-> FSharpGlyph.Typedef + | TProvidedNamespaceExtensionPoint _-> FSharpGlyph.Typedef +#endif + | TNoRepr -> FSharpGlyph.Class + + /// Find the glyph for the given type representation. + let typeToGlyph typ = + if isAppTy denv.g typ then + let tcref = tcrefOfAppTy denv.g typ + tcref.TypeReprInfo |> reprToGlyph + elif isStructTupleTy denv.g typ then FSharpGlyph.Struct + elif isRefTupleTy denv.g typ then FSharpGlyph.Class + elif isFunction denv.g typ then FSharpGlyph.Delegate + elif isTyparTy denv.g typ then FSharpGlyph.Struct + else FSharpGlyph.Typedef + + // This may explore assemblies that are not in the reference set, + // e.g. for type abbreviations to types not in the reference set. + // In this case just use GlyphMajor.Class. + protectAssemblyExploration FSharpGlyph.Class (fun () -> + match item with + | Item.Value(vref) | Item.CustomBuilder (_,vref) -> + if isFunction denv.g vref.Type then FSharpGlyph.Method + elif vref.LiteralValue.IsSome then FSharpGlyph.Constant + else FSharpGlyph.Variable + | Item.Types(_,typ::_) -> typeToGlyph (stripTyEqns denv.g typ) + | Item.UnionCase _ + | Item.ActivePatternCase _ -> FSharpGlyph.EnumMember + | Item.ExnCase _ -> FSharpGlyph.Exception + | Item.RecdField _ -> FSharpGlyph.Field + | Item.ILField _ -> FSharpGlyph.Field + | Item.Event _ -> FSharpGlyph.Event + | Item.Property _ -> FSharpGlyph.Property + | Item.CtorGroup _ + | Item.DelegateCtor _ + | Item.FakeInterfaceCtor _ + | Item.CustomOperation _ -> FSharpGlyph.Method + | Item.MethodGroup (_, minfos, _) when minfos |> List.forall (fun minfo -> minfo.IsExtensionMember) -> FSharpGlyph.ExtensionMethod + | Item.MethodGroup _ -> FSharpGlyph.Method + | Item.TypeVar _ + | Item.Types _ -> FSharpGlyph.Class + | Item.UnqualifiedType (tcref :: _) -> + if tcref.IsEnumTycon || tcref.IsILEnumTycon then FSharpGlyph.Enum + elif tcref.IsExceptionDecl then FSharpGlyph.Exception + elif tcref.IsFSharpDelegateTycon then FSharpGlyph.Delegate + elif tcref.IsFSharpInterfaceTycon then FSharpGlyph.Interface + elif tcref.IsFSharpStructOrEnumTycon then FSharpGlyph.Struct + elif tcref.IsModule then FSharpGlyph.Module + elif tcref.IsNamespace then FSharpGlyph.NameSpace + elif tcref.IsUnionTycon then FSharpGlyph.Union + elif tcref.IsILTycon then + let (TILObjectReprData (_, _, tydef)) = tcref.ILTyconInfo + if tydef.IsInterface then FSharpGlyph.Interface + elif tydef.IsDelegate then FSharpGlyph.Delegate + elif tydef.IsEnum then FSharpGlyph.Enum + elif tydef.IsStructOrEnum then FSharpGlyph.Struct + else FSharpGlyph.Class + else FSharpGlyph.Class + | Item.ModuleOrNamespaces(modref::_) -> + if modref.IsNamespace then FSharpGlyph.NameSpace else FSharpGlyph.Module + | Item.ArgName _ -> FSharpGlyph.Variable + | Item.SetterArg _ -> FSharpGlyph.Variable + | _ -> FSharpGlyph.Error) + + + /// Get rid of groups of overloads an replace them with single items. + /// (This looks like it is doing the a similar thing as FlattenItems, this code + /// duplication could potentially be removed) + let AnotherFlattenItems g m item = + match item with + | Item.CtorGroup(nm,cinfos) -> List.map (fun minfo -> Item.CtorGroup(nm,[minfo])) cinfos + | Item.FakeInterfaceCtor _ + | Item.DelegateCtor _ -> [item] + | Item.NewDef _ + | Item.ILField _ -> [] + | Item.Event _ -> [] + | Item.RecdField(rfinfo) -> + if isFunction g rfinfo.FieldType then [item] else [] + | Item.Value v -> + if isFunction g v.Type then [item] else [] + | Item.UnionCase(ucr,_) -> + if not ucr.UnionCase.IsNullary then [item] else [] + | Item.ExnCase(ecr) -> + if isNil (recdFieldsOfExnDefRef ecr) then [] else [item] + | Item.Property(_,pinfos) -> + let pinfo = List.head pinfos + if pinfo.IsIndexer then [item] else [] +#if EXTENSIONTYPING + | SymbolHelpers.ItemIsWithStaticArguments m g _ -> + // we pretend that provided-types-with-static-args are method-like in order to get ParamInfo for them + [item] +#endif + | Item.MethodGroup(nm,minfos,orig) -> minfos |> List.map (fun minfo -> Item.MethodGroup(nm,[minfo],orig)) + | Item.CustomOperation(_name, _helpText, _minfo) -> [item] + | Item.TypeVar _ -> [] + | Item.CustomBuilder _ -> [] + | _ -> [] + + +/// An intellisense declaration +[] +type FSharpDeclarationListItem(name: string, nameInCode: string, fullName: string, glyph: FSharpGlyph, info, accessibility: FSharpAccessibility option, + kind: CompletionItemKind, isOwnMember: bool, priority: int, isResolved: bool, namespaceToOpen: string option) = + + let mutable descriptionTextHolder: FSharpToolTipText<_> option = None + let mutable task = null + + member __.Name = name + member __.NameInCode = nameInCode + + member __.StructuredDescriptionTextAsync = + match info with + | Choice1Of2 (items: CompletionItem list, infoReader, m, denv, reactor:IReactorOperations, checkAlive) -> + // reactor causes the lambda to execute on the background compiler thread, through the Reactor + reactor.EnqueueAndAwaitOpAsync ("StructuredDescriptionTextAsync", fun ctok -> + RequireCompilationThread ctok + // This is where we do some work which may touch TAST data structures owned by the IncrementalBuilder - infoReader, item etc. + // It is written to be robust to a disposal of an IncrementalBuilder, in which case it will just return the empty string. + // It is best to think of this as a "weak reference" to the IncrementalBuilder, i.e. this code is written to be robust to its + // disposal. Yes, you are right to scratch your head here, but this is ok. + cancellable.Return( + if checkAlive() then + FSharpToolTipText(items |> List.map (fun x -> SymbolHelpers.FormatStructuredDescriptionOfItem true infoReader m denv x.ItemWithInst)) + else + FSharpToolTipText [ FSharpStructuredToolTipElement.Single(wordL (tagText (FSComp.SR.descriptionUnavailable())), FSharpXmlDoc.None) ])) + | Choice2Of2 result -> + async.Return result + + member decl.DescriptionTextAsync = + decl.StructuredDescriptionTextAsync + |> Tooltips.Map Tooltips.ToFSharpToolTipText + + member decl.StructuredDescriptionText = + ErrorScope.Protect Range.range0 + (fun () -> + match descriptionTextHolder with + | Some descriptionText -> descriptionText + | None -> + match info with + | Choice1Of2 _ -> + // The dataTipSpinWaitTime limits how long we block the UI thread while a tooltip pops up next to a selected item in an IntelliSense completion list. + // This time appears to be somewhat amortized by the time it takes the VS completion UI to actually bring up the tooltip after selecting an item in the first place. + if isNull task then + // kick off the actual (non-cooperative) work + task <- System.Threading.Tasks.Task.Factory.StartNew(fun() -> + let text = decl.StructuredDescriptionTextAsync |> Async.RunSynchronously + descriptionTextHolder <- Some text) + + // The dataTipSpinWaitTime limits how long we block the UI thread while a tooltip pops up next to a selected item in an IntelliSense completion list. + // This time appears to be somewhat amortized by the time it takes the VS completion UI to actually bring up the tooltip after selecting an item in the first place. + task.Wait EnvMisc3.dataTipSpinWaitTime |> ignore + match descriptionTextHolder with + | Some text -> text + | None -> FSharpToolTipText [ FSharpStructuredToolTipElement.Single(wordL (tagText (FSComp.SR.loadingDescription())), FSharpXmlDoc.None) ] + + | Choice2Of2 result -> + result + ) + (fun err -> FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError err]) + member decl.DescriptionText = decl.StructuredDescriptionText |> Tooltips.ToFSharpToolTipText + member __.Glyph = glyph + member __.Accessibility = accessibility + member __.Kind = kind + member __.IsOwnMember = isOwnMember + member __.MinorPriority = priority + member __.FullName = fullName + member __.IsResolved = isResolved + member __.NamespaceToOpen = namespaceToOpen + +/// A table of declarations for Intellisense completion +[] +type FSharpDeclarationListInfo(declarations: FSharpDeclarationListItem[], isForType: bool, isError: bool) = + member __.Items = declarations + member __.IsForType = isForType + member __.IsError = isError + + // Make a 'Declarations' object for a set of selected items + static member Create(infoReader:InfoReader, m, denv, getAccessibility, items: CompletionItem list, reactor, currentNamespaceOrModule: string[] option, isAttributeApplicationContext: bool, checkAlive) = + let g = infoReader.g + let isForType = items |> List.exists (fun x -> x.Type.IsSome) + let items = items |> SymbolHelpers.RemoveExplicitlySuppressedCompletionItems g + + let tyconRefOptEq tref1 tref2 = + match tref1 with + | Some tref1 -> tyconRefEq g tref1 tref2 + | None -> false + + // Adjust items priority. Sort by name. For things with the same name, + // - show types with fewer generic parameters first + // - show types before over other related items - they usually have very useful XmlDocs + let _, _, items = + items + |> List.map (fun x -> + match x.Item with + | Item.Types (_,(TType_app(tcref,_) :: _)) -> { x with MinorPriority = 1 + tcref.TyparsNoRange.Length } + // Put delegate ctors after types, sorted by #typars. RemoveDuplicateItems will remove FakeInterfaceCtor and DelegateCtor if an earlier type is also reported with this name + | Item.FakeInterfaceCtor (TType_app(tcref,_)) + | Item.DelegateCtor (TType_app(tcref,_)) -> { x with MinorPriority = 1000 + tcref.TyparsNoRange.Length } + // Put type ctors after types, sorted by #typars. RemoveDuplicateItems will remove DefaultStructCtors if a type is also reported with this name + | Item.CtorGroup (_, (cinfo :: _)) -> { x with MinorPriority = 1000 + 10 * (tcrefOfAppTy g cinfo.EnclosingType).TyparsNoRange.Length } + | Item.MethodGroup(_, minfo :: _, _) -> { x with IsOwnMember = tyconRefOptEq x.Type minfo.DeclaringEntityRef } + | Item.Property(_, pinfo :: _) -> { x with IsOwnMember = tyconRefOptEq x.Type (tcrefOfAppTy g pinfo.EnclosingType) } + | Item.ILField finfo -> { x with IsOwnMember = tyconRefOptEq x.Type (tcrefOfAppTy g finfo.EnclosingType) } + | _ -> x) + |> List.sortBy (fun x -> x.MinorPriority) + |> List.fold (fun (prevRealPrior, prevNormalizedPrior, acc) x -> + if x.MinorPriority = prevRealPrior then + prevRealPrior, prevNormalizedPrior, x :: acc + else + let normalizedPrior = prevNormalizedPrior + 1 + x.MinorPriority, normalizedPrior, { x with MinorPriority = normalizedPrior } :: acc + ) (0, 0, []) + + if verbose then dprintf "service.ml: mkDecls: %d found groups after filtering\n" (List.length items); + + // Group by full name for unresolved items and by display name for resolved ones. + let items = + items + |> List.rev + // Prefer items from file check results to ones from referenced assemblies via GetAssemblyContent ("all entities") + |> List.sortBy (fun x -> x.Unresolved.IsSome) + // Remove all duplicates. We've put the types first, so this removes the DelegateCtor and DefaultStructCtor's. + |> SymbolHelpers.RemoveDuplicateCompletionItems g + |> List.groupBy (fun x -> + match x.Unresolved with + | Some u -> + match u.Namespace with + | [||] -> u.DisplayName + | ns -> (ns |> String.concat ".") + "." + u.DisplayName + | None -> x.Item.DisplayName) + |> List.map (fun (_, items) -> + let item = items.Head + let name = + match item.Unresolved with + | Some u -> u.DisplayName + | None -> item.Item.DisplayName + name, items) + + // Filter out operators (and list) + let items = + // Check whether this item looks like an operator. + let isOperatorItem(name, items: CompletionItem list) = + match items |> List.map (fun x -> x.Item) with + | [Item.Value _ | Item.MethodGroup _ | Item.UnionCase _] -> IsOperatorName name + | _ -> false + let isFSharpList name = (name = "[]") // list shows up as a Type and a UnionCase, only such entity with a symbolic name, but want to filter out of intellisense + items |> List.filter (fun (displayName, items) -> not (isOperatorItem(displayName, items)) && not (isFSharpList displayName)) + + let decls = + items + |> List.map (fun (displayName, itemsWithSameFullName) -> + match itemsWithSameFullName with + | [] -> failwith "Unexpected empty bag" + | _ -> + let items = + match itemsWithSameFullName |> List.partition (fun x -> x.Unresolved.IsNone) with + | [], unresolved -> unresolved + // if there are resolvable items, throw out unresolved to prevent duplicates like `Set` and `FSharp.Collections.Set`. + | resolved, _ -> resolved + + let item = items.Head + let glyph = GlyphOfItem(denv, item.Item) + + let name, nameInCode = + if displayName.StartsWith "( " && displayName.EndsWith " )" then + let cleanName = displayName.[2..displayName.Length - 3] + cleanName, + if IsOperatorName displayName then cleanName else "``" + cleanName + "``" + else + displayName, + match item.Unresolved with + | Some _ -> displayName + | None -> Lexhelp.Keywords.QuoteIdentifierIfNeeded displayName + + let isAttribute = SymbolHelpers.IsAttribute infoReader item.Item + + let cutAttributeSuffix (name: string) = + if isAttributeApplicationContext && isAttribute && name <> "Attribute" && name.EndsWith "Attribute" then + name.[0..name.Length - "Attribute".Length - 1] + else name + + let name = cutAttributeSuffix name + let nameInCode = cutAttributeSuffix nameInCode + let fullName = SymbolHelpers.FullNameOfItem g item.Item + + let namespaceToOpen = + item.Unresolved + |> Option.map (fun x -> x.Namespace) + |> Option.bind (fun ns -> + if ns |> Array.startsWith [|"Microsoft"; "FSharp"|] then None + else Some ns) + |> Option.map (fun ns -> + match currentNamespaceOrModule with + | Some currentNs -> + if ns |> Array.startsWith currentNs then + ns.[currentNs.Length..] + else ns + | None -> ns) + |> Option.bind (function + | [||] -> None + | ns -> Some (ns |> String.concat ".")) + + FSharpDeclarationListItem( + name, nameInCode, fullName, glyph, Choice1Of2 (items, infoReader, m, denv, reactor, checkAlive), getAccessibility item.Item, + item.Kind, item.IsOwnMember, item.MinorPriority, item.Unresolved.IsNone, namespaceToOpen)) + + new FSharpDeclarationListInfo(Array.ofList decls, isForType, false) + + static member Error msg = + new FSharpDeclarationListInfo( + [| FSharpDeclarationListItem("", "", "", FSharpGlyph.Error, Choice2Of2 (FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError msg]), + None, CompletionItemKind.Other, false, 0, false, None) |], false, true) + + static member Empty = FSharpDeclarationListInfo([| |], false, false) + + + +/// A single method for Intellisense completion +[] +// Note: instances of this type do not hold any references to any compiler resources. +type FSharpMethodGroupItem(description: FSharpToolTipText, xmlDoc: FSharpXmlDoc, returnType: layout, parameters: FSharpMethodGroupItemParameter[], hasParameters: bool, hasParamArrayArg: bool, staticParameters: FSharpMethodGroupItemParameter[]) = + member __.StructuredDescription = description + member __.Description = Tooltips.ToFSharpToolTipText description + member __.XmlDoc = xmlDoc + member __.StructuredReturnTypeText = returnType + member __.ReturnTypeText = showL returnType + member __.Parameters = parameters + member __.HasParameters = hasParameters + member __.HasParamArrayArg = hasParamArrayArg + // Does the type name or method support a static arguments list, like TP<42,"foo"> or conn.CreateCommand<42, "foo">(arg1, arg2)? + member __.StaticParameters = staticParameters + + +/// A table of methods for Intellisense completion +// +// Note: this type does not hold any strong references to any compiler resources, nor does evaluating any of the properties execute any +// code on the compiler thread. +[] +type FSharpMethodGroup( name: string, unsortedMethods: FSharpMethodGroupItem[] ) = + // BUG 413009 : [ParameterInfo] takes about 3 seconds to move from one overload parameter to another + // cache allows to avoid recomputing parameterinfo for the same item +#if !FX_NO_WEAKTABLE + static let methodOverloadsCache = System.Runtime.CompilerServices.ConditionalWeakTable() +#endif + + let methods = + unsortedMethods + // Methods with zero arguments show up here as taking a single argument of type 'unit'. Patch them now to appear as having zero arguments. + |> Array.map (fun meth -> + let parms = meth.Parameters + if parms.Length = 1 && parms.[0].CanonicalTypeTextForSorting="Microsoft.FSharp.Core.Unit" then + FSharpMethodGroupItem(meth.StructuredDescription, meth.XmlDoc, meth.StructuredReturnTypeText, [||], true, meth.HasParamArrayArg, meth.StaticParameters) + else + meth) + // Fix the order of methods, to be stable for unit testing. + |> Array.sortBy (fun meth -> + let parms = meth.Parameters + parms.Length, (parms |> Array.map (fun p -> p.CanonicalTypeTextForSorting))) + + member __.MethodName = name + + member __.Methods = methods + + static member Create (infoReader: InfoReader, m, denv, items:ItemWithInst list) = + let g = infoReader.g + if isNil items then new FSharpMethodGroup("", [| |]) else + let name = items.Head.Item.DisplayName + + let methods = + [| for item in items do +#if !FX_NO_WEAKTABLE + match methodOverloadsCache.TryGetValue item with + | true, res -> yield! res + | false, _ -> +#endif + let flatItems = AnotherFlattenItems g m item.Item + + let methods = + flatItems |> Array.ofList |> Array.map (fun flatItem -> + let prettyParams, prettyRetTyL = + ErrorScope.Protect m + (fun () -> PrettyParamsAndReturnTypeOfItem infoReader m denv { item with Item = flatItem }) + (fun err -> [], wordL (tagText err)) + + let description = FSharpToolTipText [SymbolHelpers.FormatStructuredDescriptionOfItem true infoReader m denv { item with Item = flatItem }] + + let hasParamArrayArg = + match flatItem with + | Item.CtorGroup(_,[meth]) + | Item.MethodGroup(_,[meth],_) -> meth.HasParamArrayArg(infoReader.amap, m, meth.FormalMethodInst) + | _ -> false + + let hasStaticParameters = + match flatItem with + | SymbolHelpers.ItemIsProvidedTypeWithStaticArguments m g _ -> false + | _ -> true + + FSharpMethodGroupItem( + description = description, + returnType = prettyRetTyL, + xmlDoc = SymbolHelpers.GetXmlCommentForItem infoReader m flatItem, + parameters = (prettyParams |> Array.ofList), + hasParameters = hasStaticParameters, + hasParamArrayArg = hasParamArrayArg, + staticParameters = StaticParamsOfItem infoReader m denv flatItem + )) +#if !FX_NO_WEAKTABLE + methodOverloadsCache.Add(item, methods) +#endif + yield! methods + |] + + new FSharpMethodGroup(name, methods) + + + diff --git a/src/fsharp/vs/ServiceDeclarationLists.fsi b/src/fsharp/vs/ServiceDeclarationLists.fsi new file mode 100644 index 00000000000..33a05b442e5 --- /dev/null +++ b/src/fsharp/vs/ServiceDeclarationLists.fsi @@ -0,0 +1,149 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +//---------------------------------------------------------------------------- +// API for declaration lists and method overload lists + +namespace Microsoft.FSharp.Compiler.SourceCodeServices + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops + + +[] +/// Represents a declaration in F# source code, with information attached ready for display by an editor. +/// Returned by GetDeclarations. +// +// Note: this type holds a weak reference to compiler resources. +#if COMPILER_PUBLIC_API +type FSharpDeclarationListItem = +#else +type internal FSharpDeclarationListItem = +#endif + /// Get the display name for the declaration. + member Name : string + /// Get the name for the declaration as it's presented in source code. + member NameInCode : string + /// Get the description text for the declaration. Computing this property may require using compiler + /// resources and may trigger execution of a type provider method to retrieve documentation. + /// + /// May return "Loading..." if timeout occurs + member StructuredDescriptionText : FSharpStructuredToolTipText + member DescriptionText : FSharpToolTipText + + /// Get the description text, asynchronously. Never returns "Loading...". + member StructuredDescriptionTextAsync : Async + member DescriptionTextAsync : Async + member Glyph : FSharpGlyph + member Accessibility : FSharpAccessibility option + member Kind : CompletionItemKind + member IsOwnMember : bool + member MinorPriority : int + member FullName : string + member IsResolved : bool + member NamespaceToOpen : string option + + +[] +/// Represents a set of declarations in F# source code, with information attached ready for display by an editor. +/// Returned by GetDeclarations. +// +// Note: this type holds a weak reference to compiler resources. +#if COMPILER_PUBLIC_API +type FSharpDeclarationListInfo = +#else +type internal FSharpDeclarationListInfo = +#endif + member Items : FSharpDeclarationListItem[] + member IsForType : bool + member IsError : bool + + // Implementation details used by other code in the compiler + static member internal Create : infoReader:InfoReader * m:range * denv:DisplayEnv * getAccessibility:(Item -> FSharpAccessibility option) * items:CompletionItem list * reactor:IReactorOperations * currentNamespace:string[] option * isAttributeApplicationContex:bool * checkAlive:(unit -> bool) -> FSharpDeclarationListInfo + static member internal Error : message:string -> FSharpDeclarationListInfo + static member Empty : FSharpDeclarationListInfo + +/// Represents one parameter for one method (or other item) in a group. +[] +#if COMPILER_PUBLIC_API +type FSharpMethodGroupItemParameter = +#else +type internal FSharpMethodGroupItemParameter = +#endif + + /// The name of the parameter. + member ParameterName: string + + /// A key that can be used for sorting the parameters, used to help sort overloads. + member CanonicalTypeTextForSorting: string + + /// The structured representation for the parameter including its name, its type and visual indicators of other + /// information such as whether it is optional. + member StructuredDisplay: Layout + + /// The text to display for the parameter including its name, its type and visual indicators of other + /// information such as whether it is optional. + member Display: string + + /// Is the parameter optional + member IsOptional: bool + +/// Represents one method (or other item) in a method group. The item may represent either a method or +/// a single, non-overloaded item such as union case or a named function value. +[] +#if COMPILER_PUBLIC_API +type FSharpMethodGroupItem = +#else +type internal FSharpMethodGroupItem = +#endif + + /// The documentation for the item + member XmlDoc : FSharpXmlDoc + + /// The structured description representation for the method (or other item) + member StructuredDescription : FSharpStructuredToolTipText + + /// The formatted description text for the method (or other item) + member Description : FSharpToolTipText + + /// The The structured description representation for the method (or other item) + member StructuredReturnTypeText: Layout + + /// The formatted type text for the method (or other item) + member ReturnTypeText: string + + /// The parameters of the method in the overload set + member Parameters: FSharpMethodGroupItemParameter[] + + /// Does the method support an arguments list? This is always true except for static type instantiations like TP<42,"foo">. + member HasParameters: bool + + /// Does the method support a params list arg? + member HasParamArrayArg: bool + + /// Does the type name or method support a static arguments list, like TP<42,"foo"> or conn.CreateCommand<42, "foo">(arg1, arg2)? + member StaticParameters: FSharpMethodGroupItemParameter[] + +/// Represents a group of methods (or other items) returned by GetMethods. +[] +#if COMPILER_PUBLIC_API +type FSharpMethodGroup = +#else +type internal FSharpMethodGroup = +#endif + + internal new : string * FSharpMethodGroupItem[] -> FSharpMethodGroup + + /// The shared name of the methods (or other items) in the group + member MethodName: string + + /// The methods (or other items) in the group + member Methods: FSharpMethodGroupItem[] + + static member internal Create : InfoReader * range * DisplayEnv * ItemWithInst list -> FSharpMethodGroup + diff --git a/src/fsharp/vs/ServiceDeclarations.fsi b/src/fsharp/vs/ServiceDeclarations.fsi deleted file mode 100755 index 7e1a2d5c89b..00000000000 --- a/src/fsharp/vs/ServiceDeclarations.fsi +++ /dev/null @@ -1,267 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. - -//---------------------------------------------------------------------------- -// API to the compiler as an incremental service for parsing, -// type checking and intellisense-like environment-reporting. -//---------------------------------------------------------------------------- - -namespace Microsoft.FSharp.Compiler.SourceCodeServices - -open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.Range -open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.Infos -open Microsoft.FSharp.Compiler.NameResolution -open Microsoft.FSharp.Compiler.InfoReader -open Microsoft.FSharp.Compiler.Tast -open Microsoft.FSharp.Compiler.Tastops - -/// Describe a comment as either a block of text or a file+signature reference into an intellidoc file. -// -// Note: instances of this type do not hold any references to any compiler resources. -[] -type internal FSharpXmlDoc = - /// No documentation is available - | None - - /// The text for documentation - | Text of string - - /// Indicates that the text for the documentation can be found in a .xml documentation file, using the given signature key - | XmlDocFileSignature of (*File:*) string * (*Signature:*)string - -type internal Layout = Internal.Utilities.StructuredFormat.Layout - -/// A single data tip display element -[] -type FSharpToolTipElementData<'T> = - { MainDescription: 'T - XmlDoc: FSharpXmlDoc - /// typar insantiation text, to go after xml - TypeMapping: 'T list - /// Extra text, goes at the end - Remarks: 'T option - /// Parameter name - ParamName : string option } - -/// A single tool tip display element -// -// Note: instances of this type do not hold any references to any compiler resources. -[] -type internal FSharpToolTipElement<'T> = - | None - - /// A single type, method, etc with comment. May represent a method overload group. - | Group of FSharpToolTipElementData<'T> list - - /// An error occurred formatting this element - | CompositionError of string - static member Single : 'T * FSharpXmlDoc * ?typeMapping: 'T list * ?paramName: string * ?remarks : 'T -> FSharpToolTipElement<'T> - -/// A single data tip display element with where text is expressed as string -type FSharpToolTipElement = FSharpToolTipElement - -/// A single data tip display element with where text is expressed as -type internal FSharpStructuredToolTipElement = FSharpToolTipElement - -/// Information for building a tool tip box. -// -// Note: instances of this type do not hold any references to any compiler resources. -type internal FSharpToolTipText<'T> = - /// A list of data tip elements to display. - | FSharpToolTipText of FSharpToolTipElement<'T> list - -type FSharpToolTipText = FSharpToolTipText -type internal FSharpStructuredToolTipText = FSharpToolTipText - -module internal Tooltips = - val ToFSharpToolTipElement: FSharpStructuredToolTipElement -> FSharpToolTipElement - val ToFSharpToolTipText: FSharpStructuredToolTipText -> FSharpToolTipText - val Map: f: ('T1 -> 'T2) -> a: Async<'T1> -> Async<'T2> - -[] -type internal CompletionItemKind = - | Field - | Property - | Method of isExtension : bool - | Event - | Argument - | Other - -/// Indicates the accessibility of a symbol, as seen by the F# language -and [] internal FSharpAccessibility = - new: Accessibility * ?isProtected: bool -> FSharpAccessibility - - /// Indicates the symbol has public accessibility - member IsPublic : bool - - /// Indicates the symbol has private accessibility - member IsPrivate : bool - - /// Indicates the symbol has internal accessibility - member IsInternal : bool - - /// The underlying Accessibility - member Contents : Accessibility - -[] -/// Represents a declaration in F# source code, with information attached ready for display by an editor. -/// Returned by GetDeclarations. -// -// Note: this type holds a weak reference to compiler resources. -type internal FSharpDeclarationListItem = - /// Get the display name for the declaration. - member Name : string - /// Get the name for the declaration as it's presented in source code. - member NameInCode : string - /// Get the description text for the declaration. Computing this property may require using compiler - /// resources and may trigger execution of a type provider method to retrieve documentation. - /// - /// May return "Loading..." if timeout occurs - member StructuredDescriptionText : FSharpStructuredToolTipText - member DescriptionText : FSharpToolTipText - - /// Get the description text, asynchronously. Never returns "Loading...". - member StructuredDescriptionTextAsync : Async - member DescriptionTextAsync : Async - member Glyph : FSharpGlyph - member Accessibility : FSharpAccessibility option - member Kind : CompletionItemKind - member IsOwnMember : bool - member MinorPriority : int - member FullName : string - member IsResolved : bool - member NamespaceToOpen : string option - -type UnresolvedSymbol = - { DisplayName: string - Namespace: string[] } - -type internal CompletionItem = - { ItemWithInst: ItemWithInst - Kind: CompletionItemKind - IsOwnMember: bool - MinorPriority: int - Type: TyconRef option - Unresolved: UnresolvedSymbol option } - member Item : Item - -[] -/// Represents a set of declarations in F# source code, with information attached ready for display by an editor. -/// Returned by GetDeclarations. -// -// Note: this type holds a weak reference to compiler resources. -type internal FSharpDeclarationListInfo = - member Items : FSharpDeclarationListItem[] - member IsForType : bool - member IsError : bool - - // Implementation details used by other code in the compiler - static member internal Create : infoReader:InfoReader * m:range * denv:DisplayEnv * getAccessibility:(Item -> FSharpAccessibility option) * items:CompletionItem list * reactor:IReactorOperations * currentNamespace:string[] option * isAttributeApplicationContex:bool * checkAlive:(unit -> bool) -> FSharpDeclarationListInfo - static member internal Error : message:string -> FSharpDeclarationListInfo - static member Empty : FSharpDeclarationListInfo - -/// Represents one parameter for one method (or other item) in a group. -[] -type internal FSharpMethodGroupItemParameter = - - /// The name of the parameter. - member ParameterName: string - - /// A key that can be used for sorting the parameters, used to help sort overloads. - member CanonicalTypeTextForSorting: string - - /// The structured representation for the parameter including its name, its type and visual indicators of other - /// information such as whether it is optional. - member StructuredDisplay: Layout - - /// The text to display for the parameter including its name, its type and visual indicators of other - /// information such as whether it is optional. - member Display: string - - /// Is the parameter optional - member IsOptional: bool - -/// Represents one method (or other item) in a method group. The item may represent either a method or -/// a single, non-overloaded item such as union case or a named function value. -[] -type internal FSharpMethodGroupItem = - - /// The documentation for the item - member XmlDoc : FSharpXmlDoc - - /// The structured description representation for the method (or other item) - member StructuredDescription : FSharpStructuredToolTipText - - /// The formatted description text for the method (or other item) - member Description : FSharpToolTipText - - /// The The structured description representation for the method (or other item) - member StructuredReturnTypeText: Layout - - /// The formatted type text for the method (or other item) - member ReturnTypeText: string - - /// The parameters of the method in the overload set - member Parameters: FSharpMethodGroupItemParameter[] - - /// Does the method support an arguments list? This is always true except for static type instantiations like TP<42,"foo">. - member HasParameters: bool - - /// Does the method support a params list arg? - member HasParamArrayArg: bool - - /// Does the type name or method support a static arguments list, like TP<42,"foo"> or conn.CreateCommand<42, "foo">(arg1, arg2)? - member StaticParameters: FSharpMethodGroupItemParameter[] - -/// Represents a group of methods (or other items) returned by GetMethods. -[] -type internal FSharpMethodGroup = - - internal new : string * FSharpMethodGroupItem[] -> FSharpMethodGroup - - /// The shared name of the methods (or other items) in the group - member MethodName: string - - /// The methods (or other items) in the group - member Methods: FSharpMethodGroupItem[] - - static member internal Create : InfoReader * range * DisplayEnv * ItemWithInst list -> FSharpMethodGroup - -// implementation details used by other code in the compiler -module internal ItemDescriptionsImpl = - val isFunction : TcGlobals -> TType -> bool - val ParamNameAndTypesOfUnaryCustomOperation : TcGlobals -> MethInfo -> ParamNameAndType list - - val GetXmlDocSigOfEntityRef : InfoReader -> range -> EntityRef -> (string option * string) option - val GetXmlDocSigOfScopedValRef : TcGlobals -> TyconRef -> ValRef -> (string option * string) option - val GetXmlDocSigOfILFieldInfo : InfoReader -> range -> ILFieldInfo -> (string option * string) option - val GetXmlDocSigOfRecdFieldInfo : RecdFieldInfo -> (string option * string) option - val GetXmlDocSigOfUnionCaseInfo : UnionCaseInfo -> (string option * string) option - val GetXmlDocSigOfMethInfo : InfoReader -> range -> MethInfo -> (string option * string) option - val GetXmlDocSigOfValRef : TcGlobals -> ValRef -> (string option * string) option - val GetXmlDocSigOfProp : InfoReader -> range -> PropInfo -> (string option * string) option - val GetXmlDocSigOfEvent : InfoReader -> range -> EventInfo -> (string option * string) option - val GetXmlCommentForItem : InfoReader -> range -> Item -> FSharpXmlDoc - val FormatStructuredDescriptionOfItem : isDecl:bool -> InfoReader -> range -> DisplayEnv -> ItemWithInst -> FSharpStructuredToolTipElement - val RemoveDuplicateItems : TcGlobals -> ItemWithInst list -> ItemWithInst list - val RemoveExplicitlySuppressed : TcGlobals -> ItemWithInst list -> ItemWithInst list - val RemoveDuplicateCompletionItems : TcGlobals -> CompletionItem list -> CompletionItem list - val RemoveExplicitlySuppressedCompletionItems : TcGlobals -> CompletionItem list -> CompletionItem list - val GetF1Keyword : TcGlobals -> Item -> string option - val rangeOfItem : TcGlobals -> bool option -> Item -> range option - val fileNameOfItem : TcGlobals -> string option -> range -> Item -> string - val FullNameOfItem : TcGlobals -> Item -> string - val ccuOfItem : TcGlobals -> Item -> CcuThunk option - val mutable ToolTipFault : string option - val GlyphOfItem : DisplayEnv * Item -> FSharpGlyph - val IsAttribute : InfoReader -> Item -> bool - val IsExplicitlySuppressed : TcGlobals -> Item -> bool - val FlattenItems : TcGlobals -> range -> Item -> Item list - val (|ItemIsProvidedType|_|) : TcGlobals -> Item -> TyconRef option - -module EnvMisc2 = - val maxMembers : int - /// dataTipSpinWaitTime limits how long we block the UI thread while a tooltip pops up next to a selected item in an IntelliSense completion list. - /// This time appears to be somewhat amortized by the time it takes the VS completion UI to actually bring up the tooltip after selecting an item in the first place. - val dataTipSpinWaitTime : int \ No newline at end of file diff --git a/src/fsharp/vs/ServiceLexing.fs b/src/fsharp/vs/ServiceLexing.fs index c92b48ec16c..1f21194099c 100755 --- a/src/fsharp/vs/ServiceLexing.fs +++ b/src/fsharp/vs/ServiceLexing.fs @@ -751,3 +751,10 @@ type FSharpSourceTokenizer(defineConstants : string list, filename : Option] -type internal FSharpLineTokenizer = +type FSharpLineTokenizer = /// Scan one token from the line member ScanToken : lexState:FSharpTokenizerLexState -> FSharpTokenInfo option * FSharpTokenizerLexState static member ColorStateOfLexState : FSharpTokenizerLexState -> FSharpTokenizerColorState @@ -206,13 +206,21 @@ type internal FSharpLineTokenizer = /// Tokenizer for a source file. Holds some expensive-to-compute resources at the scope of the file. [] -type internal FSharpSourceTokenizer = - new : conditionalDefines:string list * fileName:Option -> FSharpSourceTokenizer +type FSharpSourceTokenizer = + new : conditionalDefines:string list * fileName:string option -> FSharpSourceTokenizer member CreateLineTokenizer : lineText:string -> FSharpLineTokenizer member CreateBufferTokenizer : bufferFiller:(char[] * int * int -> int) -> FSharpLineTokenizer module internal TestExpose = - val TokenInfo : Parser.token -> (FSharpTokenColorKind * FSharpTokenCharKind * FSharpTokenTriggerClass) + val TokenInfo : Parser.token -> (FSharpTokenColorKind * FSharpTokenCharKind * FSharpTokenTriggerClass) +module Keywords = + /// Add backticks if the identifier is a keyword. + val QuoteIdentifierIfNeeded : string -> string + /// Remove backticks if present. + val NormalizeIdentifierBackticks : string -> string + + /// Keywords paired with their descriptions. Used in completion and quick info. + val KeywordsWithDescription : (string * string) list diff --git a/src/fsharp/vs/ServiceNavigation.fs b/src/fsharp/vs/ServiceNavigation.fs index 9dc1ba073f0..0dec86c4fe5 100755 --- a/src/fsharp/vs/ServiceNavigation.fs +++ b/src/fsharp/vs/ServiceNavigation.fs @@ -23,10 +23,21 @@ type FSharpNavigationDeclarationItemKind = | FieldDecl | OtherDecl +[] +type FSharpEnclosingEntityKind = + | Namespace + | Module + | Class + | Exception + | Interface + | Record + | Enum + | DU + /// Represents an item to be displayed in the navigation bar [] type FSharpNavigationDeclarationItem(uniqueName: string, name: string, kind: FSharpNavigationDeclarationItemKind, glyph: FSharpGlyph, range: range, - bodyRange: range, singleTopLevel: bool, access: SynAccess option) = + bodyRange: range, singleTopLevel: bool, enclosingEntityKind: FSharpEnclosingEntityKind, isAbstract: bool, access: SynAccess option) = member x.bodyRange = bodyRange member x.UniqueName = uniqueName @@ -36,13 +47,15 @@ type FSharpNavigationDeclarationItem(uniqueName: string, name: string, kind: FSh member x.Range = range member x.BodyRange = bodyRange member x.IsSingleTopLevel = singleTopLevel + member x.EnclosingEntityKind = enclosingEntityKind + member x.IsAbstract = isAbstract + member x.Access = access member x.WithUniqueName(uniqueName: string) = - FSharpNavigationDeclarationItem(uniqueName, name, kind, glyph, range, bodyRange, singleTopLevel, access) - - static member Create(name: string, kind, glyph: FSharpGlyph, range: range, bodyRange: range, singleTopLevel: bool, access: SynAccess option) = - FSharpNavigationDeclarationItem("", name, kind, glyph, range, bodyRange, singleTopLevel, access) + FSharpNavigationDeclarationItem(uniqueName, name, kind, glyph, range, bodyRange, singleTopLevel, enclosingEntityKind, isAbstract, access) + static member Create(name: string, kind, glyph: FSharpGlyph, range: range, bodyRange: range, singleTopLevel: bool, enclosingEntityKind, isAbstract, access: SynAccess option) = + FSharpNavigationDeclarationItem("", name, kind, glyph, range, bodyRange, singleTopLevel, enclosingEntityKind, isAbstract, access) /// Represents top-level declarations (that should be in the type drop-down) /// with nested declarations (that can be shown in the member drop-down) @@ -94,25 +107,25 @@ module NavigationImpl = sprintf "%s_%d_of_%d" name idx total // Create declaration (for the left dropdown) - let createDeclLid(baseName, lid, kind, baseGlyph, m, bodym, nested, access) = + let createDeclLid(baseName, lid, kind, baseGlyph, m, bodym, nested, enclosingEntityKind, isAbstract, access) = let name = (if baseName <> "" then baseName + "." else "") + (textOfLid lid) FSharpNavigationDeclarationItem.Create - (name, kind, baseGlyph, m, bodym, false, access), (addItemName name), nested + (name, kind, baseGlyph, m, bodym, false, enclosingEntityKind, isAbstract, access), (addItemName name), nested - let createDecl(baseName, id:Ident, kind, baseGlyph, m, bodym, nested, access) = + let createDecl(baseName, id:Ident, kind, baseGlyph, m, bodym, nested, enclosingEntityKind, isAbstract, access) = let name = (if baseName <> "" then baseName + "." else "") + (id.idText) FSharpNavigationDeclarationItem.Create - (name, kind, baseGlyph, m, bodym, false, access), (addItemName name), nested + (name, kind, baseGlyph, m, bodym, false, enclosingEntityKind, isAbstract, access), (addItemName name), nested // Create member-kind-of-thing for the right dropdown - let createMemberLid(lid, kind, baseGlyph, m, access) = - FSharpNavigationDeclarationItem.Create(textOfLid lid, kind, baseGlyph, m, m, false, access), (addItemName(textOfLid lid)) + let createMemberLid(lid, kind, baseGlyph, m, enclosingEntityKind, isAbstract, access) = + FSharpNavigationDeclarationItem.Create(textOfLid lid, kind, baseGlyph, m, m, false, enclosingEntityKind, isAbstract, access), (addItemName(textOfLid lid)) - let createMember(id:Ident, kind, baseGlyph, m, access) = - FSharpNavigationDeclarationItem.Create(id.idText, kind, baseGlyph, m, m, false, access), (addItemName(id.idText)) + let createMember(id:Ident, kind, baseGlyph, m, enclosingEntityKind, isAbstract, access) = + FSharpNavigationDeclarationItem.Create(id.idText, kind, baseGlyph, m, m, false, enclosingEntityKind, isAbstract, access), (addItemName(id.idText)) // Process let-binding - let processBinding isMember (Binding(_, _, _, _, _, _, SynValData(memebrOpt, _, _), synPat, _, synExpr, _, _)) = + let processBinding isMember enclosingEntityKind isAbstract (Binding(_, _, _, _, _, _, SynValData(memebrOpt, _, _), synPat, _, synExpr, _, _)) = let m = match synExpr with | SynExpr.Typed(e, _, _) -> e.Range // fix range for properties with type annotations @@ -134,57 +147,57 @@ module NavigationImpl = | _thisVar::nm::_ -> (List.tail lid, nm.idRange) | hd::_ -> (lid, hd.idRange) | _ -> (lid, m) - [ createMemberLid(lidShow, kind, icon, unionRanges rangeMerge m, access) ] + [ createMemberLid(lidShow, kind, icon, unionRanges rangeMerge m, enclosingEntityKind, isAbstract, access) ] | SynPat.LongIdent(LongIdentWithDots(lid,_), _, _, _, access, _), _ -> - [ createMemberLid(lid, FieldDecl, FSharpGlyph.Field, unionRanges (List.head lid).idRange m, access) ] + [ createMemberLid(lid, FieldDecl, FSharpGlyph.Field, unionRanges (List.head lid).idRange m, enclosingEntityKind, isAbstract, access) ] | SynPat.Named(_, id, _, access, _), _ -> let glyph = if isMember then FSharpGlyph.Method else FSharpGlyph.Field - [ createMember(id, FieldDecl, glyph, unionRanges id.idRange m, access) ] + [ createMember(id, FieldDecl, glyph, unionRanges id.idRange m, enclosingEntityKind, isAbstract, access) ] | _ -> [] // Process a class declaration or F# type declaration let rec processExnDefnRepr baseName nested (SynExceptionDefnRepr(_, (UnionCase(_, id, fldspec, _, _, _)), _, _, access, m)) = // Exception declaration - [ createDecl(baseName, id, ExnDecl, FSharpGlyph.Exception, m, fldspecRange fldspec, nested, access) ] + [ createDecl(baseName, id, ExnDecl, FSharpGlyph.Exception, m, fldspecRange fldspec, nested, FSharpEnclosingEntityKind.Exception, false, access) ] // Process a class declaration or F# type declaration and processExnDefn baseName (SynExceptionDefn(repr, membDefns, _)) = - let nested = processMembers membDefns |> snd + let nested = processMembers membDefns FSharpEnclosingEntityKind.Exception |> snd processExnDefnRepr baseName nested repr and processTycon baseName (TypeDefn(ComponentInfo(_, _, _, lid, _, _, access, _), repr, membDefns, m)) = - let topMembers = processMembers membDefns |> snd + let topMembers = processMembers membDefns FSharpEnclosingEntityKind.Class |> snd match repr with | SynTypeDefnRepr.Exception repr -> processExnDefnRepr baseName [] repr | SynTypeDefnRepr.ObjectModel(_, membDefns, mb) -> // F# class declaration - let members = processMembers membDefns |> snd + let members = processMembers membDefns FSharpEnclosingEntityKind.Class |> snd let nested = members@topMembers - ([ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Class, m, bodyRange mb nested, nested, access) ]: ((FSharpNavigationDeclarationItem * int * _) list)) + ([ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Class, m, bodyRange mb nested, nested, FSharpEnclosingEntityKind.Class, false, access) ]: ((FSharpNavigationDeclarationItem * int * _) list)) | SynTypeDefnRepr.Simple(simple, _) -> // F# type declaration match simple with | SynTypeDefnSimpleRepr.Union(_, cases, mb) -> let cases = [ for (UnionCase(_, id, fldspec, _, _, _)) in cases -> - createMember(id, OtherDecl, FSharpGlyph.Struct, unionRanges (fldspecRange fldspec) id.idRange, access) ] + createMember(id, OtherDecl, FSharpGlyph.Struct, unionRanges (fldspecRange fldspec) id.idRange, FSharpEnclosingEntityKind.DU, false, access) ] let nested = cases@topMembers - [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Union, m, bodyRange mb nested, nested, access) ] + [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Union, m, bodyRange mb nested, nested, FSharpEnclosingEntityKind.DU, false, access) ] | SynTypeDefnSimpleRepr.Enum(cases, mb) -> let cases = [ for (EnumCase(_, id, _, _, m)) in cases -> - createMember(id, FieldDecl, FSharpGlyph.EnumMember, m, access) ] + createMember(id, FieldDecl, FSharpGlyph.EnumMember, m, FSharpEnclosingEntityKind.Enum, false, access) ] let nested = cases@topMembers - [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Enum, m, bodyRange mb nested, nested, access) ] + [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Enum, m, bodyRange mb nested, nested, FSharpEnclosingEntityKind.Enum, false, access) ] | SynTypeDefnSimpleRepr.Record(_, fields, mb) -> let fields = [ for (Field(_, _, id, _, _, _, _, m)) in fields do if (id.IsSome) then - yield createMember(id.Value, FieldDecl, FSharpGlyph.Field, m, access) ] + yield createMember(id.Value, FieldDecl, FSharpGlyph.Field, m, FSharpEnclosingEntityKind.Record, false, access) ] let nested = fields@topMembers - [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Type, m, bodyRange mb nested, nested, access) ] + [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Type, m, bodyRange mb nested, nested, FSharpEnclosingEntityKind.Record, false, access) ] | SynTypeDefnSimpleRepr.TypeAbbrev(_, _, mb) -> - [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Typedef, m, bodyRange mb topMembers, topMembers, access) ] + [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Typedef, m, bodyRange mb topMembers, topMembers, FSharpEnclosingEntityKind.Class, false, access) ] //| SynTypeDefnSimpleRepr.General of TyconKind * (SynType * range * ident option) list * (valSpfn * MemberFlags) list * fieldDecls * bool * bool * range //| SynTypeDefnSimpleRepr.LibraryOnlyILAssembly of ILType * range @@ -192,7 +205,7 @@ module NavigationImpl = | _ -> [] // Returns class-members for the right dropdown - and processMembers members: (range * list) = + and processMembers members enclosingEntityKind : (range * list) = let members = members |> List.groupBy (fun x -> x.Range) @@ -201,17 +214,17 @@ module NavigationImpl = (match members with | [memb] -> match memb with - | SynMemberDefn.LetBindings(binds, _, _, _) -> List.collect (processBinding false) binds - | SynMemberDefn.Member(bind, _) -> processBinding true bind + | SynMemberDefn.LetBindings(binds, _, _, _) -> List.collect (processBinding false enclosingEntityKind false) binds + | SynMemberDefn.Member(bind, _) -> processBinding true enclosingEntityKind false bind | SynMemberDefn.ValField(Field(_, _, Some(rcid), ty, _, _, access, _), _) -> - [ createMember(rcid, FieldDecl, FSharpGlyph.Field, ty.Range, access) ] + [ createMember(rcid, FieldDecl, FSharpGlyph.Field, ty.Range, enclosingEntityKind, false, access) ] | SynMemberDefn.AutoProperty(_attribs,_isStatic,id,_tyOpt,_propKind,_,_xmlDoc, access,_synExpr, _, _) -> - [ createMember(id, FieldDecl, FSharpGlyph.Field, id.idRange, access) ] + [ createMember(id, FieldDecl, FSharpGlyph.Field, id.idRange, enclosingEntityKind, false, access) ] | SynMemberDefn.AbstractSlot(ValSpfn(_, id, _, ty, _, _, _, _, access, _, _), _, _) -> - [ createMember(id, MethodDecl, FSharpGlyph.OverridenMethod, ty.Range, access) ] + [ createMember(id, MethodDecl, FSharpGlyph.OverridenMethod, ty.Range, enclosingEntityKind, true, access) ] | SynMemberDefn.NestedType _ -> failwith "tycon as member????" //processTycon tycon | SynMemberDefn.Interface(_, Some(membs), _) -> - processMembers membs |> snd + processMembers membs enclosingEntityKind |> snd | _ -> [] // can happen if one is a getter and one is a setter | [SynMemberDefn.Member(memberDefn=Binding(headPat=SynPat.LongIdent(lid1, Some(info1),_,_,_,_)) as binding1) @@ -222,8 +235,8 @@ module NavigationImpl = assert((info1.idText = "set" && info2.idText = "get") || (info2.idText = "set" && info1.idText = "get")) // both binding1 and binding2 have same range, so just try the first one, else try the second one - match processBinding true binding1 with - | [] -> processBinding true binding2 + match processBinding true enclosingEntityKind false binding1 with + | [] -> processBinding true enclosingEntityKind false binding2 | x -> x | _ -> [])) @@ -232,14 +245,14 @@ module NavigationImpl = // Process declarations in a module that belong to the right drop-down (let bindings) let processNestedDeclarations decls = decls |> List.collect (function - | SynModuleDecl.Let(_, binds, _) -> List.collect (processBinding false) binds + | SynModuleDecl.Let(_, binds, _) -> List.collect (processBinding false FSharpEnclosingEntityKind.Module false) binds | _ -> []) // Process declarations nested in a module that should be displayed in the left dropdown // (such as type declarations, nested modules etc.) let rec processFSharpNavigationTopLevelDeclarations(baseName, decls) = decls |> List.collect (function | SynModuleDecl.ModuleAbbrev(id, lid, m) -> - [ createDecl(baseName, id, ModuleDecl, FSharpGlyph.Module, m, rangeOfLid lid, [], None) ] + [ createDecl(baseName, id, ModuleDecl, FSharpGlyph.Module, m, rangeOfLid lid, [], FSharpEnclosingEntityKind.Namespace, false, None) ] | SynModuleDecl.NestedModule(ComponentInfo(_, _, _, lid, _, _, access, _), _isRec, decls, _, m) -> // Find let bindings (for the right dropdown) @@ -248,7 +261,7 @@ module NavigationImpl = // Get nested modules and types (for the left dropdown) let other = processFSharpNavigationTopLevelDeclarations(newBaseName, decls) - createDeclLid(baseName, lid, ModuleDecl, FSharpGlyph.Module, m, unionRangesChecked (rangeOfDecls nested) (moduleRange (rangeOfLid lid) other), nested, access) :: other + createDeclLid(baseName, lid, ModuleDecl, FSharpGlyph.Module, m, unionRangesChecked (rangeOfDecls nested) (moduleRange (rangeOfLid lid) other), nested, FSharpEnclosingEntityKind.Module, false, access) :: other | SynModuleDecl.Types(tydefs, _) -> tydefs |> List.collect (processTycon baseName) | SynModuleDecl.Exception (defn,_) -> processExnDefn baseName defn @@ -274,7 +287,7 @@ module NavigationImpl = (textOfLid id, (if isModule then ModuleFileDecl else NamespaceDecl), FSharpGlyph.Module, m, unionRangesChecked (rangeOfDecls nested) (moduleRange (rangeOfLid id) other), - singleTopLevel, access), (addItemName(textOfLid id)), nested + singleTopLevel, FSharpEnclosingEntityKind.Module, false, access), (addItemName(textOfLid id)), nested decl::other) let items = @@ -300,22 +313,22 @@ module NavigationImpl = sprintf "%s_%d_of_%d" name idx total // Create declaration (for the left dropdown) - let createDeclLid(baseName, lid, kind, baseGlyph, m, bodym, nested, access) = + let createDeclLid(baseName, lid, kind, baseGlyph, m, bodym, nested, enclosingEntityKind, isAbstract, access) = let name = (if baseName <> "" then baseName + "." else "") + (textOfLid lid) FSharpNavigationDeclarationItem.Create - (name, kind, baseGlyph, m, bodym, false, access), (addItemName name), nested + (name, kind, baseGlyph, m, bodym, false, enclosingEntityKind, isAbstract, access), (addItemName name), nested - let createDecl(baseName, id:Ident, kind, baseGlyph, m, bodym, nested, access) = + let createDecl(baseName, id:Ident, kind, baseGlyph, m, bodym, nested, enclosingEntityKind, isAbstract, access) = let name = (if baseName <> "" then baseName + "." else "") + (id.idText) FSharpNavigationDeclarationItem.Create - (name, kind, baseGlyph, m, bodym, false, access), (addItemName name), nested + (name, kind, baseGlyph, m, bodym, false, enclosingEntityKind, isAbstract, access), (addItemName name), nested - let createMember(id:Ident, kind, baseGlyph, m, access) = - FSharpNavigationDeclarationItem.Create(id.idText, kind, baseGlyph, m, m, false, access), (addItemName(id.idText)) + let createMember(id:Ident, kind, baseGlyph, m, enclosingEntityKind, isAbstract, access) = + FSharpNavigationDeclarationItem.Create(id.idText, kind, baseGlyph, m, m, false, enclosingEntityKind, isAbstract, access), (addItemName(id.idText)) let rec processExnRepr baseName nested (SynExceptionDefnRepr(_, (UnionCase(_, id, fldspec, _, _, _)), _, _, access, m)) = // Exception declaration - [ createDecl(baseName, id, ExnDecl, FSharpGlyph.Exception, m, fldspecRange fldspec, nested, access) ] + [ createDecl(baseName, id, ExnDecl, FSharpGlyph.Exception, m, fldspecRange fldspec, nested, FSharpEnclosingEntityKind.Exception, false, access) ] and processExnSig baseName (SynExceptionSig(repr, memberSigs, _)) = let nested = processSigMembers memberSigs @@ -329,31 +342,31 @@ module NavigationImpl = // F# class declaration let members = processSigMembers membDefns let nested = members @ topMembers - ([ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Class, m, bodyRange mb nested, nested, access) ]: ((FSharpNavigationDeclarationItem * int * _) list)) + ([ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Class, m, bodyRange mb nested, nested, FSharpEnclosingEntityKind.Class, false, access) ]: ((FSharpNavigationDeclarationItem * int * _) list)) | SynTypeDefnSigRepr.Simple(simple, _) -> // F# type declaration match simple with | SynTypeDefnSimpleRepr.Union(_, cases, mb) -> let cases = [ for (UnionCase(_, id, fldspec, _, _, _)) in cases -> - createMember(id, OtherDecl, FSharpGlyph.Struct, unionRanges (fldspecRange fldspec) id.idRange, access) ] + createMember(id, OtherDecl, FSharpGlyph.Struct, unionRanges (fldspecRange fldspec) id.idRange, FSharpEnclosingEntityKind.DU, false, access) ] let nested = cases@topMembers - [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Union, m, bodyRange mb nested, nested, access) ] + [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Union, m, bodyRange mb nested, nested, FSharpEnclosingEntityKind.DU, false, access) ] | SynTypeDefnSimpleRepr.Enum(cases, mb) -> let cases = [ for (EnumCase(_, id, _, _, m)) in cases -> - createMember(id, FieldDecl, FSharpGlyph.EnumMember, m, access) ] + createMember(id, FieldDecl, FSharpGlyph.EnumMember, m, FSharpEnclosingEntityKind.Enum, false, access) ] let nested = cases@topMembers - [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Enum, m, bodyRange mb nested, nested, access) ] + [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Enum, m, bodyRange mb nested, nested, FSharpEnclosingEntityKind.Enum, false, access) ] | SynTypeDefnSimpleRepr.Record(_, fields, mb) -> let fields = [ for (Field(_, _, id, _, _, _, _, m)) in fields do if (id.IsSome) then - yield createMember(id.Value, FieldDecl, FSharpGlyph.Field, m, access) ] + yield createMember(id.Value, FieldDecl, FSharpGlyph.Field, m, FSharpEnclosingEntityKind.Record, false, access) ] let nested = fields@topMembers - [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Type, m, bodyRange mb nested, nested, access) ] + [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Type, m, bodyRange mb nested, nested, FSharpEnclosingEntityKind.Record, false, access) ] | SynTypeDefnSimpleRepr.TypeAbbrev(_, _, mb) -> - [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Typedef, m, bodyRange mb topMembers, topMembers, access) ] + [ createDeclLid(baseName, lid, TypeDecl, FSharpGlyph.Typedef, m, bodyRange mb topMembers, topMembers, FSharpEnclosingEntityKind.Class, false, access) ] //| SynTypeDefnSimpleRepr.General of TyconKind * (SynType * range * ident option) list * (valSpfn * MemberFlags) list * fieldDecls * bool * bool * range //| SynTypeDefnSimpleRepr.LibraryOnlyILAssembly of ILType * range @@ -364,22 +377,22 @@ module NavigationImpl = [ for memb in members do match memb with | SynMemberSig.Member(SynValSig.ValSpfn(_, id, _, _, _, _, _, _, access, _, m), _, _) -> - yield createMember(id, MethodDecl, FSharpGlyph.Method, m, access) + yield createMember(id, MethodDecl, FSharpGlyph.Method, m, FSharpEnclosingEntityKind.Class, false, access) | SynMemberSig.ValField(Field(_, _, Some(rcid), ty, _, _, access, _), _) -> - yield createMember(rcid, FieldDecl, FSharpGlyph.Field, ty.Range, access) + yield createMember(rcid, FieldDecl, FSharpGlyph.Field, ty.Range, FSharpEnclosingEntityKind.Class, false, access) | _ -> () ] // Process declarations in a module that belong to the right drop-down (let bindings) let processNestedSigDeclarations decls = decls |> List.collect (function | SynModuleSigDecl.Val(SynValSig.ValSpfn(_, id, _, _, _, _, _, _, access, _, m), _) -> - [ createMember(id, MethodDecl, FSharpGlyph.Method, m, access) ] + [ createMember(id, MethodDecl, FSharpGlyph.Method, m, FSharpEnclosingEntityKind.Module, false, access) ] | _ -> [] ) // Process declarations nested in a module that should be displayed in the left dropdown // (such as type declarations, nested modules etc.) let rec processFSharpNavigationTopLevelSigDeclarations(baseName, decls) = decls |> List.collect (function | SynModuleSigDecl.ModuleAbbrev(id, lid, m) -> - [ createDecl(baseName, id, ModuleDecl, FSharpGlyph.Module, m, rangeOfLid lid, [], None) ] + [ createDecl(baseName, id, ModuleDecl, FSharpGlyph.Module, m, rangeOfLid lid, [], FSharpEnclosingEntityKind.Module, false, None) ] | SynModuleSigDecl.NestedModule(ComponentInfo(_, _, _, lid, _, _, access, _), _, decls, m) -> // Find let bindings (for the right dropdown) @@ -388,7 +401,7 @@ module NavigationImpl = // Get nested modules and types (for the left dropdown) let other = processFSharpNavigationTopLevelSigDeclarations(newBaseName, decls) - createDeclLid(baseName, lid, ModuleDecl, FSharpGlyph.Module, m, unionRangesChecked (rangeOfDecls nested) (moduleRange (rangeOfLid lid) other), nested, access)::other + createDeclLid(baseName, lid, ModuleDecl, FSharpGlyph.Module, m, unionRangesChecked (rangeOfDecls nested) (moduleRange (rangeOfLid lid) other), nested, FSharpEnclosingEntityKind.Module, false, access)::other | SynModuleSigDecl.Types(tydefs, _) -> tydefs |> List.collect (processTycon baseName) | SynModuleSigDecl.Exception (defn,_) -> processExnSig baseName defn @@ -411,7 +424,7 @@ module NavigationImpl = (textOfLid id, (if isModule then ModuleFileDecl else NamespaceDecl), FSharpGlyph.Module, m, unionRangesChecked (rangeOfDecls nested) (moduleRange (rangeOfLid id) other), - singleTopLevel, access), (addItemName(textOfLid id)), nested + singleTopLevel, FSharpEnclosingEntityKind.Module, false, access), (addItemName(textOfLid id)), nested decl::other) let items = @@ -420,6 +433,8 @@ module NavigationImpl = |> Array.map (fun (d, idx, nest) -> let nest = nest |> Array.ofList |> Array.map (fun (decl, idx) -> decl.WithUniqueName(uniqueName d.Name idx)) nest |> Array.sortInPlaceWith (fun a b -> compare a.Name b.Name) + let nest = nest |> Array.distinctBy (fun x -> x.Range, x.BodyRange, x.Name, x.Kind) + { Declaration = d.WithUniqueName(uniqueName d.Name idx); Nested = nest } ) items |> Array.sortInPlaceWith (fun a b -> compare a.Declaration.Name b.Declaration.Name) new FSharpNavigationItems(items) @@ -713,4 +728,5 @@ module NavigateTo = | ParsedInput.SigFile input -> walkSigFileInput input | ParsedInput.ImplFile input -> walkImplFileInpit input - result.ToArray() \ No newline at end of file + result.ToArray() + diff --git a/src/fsharp/vs/ServiceNavigation.fsi b/src/fsharp/vs/ServiceNavigation.fsi index 3766d381a1d..4b17f7f97a0 100755 --- a/src/fsharp/vs/ServiceNavigation.fsi +++ b/src/fsharp/vs/ServiceNavigation.fsi @@ -10,7 +10,11 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices open Microsoft.FSharp.Compiler /// Indicates a kind of item to show in an F# navigation bar +#if COMPILER_PUBLIC_API +type FSharpNavigationDeclarationItemKind = +#else type internal FSharpNavigationDeclarationItemKind = +#endif | NamespaceDecl | ModuleFileDecl | ExnDecl @@ -21,9 +25,28 @@ type internal FSharpNavigationDeclarationItemKind = | FieldDecl | OtherDecl +[] +#if COMPILER_PUBLIC_API +type FSharpEnclosingEntityKind = +#else +type internal FSharpEnclosingEntityKind = +#endif + | Namespace + | Module + | Class + | Exception + | Interface + | Record + | Enum + | DU + /// Represents an item to be displayed in the navigation bar [] +#if COMPILER_PUBLIC_API +type FSharpNavigationDeclarationItem = +#else type internal FSharpNavigationDeclarationItem = +#endif member Name : string member UniqueName : string member Glyph : FSharpGlyph @@ -31,12 +54,18 @@ type internal FSharpNavigationDeclarationItem = member Range : Range.range member BodyRange : Range.range member IsSingleTopLevel : bool + member EnclosingEntityKind: FSharpEnclosingEntityKind + member IsAbstract: bool member Access : Ast.SynAccess option /// Represents top-level declarations (that should be in the type drop-down) /// with nested declarations (that can be shown in the member drop-down) [] +#if COMPILER_PUBLIC_API +type FSharpNavigationTopLevelDeclaration = +#else type internal FSharpNavigationTopLevelDeclaration = +#endif { Declaration : FSharpNavigationDeclarationItem Nested : FSharpNavigationDeclarationItem[] } @@ -44,7 +73,11 @@ type internal FSharpNavigationTopLevelDeclaration = /// all the members and currently selected indices. First level correspond to /// types & modules and second level are methods etc. [] +#if COMPILER_PUBLIC_API +type FSharpNavigationItems = +#else type internal FSharpNavigationItems = +#endif member Declarations : FSharpNavigationTopLevelDeclaration[] // implementation details used by other code in the compiler @@ -54,9 +87,13 @@ module internal NavigationImpl = val internal getNavigation : Ast.ParsedInput -> FSharpNavigationItems val internal empty : FSharpNavigationItems +#if COMPILER_PUBLIC_API +module NavigateTo = +#else module internal NavigateTo = +#endif [] - type internal NavigableItemKind = + type NavigableItemKind = | Module | ModuleAbbreviation | Exception @@ -70,22 +107,22 @@ module internal NavigateTo = | UnionCase [] - type internal ContainerType = + type ContainerType = | File | Namespace | Module | Type | Exception - type internal Container = + type Container = { Type: ContainerType Name: string } - type internal NavigableItem = + type NavigableItem = { Name: string Range: Range.range IsSignature: bool Kind: NavigableItemKind Container: Container } - val internal getNavigableItems : Ast.ParsedInput -> NavigableItem [] + val getNavigableItems : Ast.ParsedInput -> NavigableItem [] diff --git a/src/fsharp/vs/ServiceParamInfoLocations.fsi b/src/fsharp/vs/ServiceParamInfoLocations.fsi index b4cdef33f9c..ee33ddd39c0 100755 --- a/src/fsharp/vs/ServiceParamInfoLocations.fsi +++ b/src/fsharp/vs/ServiceParamInfoLocations.fsi @@ -11,7 +11,11 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range [] +#if COMPILER_PUBLIC_API +type FSharpNoteworthyParamInfoLocations = +#else type internal FSharpNoteworthyParamInfoLocations = +#endif member LongId : string list member LongIdStartLocation : pos member LongIdEndLocation : pos diff --git a/src/fsharp/vs/ServiceParseTreeWalk.fs b/src/fsharp/vs/ServiceParseTreeWalk.fs index 60a8891de27..796b5ed088e 100755 --- a/src/fsharp/vs/ServiceParseTreeWalk.fs +++ b/src/fsharp/vs/ServiceParseTreeWalk.fs @@ -13,7 +13,11 @@ open Microsoft.FSharp.Compiler.Ast /// A range of utility functions to assist with traversing an AST +#if COMPILER_PUBLIC_API +module AstTraversal = +#else module internal AstTraversal = +#endif // treat ranges as though they are half-open: [,) let rangeContainsPosLeftEdgeInclusive (m1:range) p = if posEq m1.Start m1.End then @@ -143,7 +147,7 @@ module internal AstTraversal = /// traverse an implementation file walking all the way down to SynExpr or TypeAbbrev at a particular location /// - let (*internal*) Traverse(pos:pos, parseTree, visitor:AstVisitorBase<'T>) = + let Traverse(pos:pos, parseTree, visitor:AstVisitorBase<'T>) = let pick x = pick pos x let rec traverseSynModuleDecl path (decl:SynModuleDecl) = let pick = pick decl.Range @@ -575,4 +579,4 @@ module internal AstTraversal = range0 // only used for asserting, does not matter in non-debug #endif l |> List.map (fun x -> dive x x.Range (traverseSynModuleOrNamespace [])) |> pick fileRange l - | ParsedInput.SigFile _sigFile -> None \ No newline at end of file + | ParsedInput.SigFile _sigFile -> None diff --git a/src/fsharp/vs/ServiceUntypedParse.fs b/src/fsharp/vs/ServiceUntypedParse.fs index ee4dab1a2f0..3cf2fc34725 100755 --- a/src/fsharp/vs/ServiceUntypedParse.fs +++ b/src/fsharp/vs/ServiceUntypedParse.fs @@ -20,7 +20,7 @@ open Microsoft.FSharp.Compiler.CompileOps open Microsoft.FSharp.Compiler.Lib /// Methods for dealing with F# sources files. -module internal SourceFile = +module SourceFile = /// Source file extensions let private compilableExtensions = CompileOps.FSharpSigFileSuffixes @ CompileOps.FSharpImplFileSuffixes @ CompileOps.FSharpScriptFileSuffixes /// Single file projects extensions @@ -34,7 +34,7 @@ module internal SourceFile = let ext = Path.GetExtension(file) singleFileProjectExtensions |> List.exists(fun e-> 0 = String.Compare(e,ext,StringComparison.OrdinalIgnoreCase)) -module internal SourceFileImpl = +module SourceFileImpl = let IsInterfaceFile file = let ext = Path.GetExtension(file) 0 = String.Compare(".fsi",ext,StringComparison.OrdinalIgnoreCase) @@ -1189,6 +1189,7 @@ module UntypedParseImpl = match parseLid lidwd with | Some (completionPath) -> GetCompletionContextForInheritSynMember (componentInfo, typeDefnKind, completionPath) | None -> Some (CompletionContext.Invalid) // A $ .B -> no completion list + | _ -> None member __.VisitBinding(defaultTraverse, (Binding(headPat = headPat) as synBinding)) = @@ -1227,7 +1228,7 @@ module UntypedParseImpl = member __.VisitModuleOrNamespace(SynModuleOrNamespace(longId = idents)) = match List.tryLast idents with - | Some lastIdent when pos.Line = lastIdent.idRange.EndLine -> + | Some lastIdent when pos.Line = lastIdent.idRange.EndLine && lastIdent.idRange.EndColumn >= 0 && pos.Column <= lineStr.Length -> let stringBetweenModuleNameAndPos = lineStr.[lastIdent.idRange.EndColumn..pos.Column - 1] if stringBetweenModuleNameAndPos |> Seq.forall (fun x -> x = ' ' || x = '.') then Some CompletionContext.Invalid @@ -1284,4 +1285,4 @@ module UntypedParseImpl = None // we should traverse the rest of the AST to find the smallest module } AstTraversal.Traverse(pos, parsedInput, visitor) |> ignore - path |> List.map (fun x -> x.idText) |> List.toArray \ No newline at end of file + path |> List.map (fun x -> x.idText) |> List.toArray diff --git a/src/fsharp/vs/ServiceUntypedParse.fsi b/src/fsharp/vs/ServiceUntypedParse.fsi index 05b266c2a84..f8331c6c7d8 100755 --- a/src/fsharp/vs/ServiceUntypedParse.fsi +++ b/src/fsharp/vs/ServiceUntypedParse.fsi @@ -15,7 +15,11 @@ open Microsoft.FSharp.Compiler.ErrorLogger [] /// Represents the results of parsing an F# file +#if COMPILER_PUBLIC_API +type FSharpParseFileResults = +#else type internal FSharpParseFileResults = +#endif /// The syntax tree resulting from the parse member ParseTree : Ast.ParsedInput option @@ -44,7 +48,11 @@ type internal FSharpParseFileResults = internal new : errors : FSharpErrorInfo[] * input : Ast.ParsedInput option * parseHadErrors : bool * dependencyFiles : string list -> FSharpParseFileResults /// Information about F# source file names +#if COMPILER_PUBLIC_API +module SourceFile = +#else module internal SourceFile = +#endif /// Whether or not this file is compilable val IsCompilable : string -> bool @@ -52,22 +60,38 @@ module internal SourceFile = /// Whether or not this file should be a single-file project val MustBeSingleFileProject : string -> bool +#if COMPILER_PUBLIC_API +type CompletionPath = string list * string option // plid * residue +#else type internal CompletionPath = string list * string option // plid * residue +#endif [] +#if COMPILER_PUBLIC_API +type InheritanceContext = +#else type internal InheritanceContext = +#endif | Class | Interface | Unknown [] +#if COMPILER_PUBLIC_API +type RecordContext = +#else type internal RecordContext = +#endif | CopyOnUpdate of range * CompletionPath // range | Constructor of string // typename | New of CompletionPath [] +#if COMPILER_PUBLIC_API +type CompletionContext = +#else type internal CompletionContext = +#endif // completion context cannot be determined due to errors | Invalid // completing something after the inherit keyword @@ -81,17 +105,29 @@ type internal CompletionContext = | AttributeApplication | OpenDeclaration +#if COMPILER_PUBLIC_API +type ModuleKind = { IsAutoOpen: bool; HasModuleSuffix: bool } +#else type internal ModuleKind = { IsAutoOpen: bool; HasModuleSuffix: bool } +#endif [] +#if COMPILER_PUBLIC_API +type EntityKind = +#else type internal EntityKind = +#endif | Attribute | Type | FunctionOrValue of isActivePattern:bool | Module of ModuleKind // implementation details used by other code in the compiler +#if COMPILER_PUBLIC_API +module UntypedParseImpl = +#else module internal UntypedParseImpl = +#endif val TryFindExpressionASTLeftOfDotLeftOfCursor : pos * ParsedInput option -> (pos * bool) option val GetRangeOfExprLeftOfDot : pos * ParsedInput option -> range option val TryFindExpressionIslandInPosition : pos * ParsedInput option -> string option diff --git a/src/fsharp/vs/ServiceXmlDocParser.fs b/src/fsharp/vs/ServiceXmlDocParser.fs index bb21924e319..2e910a8e7a6 100644 --- a/src/fsharp/vs/ServiceXmlDocParser.fs +++ b/src/fsharp/vs/ServiceXmlDocParser.fs @@ -5,10 +5,10 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library /// Represent an Xml documentation block in source code -type internal XmlDocable = +type XmlDocable = | XmlDocable of line:int * indent:int * paramNames:string list -module internal XmlDocParsing = +module XmlDocParsing = open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast @@ -159,7 +159,7 @@ module internal XmlDocParsing = // Should not fail here, just in case [] -module internal XmlDocComment = +module XmlDocComment = let private ws (s: string, pos) = let res = s.TrimStart() Some (res, pos + (s.Length - res.Length)) @@ -184,7 +184,7 @@ module internal XmlDocComment = let res = parser (s.TrimEnd(), 0) |> Option.map snd |> Option.map (fun x -> x - 1) res -module internal XmlDocParser = +module XmlDocParser = /// Get the list of Xml documentation from current source code let getXmlDocables (sourceCodeOfTheFile, input) = let sourceCodeLinesOfTheFile = String.getLines sourceCodeOfTheFile diff --git a/src/fsharp/vs/ServiceXmlDocParser.fsi b/src/fsharp/vs/ServiceXmlDocParser.fsi index 3946634df08..5509a7d3f9f 100644 --- a/src/fsharp/vs/ServiceXmlDocParser.fsi +++ b/src/fsharp/vs/ServiceXmlDocParser.fsi @@ -7,15 +7,27 @@ open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast /// Represent an Xml documentation block in source code +#if COMPILER_PUBLIC_API +type XmlDocable = +#else type internal XmlDocable = +#endif | XmlDocable of line:int * indent:int * paramNames:string list +#if COMPILER_PUBLIC_API +module XmlDocComment = +#else module internal XmlDocComment = +#endif /// if it's a blank XML comment with trailing "<", returns Some (index of the "<"), otherwise returns None val isBlank : string -> int option +#if COMPILER_PUBLIC_API +module XmlDocParser = +#else module internal XmlDocParser = +#endif /// Get the list of Xml documentation from current source code val getXmlDocables : sourceCodeOfTheFile : string * input : Ast.ParsedInput option -> XmlDocable list \ No newline at end of file diff --git a/src/fsharp/vs/service.fs b/src/fsharp/vs/service.fs index d3f8406fd09..88af76c591a 100644 --- a/src/fsharp/vs/service.fs +++ b/src/fsharp/vs/service.fs @@ -22,6 +22,7 @@ open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.Driver open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.PrettyNaming @@ -36,7 +37,7 @@ open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.TypeChecker -open Microsoft.FSharp.Compiler.SourceCodeServices.ItemDescriptionsImpl +open Microsoft.FSharp.Compiler.SourceCodeServices.SymbolHelpers open Internal.Utilities open Internal.Utilities.Collections @@ -71,7 +72,7 @@ module EnvMisc = //-------------------------------------------------------------------------- [] -type (*internal*) FSharpFindDeclFailureReason = +type FSharpFindDeclFailureReason = // generic reason: no particular information about error | Unknown // source code file is not available @@ -113,28 +114,6 @@ type GetPreciseCompletionListFromExprTypingsResult = type Names = string list -[] -type FSharpSymbolUse(g:TcGlobals, denv: DisplayEnv, symbol:FSharpSymbol, itemOcc, range: range) = - member __.Symbol = symbol - member __.DisplayContext = FSharpDisplayContext(fun _ -> denv) - member x.IsDefinition = x.IsFromDefinition - member __.IsFromDefinition = (match itemOcc with ItemOccurence.Binding -> true | _ -> false) - member __.IsFromPattern = (match itemOcc with ItemOccurence.Pattern -> true | _ -> false) - member __.IsFromType = (match itemOcc with ItemOccurence.UseInType -> true | _ -> false) - member __.IsFromAttribute = (match itemOcc with ItemOccurence.UseInAttribute -> true | _ -> false) - member __.IsFromDispatchSlotImplementation = (match itemOcc with ItemOccurence.Implemented -> true | _ -> false) - member __.IsFromComputationExpression = - match symbol.Item, itemOcc with - // 'seq' in 'seq { ... }' gets colored as keywords - | (Item.Value vref), ItemOccurence.Use when valRefEq g g.seq_vref vref -> true - // custom builders, custom operations get colored as keywords - | (Item.CustomBuilder _ | Item.CustomOperation _), ItemOccurence.Use -> true - | _ -> false - - member __.FileName = range.FileName - member __.Range = Range.toZ range - member __.RangeAlternate = range - [] type SemanticClassificationType = | ReferenceType @@ -898,6 +877,10 @@ type TypeCheckInfo | Item.Types _ | Item.ModuleOrNamespaces _ -> true | _ -> false + member __.GetVisibleNamespacesAndModulesAtPosition(cursorPos: pos) : ModuleOrNamespaceRef list = + let (nenv, ad), m = GetBestEnvForPos cursorPos + NameResolution.GetVisibleNamespacesAndModulesAtPoint ncenv nenv m ad + member __.IsRelativeNameResolvable(cursorPos: pos, plid: string list, item: Item) : bool = /// Determines if a long ident is resolvable at a specific point. ErrorScope.Protect @@ -1097,7 +1080,7 @@ type TypeCheckInfo match GetDeclItemsForNamesAtPosition (ctok, None,Some(names), None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.No,(fun() -> []),fun _ -> false) with | None | Some ([],_,_,_) -> None | Some (items, denv, _, m) -> - let allItems = items |> List.collect (fun item -> ItemDescriptionsImpl.FlattenItems g m item.Item) + let allItems = items |> List.collect (fun item -> SymbolHelpers.FlattenItems g m item.Item) let symbols = allItems |> List.map (fun item -> FSharpSymbol.Create(g, thisCcu, tcImports, item)) Some (symbols, denv, m) @@ -1123,7 +1106,7 @@ type TypeCheckInfo let fail defaultReason = match item with #if EXTENSIONTYPING - | ItemDescriptionsImpl.ItemIsProvidedType g (tcref) -> FSharpFindDeclResult.DeclNotFound (FSharpFindDeclFailureReason.ProvidedType(tcref.DisplayName)) + | SymbolHelpers.ItemIsProvidedType g (tcref) -> FSharpFindDeclResult.DeclNotFound (FSharpFindDeclFailureReason.ProvidedType(tcref.DisplayName)) | Item.CtorGroup(name, ProvidedMeth(_)::_) | Item.MethodGroup(name, ProvidedMeth(_)::_, _) | Item.Property(name, ProvidedProp(_)::_) -> FSharpFindDeclResult.DeclNotFound (FSharpFindDeclFailureReason.ProvidedMember(name)) @@ -1158,9 +1141,9 @@ type TypeCheckInfo [ for x in tcImports.GetImportedAssemblies() do yield FSharpAssembly(g, tcImports, x.FSharpViewOfMetadata) ] - // Not, this does not have to be a SyncOp, it can be called from any thread - member __.GetFormatSpecifierLocations() = - sSymbolUses.GetFormatSpecifierLocations() + // Note, this does not have to be a SyncOp, it can be called from any thread + member __.GetFormatSpecifierLocationsAndArity() = + sSymbolUses.GetFormatSpecifierLocationsAndArity() // Not, this does not have to be a SyncOp, it can be called from any thread member __.GetSemanticClassification(range: range option) : (range * SemanticClassificationType) [] = @@ -1265,7 +1248,7 @@ type TypeCheckInfo Some (m, SemanticClassificationType.UnionCase) | _ -> None) |> Seq.toArray - |> Array.append (sSymbolUses.GetFormatSpecifierLocations() |> Array.map (fun m -> m, SemanticClassificationType.Printf)) + |> Array.append (sSymbolUses.GetFormatSpecifierLocationsAndArity() |> Array.map (fun m -> fst m, SemanticClassificationType.Printf)) member __.ScopeResolutions = sResolutions member __.ScopeSymbolUses = sSymbolUses @@ -1284,27 +1267,6 @@ module internal Parser = let lastLineLength = source.Length - source.LastIndexOf("\n",StringComparison.Ordinal) - 1 lastLine, lastLineLength - let ReportError (tcConfig:TcConfig, allErrors, mainInputFileName, fileInfo, (exn, sev)) = - [ let isError = (sev = FSharpErrorSeverity.Error) || ReportWarningAsError (tcConfig.globalWarnLevel, tcConfig.specificWarnOff, tcConfig.specificWarnOn, tcConfig.specificWarnAsError, tcConfig.specificWarnAsWarn, tcConfig.globalWarnAsError) exn - if (isError || ReportWarning (tcConfig.globalWarnLevel, tcConfig.specificWarnOff, tcConfig.specificWarnOn) exn) then - let oneError trim exn = - [ // We use the first line of the file as a fallbackRange for reporting unexpected errors. - // Not ideal, but it's hard to see what else to do. - let fallbackRange = rangeN mainInputFileName 1 - let ei = FSharpErrorInfo.CreateFromExceptionAndAdjustEof (exn, isError, trim, fallbackRange, fileInfo) - if allErrors || (ei.FileName=mainInputFileName) || (ei.FileName=Microsoft.FSharp.Compiler.TcGlobals.DummyFileNameForRangesWithoutASpecificLocation) then - yield ei ] - - let mainError,relatedErrors = SplitRelatedDiagnostics exn - yield! oneError false mainError - for e in relatedErrors do - yield! oneError true e ] - - let CreateErrorInfos (tcConfig:TcConfig, allErrors, mainInputFileName, errors) = - let fileInfo = (Int32.MaxValue, Int32.MaxValue) - [| for (exn,isError) in errors do - yield! ReportError (tcConfig, allErrors, mainInputFileName, fileInfo, (exn, isError)) |] - /// Error handler for parsing & type checking while processing a single file type ErrorHandler(reportErrors, mainInputFileName, tcConfig: TcConfig, source: string) = @@ -1327,7 +1289,7 @@ module internal Parser = else exn if reportErrors then let report exn = - for ei in ReportError (tcConfig, false, mainInputFileName, fileInfo, (exn, sev)) do + for ei in ErrorHelpers.ReportError (tcConfig, false, mainInputFileName, fileInfo, (exn, sev)) do errorsAndWarningsCollector.Add ei if sev = FSharpErrorSeverity.Error then errorCount <- errorCount + 1 @@ -1369,7 +1331,8 @@ module internal Parser = // Initialize the error handler let errHandler = new ErrorHandler(reportErrors, mainInputFileName, tcConfig, source) - let source = source + "\n\n\n" + // Adding this new-line character at the end of the source seems odd but is required for some unit tests + let source = if source.Length = 0 || not (source.[source.Length - 1] = '\n') then source + "\n" else source let lexbuf = UnicodeLexing.StringAsLexbuf source // Collector for parens matching @@ -1676,7 +1639,7 @@ type FSharpProjectContext(thisCcu: CcuThunk, assemblies: FSharpAssembly list, ad [] // 'details' is an option because the creation of the tcGlobals etc. for the project may have failed. -type FSharpCheckProjectResults(_keepAssemblyContents, errors: FSharpErrorInfo[], details:(TcGlobals*TcImports*CcuThunk*ModuleOrNamespaceType*TcSymbolUses list*TopAttribs option*CompileOps.IRawFSharpAssemblyData option * ILAssemblyRef * AccessorDomain * TypedImplFile list option) option, reactorOps: IReactorOperations) = +type FSharpCheckProjectResults(keepAssemblyContents, errors: FSharpErrorInfo[], details:(TcGlobals*TcImports*CcuThunk*ModuleOrNamespaceType*TcSymbolUses list*TopAttribs option*CompileOps.IRawFSharpAssemblyData option * ILAssemblyRef * AccessorDomain * TypedImplFile list option * string list) option, reactorOps: IReactorOperations) = let getDetails() = match details with @@ -1688,21 +1651,21 @@ type FSharpCheckProjectResults(_keepAssemblyContents, errors: FSharpErrorInfo[], member info.HasCriticalErrors = details.IsNone member info.AssemblySignature = - let (tcGlobals, tcImports, thisCcu, ccuSig, _tcSymbolUses, topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr) = getDetails() + let (tcGlobals, tcImports, thisCcu, ccuSig, _tcSymbolUses, topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() FSharpAssemblySignature(tcGlobals, thisCcu, tcImports, topAttribs, ccuSig) - // member info.AssemblyContents = - // if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to tru on the FSharpChecker in order to access the checked contents of assemblies" - // let (tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, tcAssemblyExpr) = getDetails() - // let mimpls = - // match tcAssemblyExpr with - // | None -> [] - // | Some mimpls -> mimpls - // FSharpAssemblyContents(tcGlobals, thisCcu, tcImports, mimpls) + member info.AssemblyContents = + if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to tru on the FSharpChecker in order to access the checked contents of assemblies" + let (tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, tcAssemblyExpr, _dependencyFiles) = getDetails() + let mimpls = + match tcAssemblyExpr with + | None -> [] + | Some mimpls -> mimpls + FSharpAssemblyContents(tcGlobals, thisCcu, tcImports, mimpls) // Not, this does not have to be a SyncOp, it can be called from any thread member info.GetUsesOfSymbol(symbol:FSharpSymbol) = - let (tcGlobals, _tcImports, _thisCcu, _ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr) = getDetails() + let (tcGlobals, _tcImports, _thisCcu, _ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() // This probably doesn't need to be run on the reactor since all data touched by GetUsesOfSymbol is immutable. reactorOps.EnqueueAndAwaitOpAsync("GetUsesOfSymbol", fun ctok -> DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok @@ -1716,7 +1679,7 @@ type FSharpCheckProjectResults(_keepAssemblyContents, errors: FSharpErrorInfo[], // Not, this does not have to be a SyncOp, it can be called from any thread member info.GetAllUsesOfAllSymbols() = - let (tcGlobals, tcImports, thisCcu, _ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr) = getDetails() + let (tcGlobals, tcImports, thisCcu, _ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() // This probably doesn't need to be run on the reactor since all data touched by GetAllUsesOfSymbols is immutable. reactorOps.EnqueueAndAwaitOpAsync("GetAllUsesOfAllSymbols", fun ctok -> DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok @@ -1729,18 +1692,22 @@ type FSharpCheckProjectResults(_keepAssemblyContents, errors: FSharpErrorInfo[], |> cancellable.Return) member info.ProjectContext = - let (tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, ad, _tcAssemblyExpr) = getDetails() + let (tcGlobals, tcImports, thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() let assemblies = [ for x in tcImports.GetImportedAssemblies() do yield FSharpAssembly(tcGlobals, tcImports, x.FSharpViewOfMetadata) ] FSharpProjectContext(thisCcu, assemblies, ad) member info.RawFSharpAssemblyData = - let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr) = getDetails() + let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() tcAssemblyData + member info.DependencyFiles = + let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, dependencyFiles) = getDetails() + dependencyFiles + member info.AssemblyFullName = - let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, ilAssemRef, _ad, _tcAssemblyExpr) = getDetails() + let (_tcGlobals, _tcImports, _thisCcu, _ccuSig, _tcSymbolUses, _topAttribs, _tcAssemblyData, ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() ilAssemRef.QualifiedName [] @@ -1748,7 +1715,7 @@ type FSharpCheckProjectResults(_keepAssemblyContents, errors: FSharpErrorInfo[], // // There is an important property of all the objects returned by the methods of this type: they do not require // the corresponding background builder to be alive. That is, they are simply plain-old-data through pre-formatting of all result text. -type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo option, builderX: IncrementalBuilder option, reactorOpsX:IReactorOperations) = +type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo option, dependencyFiles: string list, builderX: IncrementalBuilder option, reactorOpsX:IReactorOperations) = // This may be None initially, or may be set to None when the object is disposed or finalized let mutable details = match scopeOptX with None -> None | Some scopeX -> Some (scopeX, builderX, reactorOpsX) @@ -1867,11 +1834,14 @@ type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo |> Option.map (fun (sym,_,_) -> sym)) member info.GetFormatSpecifierLocations() = + info.GetFormatSpecifierLocationsAndArity() |> Array.map fst + + member info.GetFormatSpecifierLocationsAndArity() = threadSafeOp (fun () -> [| |]) (fun (scope, _builder, _reactor) -> - // This operation is not asynchronous - GetFormatSpecifierLocations can be run on the calling thread - scope.GetFormatSpecifierLocations()) + // This operation is not asynchronous - GetFormatSpecifierLocationsAndArity can be run on the calling thread + scope.GetFormatSpecifierLocationsAndArity()) member info.GetSemanticClassification(range: range option) = threadSafeOp @@ -1894,6 +1864,8 @@ type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo // This operation is not asynchronous - GetReferencedAssemblies can be run on the calling thread FSharpProjectContext(scope.ThisCcu, scope.GetReferencedAssemblies(), scope.AccessRights)) + member info.DependencyFiles = dependencyFiles + member info.GetAllUsesOfAllSymbolsInFile() = reactorOp "GetAllUsesOfAllSymbolsInFile" [| |] (fun ctok scope -> @@ -1913,11 +1885,15 @@ type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo if itemOcc <> ItemOccurence.RelatedText then yield FSharpSymbolUse(scope.TcGlobals, denv, symbol, itemOcc, m) |]) + member info.GetVisibleNamespacesAndModulesAtPoint(pos: pos) : Async = + reactorOp "GetVisibleNamespacesAndModulesAtPoint" [| |] (fun _ctok scope -> scope.GetVisibleNamespacesAndModulesAtPosition(pos) |> List.toArray) + member info.IsRelativeNameResolvable(pos: pos, plid: string list, item: Item) : Async = reactorOp "IsRelativeNameResolvable" true (fun ctok scope -> DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok scope.IsRelativeNameResolvable(pos, plid, item)) + //---------------------------------------------------------------------------- // BackgroundCompiler // @@ -1930,7 +1906,7 @@ type FSharpCheckFileAnswer = /// Callback that indicates whether a requested result has become obsolete. [] -type (*internal*) IsResultObsolete = +type IsResultObsolete = | IsResultObsolete of (unit->bool) @@ -1964,6 +1940,114 @@ module Helpers = (fileName1 = fileName2) && FSharpProjectOptions.AreSubsumable(o1,o2) +module CompileHelpers = + let mkCompilationErorHandlers() = + let errors = ResizeArray<_>() + + let errorSink isError exn = + let mainError,relatedErrors = SplitRelatedDiagnostics exn + let oneError trim e = errors.Add(FSharpErrorInfo.CreateFromException (e, isError, trim, Range.range0)) + oneError false mainError + List.iter (oneError true) relatedErrors + + let errorLogger = + { new ErrorLogger("CompileAPI") with + member x.DiagnosticSink(exn, isError) = errorSink isError exn + member x.ErrorCount = errors |> Seq.filter (fun e -> e.Severity = FSharpErrorSeverity.Error) |> Seq.length } + + let loggerProvider = + { new ErrorLoggerProvider() with + member x.CreateErrorLoggerUpToMaxErrors(_tcConfigBuilder, _exiter) = errorLogger } + errors, errorLogger, loggerProvider + + let tryCompile errorLogger f = + use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + use unwindEL_2 = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger) + let exiter = { new Exiter with member x.Exit n = raise StopProcessing } + try + f exiter + 0 + with e -> + stopProcessingRecovery e Range.range0 + 1 + + /// Compile using the given flags. Source files names are resolved via the FileSystem API. The output file must be given by a -o flag. + let compileFromArgs (ctok, argv: string[], referenceResolver, tcImportsCapture, dynamicAssemblyCreator) = + + let errors, errorLogger, loggerProvider = mkCompilationErorHandlers() + let result = + tryCompile errorLogger (fun exiter -> + mainCompile (ctok, argv, referenceResolver, (*bannerAlreadyPrinted*)true, (*openBinariesInMemory*)true, exiter, loggerProvider, tcImportsCapture, dynamicAssemblyCreator) ) + + errors.ToArray(), result + + let compileFromAsts (ctok, referenceResolver, asts, assemblyName, outFile, dependencies, noframework, pdbFile, executable, tcImportsCapture, dynamicAssemblyCreator) = + + let errors, errorLogger, loggerProvider = mkCompilationErorHandlers() + + let executable = defaultArg executable true + let target = if executable then CompilerTarget.ConsoleExe else CompilerTarget.Dll + + let result = + tryCompile errorLogger (fun exiter -> + compileOfAst (ctok, referenceResolver, (*openBinariesInMemory=*)true, assemblyName, target, outFile, pdbFile, dependencies, noframework, exiter, loggerProvider, asts, tcImportsCapture, dynamicAssemblyCreator)) + + errors.ToArray(), result + + let createDynamicAssembly (ctok, debugInfo: bool, tcImportsRef: TcImports option ref, execute: bool, assemblyBuilderRef: _ option ref) (tcGlobals:TcGlobals, outfile, ilxMainModule) = + + // Create an assembly builder + let assemblyName = System.Reflection.AssemblyName(System.IO.Path.GetFileNameWithoutExtension outfile) + let flags = System.Reflection.Emit.AssemblyBuilderAccess.Run +#if FX_NO_APP_DOMAINS + let assemblyBuilder = System.Reflection.Emit.AssemblyBuilder.DefineDynamicAssembly(assemblyName, flags) + let moduleBuilder = assemblyBuilder.DefineDynamicModule("IncrementalModule") +#else + let assemblyBuilder = AppDomain.CurrentDomain.DefineDynamicAssembly(assemblyName, flags) + let moduleBuilder = assemblyBuilder.DefineDynamicModule("IncrementalModule", debugInfo) +#endif + // Omit resources in dynamic assemblies, because the module builder is constructed without a filename the module + // is tagged as transient and as such DefineManifestResource will throw an invalid operation if resources are present. + // + // Also, the dynamic assembly creator can't currently handle types called "" from statically linked assemblies. + let ilxMainModule = + { ilxMainModule with + TypeDefs = ilxMainModule.TypeDefs.AsList |> List.filter (fun td -> not (isTypeNameForGlobalFunctions td.Name)) |> mkILTypeDefs + Resources=mkILResources [] } + + // The function used to resolve typees while emitting the code + let assemblyResolver s = + match tcImportsRef.Value.Value.TryFindExistingFullyQualifiedPathByExactAssemblyRef (ctok, s) with + | Some res -> Some (Choice1Of2 res) + | None -> None + + // Emit the code + let _emEnv,execs = ILRuntimeWriter.emitModuleFragment(tcGlobals.ilg, ILRuntimeWriter.emEnv0, assemblyBuilder, moduleBuilder, ilxMainModule, debugInfo, assemblyResolver, tcGlobals.TryFindSysILTypeRef) + + // Execute the top-level initialization, if requested + if execute then + for exec in execs do + match exec() with + | None -> () + | Some exn -> raise exn + + // Register the reflected definitions for the dynamically generated assembly + for resource in ilxMainModule.Resources.AsList do + if IsReflectedDefinitionsResource resource then + Quotations.Expr.RegisterReflectedDefinitions(assemblyBuilder, moduleBuilder.Name, resource.Bytes) + + // Save the result + assemblyBuilderRef := Some assemblyBuilder + + let setOutputStreams execute = + // Set the output streams, if requested + match execute with + | Some (writer,error) -> + System.Console.SetOut writer + System.Console.SetError error + | None -> () + + type FileName = string type Source = string type FilePath = string @@ -2057,8 +2141,8 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent (keepStrongly=projectCacheSize, keepMax=projectCacheSize, areSame = FSharpProjectOptions.AreSameForChecking, areSameForSubsumption = FSharpProjectOptions.AreSubsumable, - requiredToKeep=(fun (builderOpt,_,_) -> match builderOpt with None -> false | Some b -> b.IsBeingKeptAliveApartFromCacheEntry), - onDiscard = (fun (_, _, decrement) -> decrement.Dispose())) + requiredToKeep=(fun (builderOpt,_,_) -> match builderOpt with None -> false | Some (b:IncrementalBuilder) -> b.IsBeingKeptAliveApartFromCacheEntry), + onDiscard = (fun (_, _, decrement:IDisposable) -> decrement.Dispose())) let getOrCreateBuilder (ctok, options) = cancellable { @@ -2112,9 +2196,9 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent static let mutable foregroundTypeCheckCount = 0 let MakeCheckFileResultsEmpty(creationErrors) = - FSharpCheckFileResults (Array.ofList creationErrors,None, None, reactorOps) + FSharpCheckFileResults (Array.ofList creationErrors, None, [], None, reactorOps) - let MakeCheckFileResults(options:FSharpProjectOptions, builder, scope, creationErrors, parseErrors, tcErrors) = + let MakeCheckFileResults(options:FSharpProjectOptions, builder, scope, dependencyFiles, creationErrors, parseErrors, tcErrors) = let errors = [| yield! creationErrors yield! parseErrors @@ -2123,12 +2207,12 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent else yield! tcErrors |] - FSharpCheckFileResults (errors, Some scope, Some builder, reactorOps) + FSharpCheckFileResults (errors, Some scope, dependencyFiles, Some builder, reactorOps) - let MakeCheckFileAnswer(tcFileResult, options:FSharpProjectOptions, builder, creationErrors, parseErrors, tcErrors) = + let MakeCheckFileAnswer(tcFileResult, options:FSharpProjectOptions, builder, dependencyFiles, creationErrors, parseErrors, tcErrors) = match tcFileResult with | Parser.TypeCheckAborted.Yes -> FSharpCheckFileAnswer.Aborted - | Parser.TypeCheckAborted.No scope -> FSharpCheckFileAnswer.Succeeded(MakeCheckFileResults(options, builder, scope, creationErrors, parseErrors, tcErrors)) + | Parser.TypeCheckAborted.No scope -> FSharpCheckFileAnswer.Succeeded(MakeCheckFileResults(options, builder, scope, dependencyFiles, creationErrors, parseErrors, tcErrors)) member bc.RecordTypeCheckFileInProjectResults(filename,options,parseResults,fileVersion,priorTimeStamp,checkAnswer,source) = match checkAnswer with @@ -2138,9 +2222,6 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent foregroundTypeCheckCount <- foregroundTypeCheckCount + 1 parseCacheLock.AcquireLock (fun ltok -> parseAndCheckFileInProjectCachePossiblyStale.Set(ltok, (filename,options),(parseResults,typedResults,fileVersion)) - - Console.WriteLine(sprintf "parseAndCheckFileInProjectCache SET key = %+A" (filename,source,options)) - parseAndCheckFileInProjectCache.Set(ltok, (filename,source,options),(parseResults,typedResults,fileVersion,priorTimeStamp)) parseFileInProjectCache.Set(ltok, (filename,source,options),parseResults)) @@ -2178,7 +2259,7 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent let parseErrors, _matchPairs, inputOpt, anyErrors = Parser.ParseOneFile (ctok, source, false, true, filename, builder.ProjectFileNames, builder.TcConfig) - let res = FSharpParseFileResults(parseErrors, inputOpt, anyErrors, builder.Dependencies ) + let res = FSharpParseFileResults(parseErrors, inputOpt, anyErrors, builder.AllDependenciesDeprecated ) parseCacheLock.AcquireLock (fun ctok -> parseFileInProjectCache.Set (ctok, (filename, source, options), res)) return res } @@ -2194,9 +2275,8 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent | None -> return FSharpParseFileResults(List.toArray creationErrors, None, true, []) | Some builder -> let! inputOpt,_,_,parseErrors = builder.GetParseResultsForFile (ctok, filename) - let dependencyFiles = builder.Dependencies - let errors = [| yield! creationErrors; yield! Parser.CreateErrorInfos (builder.TcConfig, false, filename, parseErrors) |] - return FSharpParseFileResults(errors = errors, input = inputOpt, parseHadErrors = false, dependencyFiles = dependencyFiles) + let errors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (builder.TcConfig, false, filename, parseErrors) |] + return FSharpParseFileResults(errors = errors, input = inputOpt, parseHadErrors = false, dependencyFiles = builder.AllDependenciesDeprecated) } ) @@ -2274,7 +2354,7 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent let! tcErrors, tcFileResult = Parser.TypeCheckOneFile(parseResults, source, fileName, options.ProjectFileName, tcPrior.TcConfig, tcPrior.TcGlobals, tcPrior.TcImports, tcPrior.TcState, loadClosure, tcPrior.Errors, reactorOps, (fun () -> builder.IsAlive), textSnapshotInfo) - let checkAnswer = MakeCheckFileAnswer(tcFileResult, options, builder, creationErrors, parseResults.Errors, tcErrors) + let checkAnswer = MakeCheckFileAnswer(tcFileResult, options, builder, tcPrior.TcDependencyFiles, creationErrors, parseResults.Errors, tcErrors) bc.RecordTypeCheckFileInProjectResults(fileName, options, parseResults, fileVersion, tcPrior.TimeStamp, Some checkAnswer, source) return checkAnswer finally @@ -2368,7 +2448,7 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent execWithReactorAsync <| fun ctok -> Parser.ParseOneFile (ctok, source, false, true, filename, builder.ProjectFileNames, builder.TcConfig) |> cancellable.Return - let parseResults = FSharpParseFileResults(parseErrors, inputOpt, anyErrors, builder.Dependencies) + let parseResults = FSharpParseFileResults(parseErrors, inputOpt, anyErrors, builder.AllDependenciesDeprecated) let! checkResults = bc.CheckOneFile(parseResults, source, filename, options, textSnapshotInfo, fileVersion, builder, tcPrior, creationErrors) bc.ImplicitlyStartCheckProjectInBackground(options) return parseResults, checkResults @@ -2388,9 +2468,9 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent | Some builder -> let! (inputOpt, _, _, untypedErrors) = builder.GetParseResultsForFile (ctok, filename) let! tcProj = builder.GetCheckResultsAfterFileInProject (ctok, filename) - let untypedErrors = [| yield! creationErrors; yield! Parser.CreateErrorInfos (builder.TcConfig, false, filename, untypedErrors) |] - let tcErrors = [| yield! creationErrors; yield! Parser.CreateErrorInfos (builder.TcConfig, false, filename, tcProj.Errors) |] - let parseResults = FSharpParseFileResults(errors = untypedErrors, input = inputOpt, parseHadErrors = false, dependencyFiles = builder.Dependencies) + let untypedErrors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (builder.TcConfig, false, filename, untypedErrors) |] + let tcErrors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (builder.TcConfig, false, filename, tcProj.Errors) |] + let parseResults = FSharpParseFileResults(errors = untypedErrors, input = inputOpt, parseHadErrors = false, dependencyFiles = builder.AllDependenciesDeprecated) let loadClosure = scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.TryGet (ltok, options) ) let scope = TypeCheckInfo(tcProj.TcConfig, tcProj.TcGlobals, tcProj.TcState.PartialAssemblySignature, tcProj.TcState.Ccu, tcProj.TcImports, tcProj.TcEnvAtEnd.AccessRights, @@ -2399,7 +2479,7 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent List.last tcProj.TcSymbolUses, tcProj.TcEnvAtEnd.NameEnv, loadClosure, reactorOps, (fun () -> builder.IsAlive), None) - let typedResults = MakeCheckFileResults(options, builder, scope, creationErrors, parseResults.Errors, tcErrors) + let typedResults = MakeCheckFileResults(options, builder, scope, tcProj.TcDependencyFiles, creationErrors, parseResults.Errors, tcErrors) return (parseResults, typedResults) }) @@ -2424,8 +2504,8 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent return FSharpCheckProjectResults (keepAssemblyContents, Array.ofList creationErrors, None, reactorOps) | Some builder -> let! (tcProj, ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt) = builder.GetCheckResultsAndImplementationsForProject(ctok) - let errors = [| yield! creationErrors; yield! Parser.CreateErrorInfos (tcProj.TcConfig, true, Microsoft.FSharp.Compiler.TcGlobals.DummyFileNameForRangesWithoutASpecificLocation, tcProj.Errors) |] - return FSharpCheckProjectResults (keepAssemblyContents, errors, Some(tcProj.TcGlobals, tcProj.TcImports, tcProj.TcState.Ccu, tcProj.TcState.PartialAssemblySignature, tcProj.TcSymbolUses, tcProj.TopAttribs, tcAssemblyDataOpt, ilAssemRef, tcProj.TcEnvAtEnd.AccessRights, tcAssemblyExprOpt), reactorOps) + let errors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (tcProj.TcConfig, true, Microsoft.FSharp.Compiler.TcGlobals.DummyFileNameForRangesWithoutASpecificLocation, tcProj.Errors) |] + return FSharpCheckProjectResults (keepAssemblyContents, errors, Some(tcProj.TcGlobals, tcProj.TcImports, tcProj.TcState.Ccu, tcProj.TcState.PartialAssemblySignature, tcProj.TcSymbolUses, tcProj.TopAttribs, tcAssemblyDataOpt, ilAssemRef, tcProj.TcEnvAtEnd.AccessRights, tcAssemblyExprOpt, tcProj.TcDependencyFiles), reactorOps) } /// Get the timestamp that would be on the output if fully built immediately @@ -2469,9 +2549,8 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent #endif let loadedTimeStamp = defaultArg loadedTimeStamp DateTime.MaxValue // Not 'now', we don't want to force reloading let applyCompilerOptions tcConfigB = - let collect _name = () let fsiCompilerOptions = CompileOptions.GetCoreFsiCompilerOptions tcConfigB - CompileOptions.ParseCompilerOptions (collect, fsiCompilerOptions, Array.toList otherFlags) + CompileOptions.ParseCompilerOptions (ignore, fsiCompilerOptions, Array.toList otherFlags) let loadClosure = LoadClosure.ComputeClosureOfSourceText(ctok, referenceResolver,filename, source, CodeContext.Editing, useSimpleResolution, useFsiAuxLib, new Lexhelp.LexResourceManager(), applyCompilerOptions, assumeDotNetFramework) let otherFlags = [| yield "--noframework"; yield "--warn:3"; @@ -2543,6 +2622,7 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent member bc.CompleteAllQueuedOps() = reactor.CompleteAllQueuedOps() + member bc.Reactor = reactor member bc.ReactorOps = reactorOps member bc.BeforeBackgroundFileCheck = beforeFileChecked.Publish member bc.FileParsed = fileParsed.Publish @@ -2589,7 +2669,7 @@ type FSharpChecker(referenceResolver, projectCacheSize, keepAssemblyContents, ke let backgroundCompiler = BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions) - static let globalInstance = FSharpChecker.Create() + static let globalInstance = lazy FSharpChecker.Create() // Parse using backgroundCompiler let ComputeBraceMatching(filename:string,source,options:FSharpProjectOptions) = @@ -2604,14 +2684,27 @@ type FSharpChecker(referenceResolver, projectCacheSize, keepAssemblyContents, ke areSame=AreSameForParsing3, areSameForSubsumption=AreSubsumable3) + let mutable maxMemoryReached = false + let mutable maxMB = maxMBDefault + let maxMemEvent = new Event() + /// Instantiate an interactive checker. - static member Create(?projectCacheSize, ?keepAssemblyContents, ?keepAllBackgroundResolutions) = - let referenceResolver = MSBuildReferenceResolver.Resolver + static member Create(?projectCacheSize, ?keepAssemblyContents, ?keepAllBackgroundResolutions, ?msbuildEnabled) = + + let msbuildEnabled = defaultArg msbuildEnabled true +#if COMPILER_SERVICE && !COMPILER_SERVICE_DLL_VISUAL_STUDIO + let referenceResolver = SimulatedMSBuildReferenceResolver.GetBestAvailableResolver(msbuildEnabled) +#else + let referenceResolver = (assert msbuildEnabled); MSBuildReferenceResolver.Resolver +#endif + let keepAssemblyContents = defaultArg keepAssemblyContents false let keepAllBackgroundResolutions = defaultArg keepAllBackgroundResolutions true let projectCacheSizeReal = defaultArg projectCacheSize projectCacheSizeDefault new FSharpChecker(referenceResolver, projectCacheSizeReal,keepAssemblyContents, keepAllBackgroundResolutions) + member ic.ReferenceResolver = referenceResolver + member ic.MatchBracesAlternate(filename, source, options) = async { match braceMatchCache.TryGet (AssumeAnyCallerThreadWithoutEvidence(), (filename, source, options)) with @@ -2623,6 +2716,7 @@ type FSharpChecker(referenceResolver, projectCacheSize, keepAssemblyContents, ke } member ic.ParseFileInProject(filename, source, options) = + ic.CheckMaxMemoryReached() backgroundCompiler.ParseFileInProject(filename, source, options) member ic.GetBackgroundParseResultsForFileInProject (filename,options) = @@ -2635,6 +2729,82 @@ type FSharpChecker(referenceResolver, projectCacheSize, keepAssemblyContents, ke member ic.TryGetRecentCheckResultsForFile(filename: string, options:FSharpProjectOptions, ?source) = backgroundCompiler.TryGetRecentCheckResultsForFile(filename,options,source) + member ic.Compile(argv: string[]) = + backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync ("Compile", fun ctok -> + cancellable { + return CompileHelpers.compileFromArgs (ctok, argv, referenceResolver, None, None) + } + ) + + member ic.Compile (ast:ParsedInput list, assemblyName:string, outFile:string, dependencies:string list, ?pdbFile:string, ?executable:bool, ?noframework:bool) = + backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync ("Compile", fun ctok -> + cancellable { + let noframework = defaultArg noframework false + return CompileHelpers.compileFromAsts (ctok, referenceResolver, ast, assemblyName, outFile, dependencies, noframework, pdbFile, executable, None, None) + } + ) + + member ic.CompileToDynamicAssembly (otherFlags: string[], execute: (TextWriter * TextWriter) option) = + backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync ("CompileToDynamicAssembly", fun ctok -> + cancellable { + CompileHelpers.setOutputStreams execute + + // References used to capture the results of compilation + let tcImportsRef = ref (None: TcImports option) + let assemblyBuilderRef = ref None + let tcImportsCapture = Some (fun tcImports -> tcImportsRef := Some tcImports) + + // Function to generate and store the results of compilation + let debugInfo = otherFlags |> Array.exists (fun arg -> arg = "-g" || arg = "--debug:+" || arg = "/debug:+") + let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (ctok, debugInfo, tcImportsRef, execute.IsSome, assemblyBuilderRef)) + + // Perform the compilation, given the above capturing function. + let errorsAndWarnings, result = CompileHelpers.compileFromArgs (ctok, otherFlags, referenceResolver, tcImportsCapture, dynamicAssemblyCreator) + + // Retrieve and return the results + let assemblyOpt = + match assemblyBuilderRef.Value with + | None -> None + | Some a -> Some (a :> System.Reflection.Assembly) + + return errorsAndWarnings, result, assemblyOpt + } + ) + + member ic.CompileToDynamicAssembly (asts:ParsedInput list, assemblyName:string, dependencies:string list, execute: (TextWriter * TextWriter) option, ?debug:bool, ?noframework:bool) = + backgroundCompiler.Reactor.EnqueueAndAwaitOpAsync ("CompileToDynamicAssembly", fun ctok -> + cancellable { + CompileHelpers.setOutputStreams execute + + // References used to capture the results of compilation + let tcImportsRef = ref (None: TcImports option) + let assemblyBuilderRef = ref None + let tcImportsCapture = Some (fun tcImports -> tcImportsRef := Some tcImports) + + let debugInfo = defaultArg debug false + let noframework = defaultArg noframework false + let location = Path.Combine(Path.GetTempPath(),"test"+string(hash assemblyName)) + try Directory.CreateDirectory(location) |> ignore with _ -> () + + let outFile = Path.Combine(location, assemblyName + ".dll") + + // Function to generate and store the results of compilation + let dynamicAssemblyCreator = Some (CompileHelpers.createDynamicAssembly (ctok, debugInfo, tcImportsRef, execute.IsSome, assemblyBuilderRef)) + + // Perform the compilation, given the above capturing function. + let errorsAndWarnings, result = + CompileHelpers.compileFromAsts (ctok, referenceResolver, asts, assemblyName, outFile, dependencies, noframework, None, Some execute.IsSome, tcImportsCapture, dynamicAssemblyCreator) + + // Retrieve and return the results + let assemblyOpt = + match assemblyBuilderRef.Value with + | None -> None + | Some a -> Some (a :> System.Reflection.Assembly) + + return errorsAndWarnings, result, assemblyOpt + } + ) + /// This function is called when the entire environment is known to have changed for reasons not encoded in the ProjectOptions of any project/compilation. /// For example, the type provider approvals file may have changed. member ic.InvalidateAll() = @@ -2648,6 +2818,16 @@ type FSharpChecker(referenceResolver, projectCacheSize, keepAssemblyContents, ke member ic.ClearCaches() = ic.ClearCachesAsync() |> Async.Start // this cache clearance is not synchronous, it will happen when the background op gets run + member ic.CheckMaxMemoryReached() = + if not maxMemoryReached && System.GC.GetTotalMemory(false) > int64 maxMB * 1024L * 1024L then + // If the maxMB limit is reached, drastic action is taken + // - reduce strong cache sizes to a minimum + backgroundCompiler.CompleteAllQueuedOps() + maxMemoryReached <- true + braceMatchCache.Resize(AssumeAnyCallerThreadWithoutEvidence(), keepStrongly=1) + backgroundCompiler.DownsizeCaches() |> Async.RunSynchronously + maxMemEvent.Trigger( () ) + /// This function is called when the entire environment is known to have changed for reasons not encoded in the ProjectOptions of any project/compilation. /// For example, the type provider approvals file may have changed. // @@ -2676,22 +2856,25 @@ type FSharpChecker(referenceResolver, projectCacheSize, keepAssemblyContents, ke /// Typecheck a source code file, returning a handle to the results of the /// parse including the reconstructed types in the file. member ic.CheckFileInProject(parseResults:FSharpParseFileResults, filename:string, fileVersion:int, source:string, options:FSharpProjectOptions, ?textSnapshotInfo:obj) = + ic.CheckMaxMemoryReached() backgroundCompiler.CheckFileInProject(parseResults,filename,fileVersion,source,options,textSnapshotInfo) /// Typecheck a source code file, returning a handle to the results of the /// parse including the reconstructed types in the file. member ic.ParseAndCheckFileInProject(filename:string, fileVersion:int, source:string, options:FSharpProjectOptions, ?textSnapshotInfo:obj) = + ic.CheckMaxMemoryReached() backgroundCompiler.ParseAndCheckFileInProject(filename, fileVersion, source, options, textSnapshotInfo) member ic.ParseAndCheckProject(options) = + ic.CheckMaxMemoryReached() backgroundCompiler.ParseAndCheckProject(options) member ic.KeepProjectAlive(options) = backgroundCompiler.KeepProjectAlive(options) /// For a given script file, get the ProjectOptions implied by the #load closure - member ic.GetProjectOptionsFromScript(filename, source, ?loadedTimeStamp, ?otherFlags, ?useFsiAuxLib, ?extraProjectInfo: obj) = - backgroundCompiler.GetProjectOptionsFromScript(filename,source,?loadedTimeStamp=loadedTimeStamp, ?otherFlags=otherFlags, ?useFsiAuxLib=useFsiAuxLib, ?extraProjectInfo=extraProjectInfo) + member ic.GetProjectOptionsFromScript(filename, source, ?loadedTimeStamp, ?otherFlags, ?useFsiAuxLib, ?assumeDotNetFramework, ?extraProjectInfo: obj) = + backgroundCompiler.GetProjectOptionsFromScript(filename,source,?loadedTimeStamp=loadedTimeStamp, ?otherFlags=otherFlags, ?useFsiAuxLib=useFsiAuxLib, ?assumeDotNetFramework=assumeDotNetFramework, ?extraProjectInfo=extraProjectInfo) member ic.GetProjectOptionsFromCommandLineArgs(projectFileName, argv, ?loadedTimeStamp, ?extraProjectInfo: obj) = let loadedTimeStamp = defaultArg loadedTimeStamp DateTime.MaxValue // Not 'now', we don't want to force reloading @@ -2735,18 +2918,40 @@ type FSharpChecker(referenceResolver, projectCacheSize, keepAssemblyContents, ke static member GlobalForegroundParseCountStatistic = BackgroundCompiler.GlobalForegroundParseCountStatistic static member GlobalForegroundTypeCheckCountStatistic = BackgroundCompiler.GlobalForegroundTypeCheckCountStatistic - static member Instance = globalInstance + member ic.MaxMemoryReached = maxMemEvent.Publish + member ic.MaxMemory with get() = maxMB and set v = maxMB <- v + + static member Instance with get() = globalInstance.Force() member internal __.FrameworkImportsCache = backgroundCompiler.FrameworkImportsCache -type FsiInteractiveChecker(reactorOps: IReactorOperations, tcConfig, tcGlobals, tcImports, tcState, loadClosure) = + /// Tokenize a single line, returning token information and a tokenization state represented by an integer + member x.TokenizeLine (line: string, state: int64) : FSharpTokenInfo[] * int64 = + let tokenizer = FSharpSourceTokenizer([], None) + let lineTokenizer = tokenizer.CreateLineTokenizer line + let state = ref (None, state) + let tokens = + [| while (state := lineTokenizer.ScanToken (snd !state); (fst !state).IsSome) do + yield (fst !state).Value |] + tokens, snd !state + + /// Tokenize an entire file, line by line + member x.TokenizeFile (source: string) : FSharpTokenInfo[][] = + let lines = source.Split('\n') + let tokens = + [| let state = ref 0L + for line in lines do + let tokens, n = x.TokenizeLine(line, !state) + state := n + yield tokens |] + tokens + + +type FsiInteractiveChecker(referenceResolver, reactorOps: IReactorOperations, tcConfig: TcConfig, tcGlobals, tcImports, tcState) = let keepAssemblyContents = false - static member CreateErrorInfos (tcConfig, allErrors, mainInputFileName, errors) = - Parser.CreateErrorInfos(tcConfig, allErrors, mainInputFileName, errors) - member __.ParseAndCheckInteraction (ctok, source) = async { - let mainInputFileName = "stdin.fsx" + let mainInputFileName = Path.Combine(tcConfig.implicitIncludeDir, "stdin.fsx") // Note: projectSourceFiles is only used to compute isLastCompiland, and is ignored if Build.IsScript(mainInputFileName) is true (which it is in this case). let projectSourceFiles = [ ] let parseErrors, _matchPairs, inputOpt, anyErrors = Parser.ParseOneFile (ctok, source, false, true, mainInputFileName, projectSourceFiles, tcConfig) @@ -2755,16 +2960,23 @@ type FsiInteractiveChecker(reactorOps: IReactorOperations, tcConfig, tcGlobals, let backgroundDiagnostics = [] + let assumeDotNetFramework = true + + let applyCompilerOptions tcConfigB = + let fsiCompilerOptions = CompileOptions.GetCoreFsiCompilerOptions tcConfigB + CompileOptions.ParseCompilerOptions (ignore, fsiCompilerOptions, [ ]) + + let loadClosure = LoadClosure.ComputeClosureOfSourceText(ctok, referenceResolver, mainInputFileName, source, CodeContext.Editing, tcConfig.useSimpleResolution, tcConfig.useFsiAuxLib, new Lexhelp.LexResourceManager(), applyCompilerOptions, assumeDotNetFramework) let! tcErrors, tcFileResult = Parser.TypeCheckOneFile(parseResults,source,mainInputFileName,"project",tcConfig,tcGlobals,tcImports, tcState, - loadClosure,backgroundDiagnostics,reactorOps,(fun () -> true),None) + Some loadClosure,backgroundDiagnostics,reactorOps,(fun () -> true),None) return match tcFileResult with | Parser.TypeCheckAborted.No scope -> let errors = [| yield! parseErrors; yield! tcErrors |] - let typeCheckResults = FSharpCheckFileResults (errors,Some scope, None, reactorOps) - let projectResults = FSharpCheckProjectResults (keepAssemblyContents, errors, Some(tcGlobals, tcImports, scope.ThisCcu, scope.CcuSig, [scope.ScopeSymbolUses], None, None, mkSimpleAssRef "stdin", tcState.TcEnvFromImpls.AccessRights, None), reactorOps) + let typeCheckResults = FSharpCheckFileResults (errors, Some scope, dependencyFiles, None, reactorOps) + let projectResults = FSharpCheckProjectResults (keepAssemblyContents, errors, Some(tcGlobals, tcImports, scope.ThisCcu, scope.CcuSig, [scope.ScopeSymbolUses], None, None, mkSimpleAssRef "stdin", tcState.TcEnvFromImpls.AccessRights, None, dependencyFiles), reactorOps) parseResults, typeCheckResults, projectResults | _ -> failwith "unexpected aborted" @@ -2774,6 +2986,10 @@ type FsiInteractiveChecker(reactorOps: IReactorOperations, tcConfig, tcGlobals, // CompilerEnvironment, DebuggerEnvironment // +type CompilerEnvironment = + static member BinFolderOfDefaultFSharpCompiler ?probePoint = + Internal.Utilities.FSharpEnvironment.BinFolderOfDefaultFSharpCompiler probePoint + /// Information about the compilation environment [] module CompilerEnvironment = @@ -2809,7 +3025,7 @@ module DebuggerEnvironment = /// debugger will use. let GetLanguageID() = System.Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy) - + module PrettyNaming = let IsIdentifierPartCharacter x = Microsoft.FSharp.Compiler.PrettyNaming.IsIdentifierPartCharacter x let IsLongIdentifierPartCharacter x = Microsoft.FSharp.Compiler.PrettyNaming.IsLongIdentifierPartCharacter x diff --git a/src/fsharp/vs/service.fsi b/src/fsharp/vs/service.fsi index 91e5da0ed22..8a63408f063 100755 --- a/src/fsharp/vs/service.fsi +++ b/src/fsharp/vs/service.fsi @@ -7,9 +7,14 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices open System +open System.IO open System.Collections.Generic +open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.Driver +open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.NameResolution @@ -26,7 +31,11 @@ open Microsoft.FSharp.Compiler.Tastops /// Represents the reason why the GetDeclarationLocation operation failed. [] +#if COMPILER_PUBLIC_API +type FSharpFindDeclFailureReason = +#else type internal FSharpFindDeclFailureReason = +#endif /// Generic reason: no particular information about error | Unknown @@ -42,7 +51,11 @@ type internal FSharpFindDeclFailureReason = /// Represents the result of the GetDeclarationLocation operation. [] +#if COMPILER_PUBLIC_API +type FSharpFindDeclResult = +#else type internal FSharpFindDeclResult = +#endif /// Indicates a declaration location was not found, with an additional reason | DeclNotFound of FSharpFindDeclFailureReason /// Indicates a declaration location was found @@ -50,52 +63,24 @@ type internal FSharpFindDeclResult = /// Represents the checking context implied by the ProjectOptions [] +#if COMPILER_PUBLIC_API +type FSharpProjectContext = +#else type internal FSharpProjectContext = +#endif /// Get the resolution and full contents of the assemblies referenced by the project options member GetReferencedAssemblies : unit -> FSharpAssembly list /// Get the accessibility rights for this project context w.r.t. InternalsVisibleTo attributes granting access to other assemblies member AccessibilityRights : FSharpAccessibilityRights -/// Represents the use of an F# symbol from F# source code -[] -type internal FSharpSymbolUse = - // For internal use only - internal new : g:TcGlobals * denv: Tastops.DisplayEnv * symbol:FSharpSymbol * itemOcc:ItemOccurence * range: range -> FSharpSymbolUse - - /// The symbol referenced - member Symbol : FSharpSymbol - - /// The display context active at the point where the symbol is used. Can be passed to FSharpType.Format - /// and other methods to format items in a way that is suitable for a specific source code location. - member DisplayContext : FSharpDisplayContext - - /// Indicates if the reference is a definition for the symbol, either in a signature or implementation - member IsFromDefinition : bool - - /// Indicates if the reference is in a pattern - member IsFromPattern : bool - - /// Indicates if the reference is in a syntactic type - member IsFromType : bool - - /// Indicates if the reference is in an attribute - member IsFromAttribute : bool - - /// Indicates if the reference is via the member being implemented in a class or object expression - member IsFromDispatchSlotImplementation : bool - - /// Indicates if the reference is either a builder or a custom operation in a computation expression - member IsFromComputationExpression : bool - - /// The file name the reference occurs in - member FileName: string - - /// The range of text representing the reference to the symbol - member RangeAlternate: range [] +#if COMPILER_PUBLIC_API +type SemanticClassificationType = +#else type internal SemanticClassificationType = +#endif | ReferenceType | ValueType | UnionCase @@ -114,7 +99,11 @@ type internal SemanticClassificationType = /// A handle to the results of CheckFileInProject. [] +#if COMPILER_PUBLIC_API +type FSharpCheckFileResults = +#else type internal FSharpCheckFileResults = +#endif /// The errors returned by parsing a source file. member Errors : FSharpErrorInfo[] @@ -128,6 +117,11 @@ type internal FSharpCheckFileResults = /// an unrecoverable error in earlier checking/parsing/resolution steps. member HasFullTypeCheckInfo: bool + /// Indicates the set of files which must be watched to accurately track changes that affect these results, + /// Clients interested in reacting to updates to these files should watch these files and take actions as described + /// in the documentation for compiler service. + member DependencyFiles : string list + /// Get the items for a declaration list /// /// @@ -136,7 +130,7 @@ type internal FSharpCheckFileResults = /// 'record field' locations and r.h.s. of 'range' operator a..b /// /// The line number where the completion is happening - /// The column number (1-based) at the end of the 'names' text + /// The column number at the end of the 'names' text /// The long identifier to the left of the '.' /// The residue of a partial long identifier to the right of the '.' /// The residue of a partial long identifier to the right of the '.' @@ -160,7 +154,7 @@ type internal FSharpCheckFileResults = /// 'record field' locations and r.h.s. of 'range' operator a..b /// /// The line number where the completion is happening - /// The column number (1-based) at the end of the 'names' text + /// The column number at the end of the 'names' text /// The long identifier to the left of the '.' /// The residue of a partial long identifier to the right of the '.' /// The residue of a partial long identifier to the right of the '.' @@ -240,27 +234,39 @@ type internal FSharpCheckFileResults = member GetSemanticClassification : range option -> (range * SemanticClassificationType)[] /// Get the locations of format specifiers + [] member GetFormatSpecifierLocations : unit -> range[] + /// Get the locations of and number of arguments associated with format specifiers + member GetFormatSpecifierLocationsAndArity : unit -> (range*int)[] + /// Get all textual usages of all symbols throughout the file member GetAllUsesOfAllSymbolsInFile : unit -> Async /// Get the textual usages that resolved to the given symbol throughout the file member GetUsesOfSymbolInFile : symbol:FSharpSymbol -> Async + member internal GetVisibleNamespacesAndModulesAtPoint : pos -> Async + /// Determines if a long ident is resolvable at a specific point. - member IsRelativeNameResolvable: cursorPos : pos * plid : string list * item: Item -> Async + member internal IsRelativeNameResolvable: cursorPos : pos * plid : string list * item: Item -> Async + /// A handle to the results of CheckFileInProject. [] +#if COMPILER_PUBLIC_API +type FSharpCheckProjectResults = +#else type internal FSharpCheckProjectResults = +#endif + /// The errors returned by processing the project member Errors : FSharpErrorInfo[] /// Get a view of the overall signature of the assembly. Only valid to use if HasCriticalErrors is false. member AssemblySignature : FSharpAssemblySignature - // /// Get a view of the overall contents of the assembly. Only valid to use if HasCriticalErrors is false. - // member AssemblyContents : FSharpAssemblyContents + /// Get a view of the overall contents of the assembly. Only valid to use if HasCriticalErrors is false. + member AssemblyContents : FSharpAssemblyContents /// Get the resolution of the ProjectOptions member ProjectContext : FSharpProjectContext @@ -274,12 +280,24 @@ type internal FSharpCheckProjectResults = /// Indicates if critical errors existed in the project options member HasCriticalErrors : bool + /// Indicates the set of files which must be watched to accurately track changes that affect these results, + /// Clients interested in reacting to updates to these files should watch these files and take actions as described + /// in the documentation for compiler service. + member DependencyFiles : string list /// Unused in this API +#if COMPILER_PUBLIC_API +type UnresolvedReferencesSet +#else type internal UnresolvedReferencesSet +#endif /// A set of information describing a project or script build configuration. +#if COMPILER_PUBLIC_API +type FSharpProjectOptions = +#else type internal FSharpProjectOptions = +#endif { // Note that this may not reduce to just the project directory, because there may be two projects in the same directory. ProjectFileName: string @@ -308,16 +326,23 @@ type internal FSharpProjectOptions = ExtraProjectInfo : obj option } - /// The result of calling TypeCheckResult including the possibility of abort and background compiler not caught up. [] +#if COMPILER_PUBLIC_API +type FSharpCheckFileAnswer = +#else type internal FSharpCheckFileAnswer = +#endif | Aborted // because cancellation caused an abandonment of the operation | Succeeded of FSharpCheckFileResults [] /// Used to parse and check F# source code. +#if COMPILER_PUBLIC_API +type FSharpChecker = +#else type internal FSharpChecker = +#endif /// /// Create an instance of an FSharpChecker. /// @@ -325,7 +350,8 @@ type internal FSharpChecker = /// The optional size of the project checking cache. /// Keep the checked contents of projects. /// If false, do not keep full intermediate checking results from background checking suitable for returning from GetBackgroundCheckResultsForFileInProject. This reduces memory usage. - static member Create : ?projectCacheSize: int * ?keepAssemblyContents: bool * ?keepAllBackgroundResolutions: bool -> FSharpChecker + /// If false, no dependency on MSBuild v12 is assumed. If true, at attempt is made to load MSBuild for reference resolution in scripts + static member Create : ?projectCacheSize: int * ?keepAssemblyContents: bool * ?keepAllBackgroundResolutions: bool * ?msbuildEnabled: bool -> FSharpChecker /// /// Parse a source code file, returning information about brace matching in the file. @@ -380,8 +406,7 @@ type internal FSharpChecker = /// Note: all files except the one being checked are read from the FileSystem API /// /// - /// Return FSharpCheckFileAnswer.Aborted if a parse tree was not available or if the check - //// was abandoned due to some checkpoint during type checking. + /// Return FSharpCheckFileAnswer.Aborted if a parse tree was not available. /// /// /// @@ -406,8 +431,7 @@ type internal FSharpChecker = /// Note: all files except the one being checked are read from the FileSystem API /// /// - /// Return FSharpCheckFileAnswer.Aborted if a parse tree was not available or if the check - //// was abandoned due to some checkpoint during type checking. + /// Return FSharpCheckFileAnswer.Aborted if a parse tree was not available. /// /// /// @@ -449,7 +473,7 @@ type internal FSharpChecker = /// Indicates when the script was loaded into the editing environment, /// so that an 'unload' and 'reload' action will cause the script to be considered as a new project, /// so that references are re-resolved. - member GetProjectOptionsFromScript : filename: string * source: string * ?loadedTimeStamp: DateTime * ?otherFlags: string[] * ?useFsiAuxLib: bool * ?extraProjectInfo: obj -> Async + member GetProjectOptionsFromScript : filename: string * source: string * ?loadedTimeStamp: DateTime * ?otherFlags: string[] * ?useFsiAuxLib: bool * ?assumeDotNetFramework: bool * ?extraProjectInfo: obj -> Async /// /// Get the FSharpProjectOptions implied by a set of command line arguments. @@ -480,6 +504,29 @@ type internal FSharpChecker = /// The options for the project or script, used to determine active --define conditionals and other options relevant to parsing. member GetBackgroundCheckResultsForFileInProject : filename : string * options : FSharpProjectOptions -> Async + /// Compile using the given flags. Source files names are resolved via the FileSystem API. + /// The output file must be given by a -o flag. + /// The first argument is ignored and can just be "fsc.exe". + member Compile: argv:string [] -> Async + + /// TypeCheck and compile provided AST + member Compile: ast:ParsedInput list * assemblyName:string * outFile:string * dependencies:string list * ?pdbFile:string * ?executable:bool * ?noframework:bool -> Async + + /// Compiles to a dynamic assembly using the given flags. + /// + /// The first argument is ignored and can just be "fsc.exe". + /// + /// Any source files names are resolved via the FileSystem API. An output file name must be given by a -o flag, but this will not + /// be written - instead a dynamic assembly will be created and loaded. + /// + /// If the 'execute' parameter is given the entry points for the code are executed and + /// the given TextWriters are used for the stdout and stderr streams respectively. In this + /// case, a global setting is modified during the execution. + member CompileToDynamicAssembly: otherFlags:string [] * execute:(TextWriter * TextWriter) option -> Async + + /// TypeCheck and compile provided AST + member CompileToDynamicAssembly: ast:ParsedInput list * assemblyName:string * dependencies:string list * execute:(TextWriter * TextWriter) option * ?debug:bool * ?noframework:bool -> Async + /// /// Try to get type check results for a file. This looks up the results of recent type checks of the /// same file, regardless of contents. The version tag specified in the original check of the file is returned. @@ -499,9 +546,6 @@ type internal FSharpChecker = /// For example, dependent references may have been deleted or created. member InvalidateConfiguration: options: FSharpProjectOptions -> unit - /// Begin background parsing the given project. - member StartBackgroundCompile: options: FSharpProjectOptions -> unit - /// Set the project to be checked in the background. Overrides any previous call to CheckProjectInBackground member CheckProjectInBackground: options: FSharpProjectOptions -> unit @@ -512,7 +556,7 @@ type internal FSharpChecker = /// Block until the background compile finishes. //[] member WaitForBackgroundCompile : unit -> unit - + /// Report a statistic for testability static member GlobalForegroundParseCountStatistic : int @@ -546,6 +590,12 @@ type internal FSharpChecker = /// The event will be raised on a background thread. member FileChecked : IEvent + /// Raised after the maxMB memory threshold limit is reached + member MaxMemoryReached : IEvent + + /// A maximum number of megabytes of allocated memory. If the figure reported by System.GC.GetTotalMemory(false) goes over this limit, the FSharpChecker object will attempt to free memory and reduce cache sizes to a minimum. + member MaxMemory : int with get, set + /// Get or set a flag which controls if background work is started implicitly. /// /// If true, calls to CheckFileInProject implicitly start a background check of that project, replacing @@ -564,21 +614,41 @@ type internal FSharpChecker = // For internal use only member internal ReactorOps : IReactorOperations - // One shared global singleton for use by multiple add-ins + [] static member Instance : FSharpChecker member internal FrameworkImportsCache : FrameworkImportsCache + member internal ReferenceResolver : ReferenceResolver.Resolver + + /// Tokenize a single line, returning token information and a tokenization state represented by an integer + member TokenizeLine: line:string * state:int64 -> FSharpTokenInfo [] * int64 + + /// Tokenize an entire file, line by line + member TokenizeFile: source:string -> FSharpTokenInfo [] [] + // An object to typecheck source in a given typechecking environment. // Used internally to provide intellisense over F# Interactive. type internal FsiInteractiveChecker = - internal new : ops: IReactorOperations * tcConfig: TcConfig * tcGlobals: TcGlobals * tcImports: TcImports * tcState: TcState * loadClosure: LoadClosure option -> FsiInteractiveChecker + internal new : ReferenceResolver.Resolver * ops: IReactorOperations * tcConfig: TcConfig * tcGlobals: TcGlobals * tcImports: TcImports * tcState: TcState -> FsiInteractiveChecker member internal ParseAndCheckInteraction : CompilationThreadToken * source:string -> Async - static member internal CreateErrorInfos : tcConfig: TcConfig * allErrors:bool * mainInputFileName : string * seq -> FSharpErrorInfo[] + +/// Information about the compilation environment +#if COMPILER_PUBLIC_API +type [] CompilerEnvironment = +#else +type [] internal CompilerEnvironment = +#endif + /// The default location of FSharp.Core.dll and fsc.exe based on the version of fsc.exe that is running + static member BinFolderOfDefaultFSharpCompiler : string option -> string option /// Information about the compilation environment [] +#if COMPILER_PUBLIC_API +module CompilerEnvironment = +#else module internal CompilerEnvironment = +#endif /// These are the names of assemblies that should be referenced for .fs or .fsi files that /// are not associated with a project. val DefaultReferencesForOrphanSources : assumeDotNetFramework: bool -> string list @@ -588,13 +658,23 @@ module internal CompilerEnvironment = val IsCheckerSupportedSubcategory : string -> bool /// Information about the debugging environment +#if COMPILER_PUBLIC_API +module DebuggerEnvironment = +#else module internal DebuggerEnvironment = +#endif /// Return the language ID, which is the expression evaluator id that the /// debugger will use. val GetLanguageID : unit -> Guid + /// A set of helpers related to naming of identifiers +#if COMPILER_PUBLIC_API +module PrettyNaming = +#else module internal PrettyNaming = +#endif + val IsIdentifierPartCharacter : char -> bool val IsLongIdentifierPartCharacter : char -> bool val IsOperatorName : string -> bool diff --git a/src/update.cmd b/src/update.cmd index 455dcf7135f..480ef80b763 100644 --- a/src/update.cmd +++ b/src/update.cmd @@ -43,57 +43,11 @@ set SN64="%WINSDKNETFXTOOLS_x64%sn.exe" set NGEN32=%windir%\Microsoft.NET\Framework\v4.0.30319\ngen.exe set NGEN64=%windir%\Microsoft.NET\Framework64\v4.0.30319\ngen.exe -rem Disable strong-name validation for F# binaries built from open source that are signed with the microsoft key -%SN32% -q -Vr FSharp.Core,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.Build,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.Compiler.Interactive.Settings,b03f5f7f11d50a3a - -%SN32% -q -Vr fsc,b03f5f7f11d50a3a -%SN32% -q -Vr fsi,b03f5f7f11d50a3a -%SN32% -q -Vr fsiAnyCpu,b03f5f7f11d50a3a - -%SN32% -q -Vr HostedCompilerServer,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.Compiler,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.Compiler.Server.Shared,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.Editor,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.UIResources,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.LanguageService,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.LanguageService.Base,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.LanguageService.Compiler,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.ProjectSystem.Base,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.ProjectSystem.FSharp,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.ProjectSystem.PropertyPages,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.VS.FSI,b03f5f7f11d50a3a -%SN32% -q -Vr VisualFSharp.Unittests,b03f5f7f11d50a3a -%SN32% -q -Vr VisualFSharp.Salsa,b03f5f7f11d50a3a -%SN32% -q -Vr FSharp.Compiler.Unittests,b03f5f7f11d50a3a -%SN32% -q -Vr Microsoft.VisualStudio.Shell.UI.Internal,b03f5f7f11d50a3a +rem Disable strong-name validation for binaries that are delay-signed with the microsoft key +%SN32% -q -Vr *,b03f5f7f11d50a3a if /i "%PROCESSOR_ARCHITECTURE%"=="AMD64" ( - %SN64% -q -Vr FSharp.Core,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.Build,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.Compiler.Interactive.Settings,b03f5f7f11d50a3a - - %SN64% -q -Vr fsc,b03f5f7f11d50a3a - %SN64% -q -Vr fsi,b03f5f7f11d50a3a - %SN64% -q -Vr fsiAnyCpu,b03f5f7f11d50a3a - - %SN64% -q -Vr HostedCompilerServer,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.Compiler,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.Compiler.Server.Shared,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.Editor,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.UIResources,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.LanguageService,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.LanguageService.Base,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.LanguageService.Compiler,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.ProjectSystem.Base,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.ProjectSystem.FSharp,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.ProjectSystem.PropertyPages,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.VS.FSI,b03f5f7f11d50a3a - %SN64% -q -Vr VisualFSharp.Unittests,b03f5f7f11d50a3a - %SN64% -q -Vr VisualFSharp.Salsa,b03f5f7f11d50a3a - %SN64% -q -Vr FSharp.Compiler.Unittests,b03f5f7f11d50a3a - %SN64% -q -Vr Microsoft.VisualStudio.Shell.UI.Internal,b03f5f7f11d50a3a + %SN64% -q -Vr *,b03f5f7f11d50a3a ) if /i "%1" == "signonly" goto :eof diff --git a/src/utils/CompilerLocationUtils.fs b/src/utils/CompilerLocationUtils.fs index c57f379a795..55b41a240d7 100644 --- a/src/utils/CompilerLocationUtils.fs +++ b/src/utils/CompilerLocationUtils.fs @@ -137,9 +137,15 @@ module internal FSharpEnvironment = null) let is32Bit = IntPtr.Size = 4 + + let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e-> false let tryRegKey(subKey:string) = + //if we are runing on mono simply return None + // GetDefaultRegistryStringValueViaDotNet will result in an access denied by default, + // and Get32BitRegistryStringValueViaPInvoke will fail due to Advapi32.dll not existing + if runningOnMono then None else if is32Bit then let s = GetDefaultRegistryStringValueViaDotNet(subKey) // If we got here AND we're on a 32-bit OS then we can validate that Get32BitRegistryStringValueViaPInvoke(...) works @@ -189,6 +195,7 @@ module internal FSharpEnvironment = // - default location of fsc.exe in FSharp.Compiler.CodeDom.dll // - default F# binaries directory in (project system) Project.fs let BinFolderOfDefaultFSharpCompiler(probePoint:string option) = + ignore probePoint #if FX_NO_WIN_REGISTRY ignore probePoint #if FX_NO_APP_DOMAINS @@ -218,19 +225,10 @@ module internal FSharpEnvironment = // Property pages (ApplicationPropPage.vb) let key20 = @"Software\Microsoft\.NETFramework\AssemblyFolders\Microsoft.FSharp-" + FSharpTeamVersionNumber -#if VS_VERSION_DEV12 - let key40 = @"Software\Microsoft\FSharp\3.1\Runtime\v4.0" -#endif -#if VS_VERSION_DEV14 - let key40 = @"Software\Microsoft\FSharp\4.0\Runtime\v4.0" -#endif -#if VS_VERSION_DEV15 - let key40 = @"Software\Microsoft\FSharp\4.1\Runtime\v4.0" -#endif - let key1,key2 = - match FSharpCoreLibRunningVersion with - | None -> key20,key40 - | Some v -> if v.Length > 1 && v.[0] <= '3' then key20,key40 else key40,key20 + let key40a = @"Software\Microsoft\FSharp\4.0\Runtime\v4.0" + let key40b = @"Software\Microsoft\FSharp\3.1\Runtime\v4.0" + let key40c = @"Software\Microsoft\FSharp\2.0\Runtime\v4.0" + let key1,key2,key3,key4 = key40a, key40b, key40c, key20 let result = tryRegKey key1 match result with @@ -240,6 +238,23 @@ module internal FSharpEnvironment = match result with | Some _ -> result | None -> + let result = tryRegKey key3 + match result with + | Some _ -> result + | None -> + let result = tryRegKey key4 + match result with + | Some _ -> result + | None -> + + // On Unix we let you set FSHARP_COMPILER_BIN. I've rarely seen this used and its not documented in the install instructions. + let result = + let var = System.Environment.GetEnvironmentVariable("FSHARP_COMPILER_BIN") + if String.IsNullOrEmpty(var) then None + else Some(var) + match result with + | Some _ -> result + | None -> // For the prototype compiler, we can just use the current domain tryCurrentDomain() with e -> @@ -266,8 +281,6 @@ module internal FSharpEnvironment = | _ -> regkey.GetValue("Release", 0) :?> int |> (fun s -> s >= 0x50000)) // 0x50000 implies 4.5.0 with _ -> false - let runningOnMono = (Type.GetType("Mono.Runtime") <> null) - // Check if the framework version 4.5 or above is installed let IsNetFx45OrAboveInstalled = IsNetFx45OrAboveInstalledAt @"SOFTWARE\Microsoft\NET Framework Setup\NDP\v4\Client" || diff --git a/src/utils/sformat.fs b/src/utils/sformat.fs index 1b377eedf94..5264297b32c 100644 --- a/src/utils/sformat.fs +++ b/src/utils/sformat.fs @@ -53,11 +53,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat #endif [] -#if COMPILER - type internal LayoutTag = -#else type LayoutTag = -#endif | ActivePatternCase | ActivePatternResult | Alias @@ -92,19 +88,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat | UnknownType | UnknownEntity -#if COMPILER - type internal TaggedText = -#else type TaggedText = -#endif abstract Tag: LayoutTag abstract Text: string - -#if COMPILER - type internal TaggedTextWriter = -#else + type TaggedTextWriter = -#endif abstract Write: t: TaggedText -> unit abstract WriteLine: unit -> unit @@ -112,11 +100,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat /// - unbreakable, or /// - breakable, and if broken the second block has a given indentation. [] -#if COMPILER - type internal Joint = -#else type Joint = -#endif | Unbreakable | Breakable of int | Broken of int @@ -126,43 +110,23 @@ namespace Microsoft.FSharp.Text.StructuredFormat /// /// If either juxt flag is true, then no space between words. [] -#if COMPILER - type internal Layout = -#else type Layout = -#endif | ObjLeaf of bool * obj * bool | Leaf of bool * TaggedText * bool | Node of bool * layout * bool * layout * bool * joint | Attr of string * (string * string) list * layout -#if COMPILER - and internal layout = Layout -#else and layout = Layout -#endif -#if COMPILER - and internal joint = Joint -#else and joint = Joint -#endif [] -#if COMPILER - type internal IEnvironment = -#else type IEnvironment = -#endif abstract GetLayout : obj -> layout abstract MaxColumns : int abstract MaxRows : int -#if COMPILER - module internal TaggedTextOps = -#else module TaggedTextOps = -#endif let tag tag text = { new TaggedText with member x.Tag = tag @@ -248,11 +212,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat let arrow = tagPunctuation "->" let questionMark = tagPunctuation "?" -#if COMPILER - module internal LayoutOps = -#else module LayoutOps = -#endif open TaggedTextOps let rec juxtLeft = function @@ -353,11 +313,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat /// These are a typical set of options used to control structured formatting. [] -#if COMPILER - type internal FormatOptions = -#else type FormatOptions = -#endif { FloatingPointFormat: string; AttributeProcessor: (string -> (string * string) list -> bool -> unit); #if RUNTIME @@ -404,11 +360,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat -#if COMPILER - module internal ReflectUtils = -#else module ReflectUtils = -#endif open System open System.Reflection @@ -536,11 +488,7 @@ namespace Microsoft.FSharp.Text.StructuredFormat | _ -> GetValueInfoOfObject bindingFlags (obj) -#if COMPILER - module internal Display = -#else module Display = -#endif open ReflectUtils open LayoutOps diff --git a/src/utils/sformat.fsi b/src/utils/sformat.fsi index 24f53a8cb77..cfddec6aacf 100644 --- a/src/utils/sformat.fsi +++ b/src/utils/sformat.fsi @@ -48,20 +48,20 @@ namespace Microsoft.FSharp.Text.StructuredFormat /// Data representing joints in structured layouts of terms. The representation /// of this data type is only for the consumption of formatting engines. [] -#if COMPILER - type internal Joint = -#else +#if COMPILER_PUBLIC_API type Joint = +#else + type internal Joint = #endif | Unbreakable | Breakable of int | Broken of int [] -#if COMPILER - type internal LayoutTag = -#else +#if COMPILER_PUBLIC_API type LayoutTag = +#else + type internal LayoutTag = #endif | ActivePatternCase | ActivePatternResult @@ -97,19 +97,19 @@ namespace Microsoft.FSharp.Text.StructuredFormat | UnknownType | UnknownEntity -#if COMPILER - type internal TaggedText = -#else +#if COMPILER_PUBLIC_API type TaggedText = +#else + type internal TaggedText = #endif abstract Tag : LayoutTag abstract Text : string -#if COMPILER - type internal TaggedTextWriter = -#else +#if COMPILER_PUBLIC_API type TaggedTextWriter = +#else + type internal TaggedTextWriter = #endif abstract Write: t: TaggedText -> unit abstract WriteLine: unit -> unit @@ -117,10 +117,10 @@ namespace Microsoft.FSharp.Text.StructuredFormat /// Data representing structured layouts of terms. The representation /// of this data type is only for the consumption of formatting engines. [] -#if COMPILER - type internal Layout = -#else +#if COMPILER_PUBLIC_API type Layout = +#else + type internal Layout = #endif | ObjLeaf of bool * obj * bool | Leaf of bool * TaggedText * bool @@ -128,12 +128,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat | Attr of string * (string * string) list * Layout #endif - module -#if RUNTIME || COMPILER - internal +#if COMPILER_PUBLIC_API + module TaggedTextOps = #else + module internal TaggedTextOps = #endif - TaggedTextOps = val tag : LayoutTag -> string -> TaggedText val keywordFunctions : Set val tagAlias : string -> TaggedText @@ -182,10 +181,10 @@ namespace Microsoft.FSharp.Text.StructuredFormat #if RUNTIME // FSharp.Core.dll doesn't use PrintIntercepts #else // FSharp.Compiler.dll, FSharp.Compiler-proto.dll, FSharp.PowerPack.dll -#if COMPILER - type internal IEnvironment = -#else +#if COMPILER_PUBLIC_API type IEnvironment = +#else + type internal IEnvironment = #endif /// Return to the layout-generation /// environment to layout any otherwise uninterpreted object @@ -205,15 +204,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat /// A joint is either unbreakable, breakable or broken. /// If a joint is broken the RHS layout occurs on the next line with optional indentation. /// A layout can be squashed to for given width which forces breaks as required. - module -#if RUNTIME // FSharp.Core.dll - internal +#if COMPILER_PUBLIC_API + module LayoutOps = #else -#if COMPILER - internal + module internal LayoutOps = #endif -#endif - LayoutOps = /// The empty layout val emptyL : Layout @@ -309,15 +304,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat /// /// [] - type -#if RUNTIME // FSharp.Core.dll - internal +#if COMPILER_PUBLIC_API + type FormatOptions = #else -#if COMPILER - internal + type internal FormatOptions = #endif -#endif - FormatOptions = { FloatingPointFormat: string AttributeProcessor: (string -> (string * string) list -> bool -> unit); #if RUNTIME // FSharp.Core.dll: PrintIntercepts aren't used there @@ -341,16 +332,11 @@ namespace Microsoft.FSharp.Text.StructuredFormat ShowIEnumerable: bool } static member Default : FormatOptions - module -#if RUNTIME // FSharp.Core.dll - internal +#if COMPILER_PUBLIC_API + module Display = #else -#if COMPILER - internal + module internal Display = #endif -#endif - Display = - /// Convert any value to a string using a standard formatter /// Data is typically formatted in a structured format, e.g. diff --git a/tests/fsharp/core/printing/z.output.test.1000.stderr.bsl b/tests/fsharp/core/printing/z.output.test.1000.stderr.bsl index b4d6c68a7f1..38819190c9d 100644 --- a/tests/fsharp/core/printing/z.output.test.1000.stderr.bsl +++ b/tests/fsharp/core/printing/z.output.test.1000.stderr.bsl @@ -268,51 +268,61 @@ stdin(619,21): warning FS1172: Infix operator member '**' has no arguments. Expe stdin(624,17): warning FS0864: This new member hides the abstract member 'System.Object.ToString() : string'. Rename the member or use 'override' instead. + member this.M() = "string" ----------------^ stdin(765,17): error FS0438: Duplicate method. The method 'M' has the same name and signature as another method in this type. + member this.P = "string" ----------------^ stdin(772,17): error FS0438: Duplicate method. The method 'get_P' has the same name and signature as another method in this type. + type public IBPublic = interface inherit IAPrivate abstract Q : int end ------------------^^^^^^^^ stdin(779,19): error FS0410: The type 'IAPrivate' is less accessible than the value, member or type 'IBPublic' it is used in. + type internal IBInternal = interface inherit IAPrivate abstract Q : int end ------------------^^^^^^^^^^ stdin(784,19): error FS0410: The type 'IAPrivate' is less accessible than the value, member or type 'IBInternal' it is used in. + type public IBPublic = interface inherit IAInternal abstract Q : int end ------------------^^^^^^^^ stdin(793,19): error FS0410: The type 'IAInternal' is less accessible than the value, member or type 'IBPublic' it is used in. + override x.M(a:string) = 1 -------------------^ stdin(825,20): error FS0361: The override 'M : string -> int' implements more than one abstract slot, e.g. 'abstract member Regression4232.D.M : 'U -> int' and 'abstract member Regression4232.D.M : 'T -> int' + let (|A|B|) (x:int) = A x;; -----^^^^^ stdin(833,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) (x:'a) = A x;; -----^^^^^ stdin(836,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) (p:'a) (x:int) = A p;; -----^^^^^ stdin(839,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) = failwith "" : Choice;; -----^^^^^ diff --git a/tests/fsharp/core/printing/z.output.test.200.stderr.bsl b/tests/fsharp/core/printing/z.output.test.200.stderr.bsl index b4d6c68a7f1..38819190c9d 100644 --- a/tests/fsharp/core/printing/z.output.test.200.stderr.bsl +++ b/tests/fsharp/core/printing/z.output.test.200.stderr.bsl @@ -268,51 +268,61 @@ stdin(619,21): warning FS1172: Infix operator member '**' has no arguments. Expe stdin(624,17): warning FS0864: This new member hides the abstract member 'System.Object.ToString() : string'. Rename the member or use 'override' instead. + member this.M() = "string" ----------------^ stdin(765,17): error FS0438: Duplicate method. The method 'M' has the same name and signature as another method in this type. + member this.P = "string" ----------------^ stdin(772,17): error FS0438: Duplicate method. The method 'get_P' has the same name and signature as another method in this type. + type public IBPublic = interface inherit IAPrivate abstract Q : int end ------------------^^^^^^^^ stdin(779,19): error FS0410: The type 'IAPrivate' is less accessible than the value, member or type 'IBPublic' it is used in. + type internal IBInternal = interface inherit IAPrivate abstract Q : int end ------------------^^^^^^^^^^ stdin(784,19): error FS0410: The type 'IAPrivate' is less accessible than the value, member or type 'IBInternal' it is used in. + type public IBPublic = interface inherit IAInternal abstract Q : int end ------------------^^^^^^^^ stdin(793,19): error FS0410: The type 'IAInternal' is less accessible than the value, member or type 'IBPublic' it is used in. + override x.M(a:string) = 1 -------------------^ stdin(825,20): error FS0361: The override 'M : string -> int' implements more than one abstract slot, e.g. 'abstract member Regression4232.D.M : 'U -> int' and 'abstract member Regression4232.D.M : 'T -> int' + let (|A|B|) (x:int) = A x;; -----^^^^^ stdin(833,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) (x:'a) = A x;; -----^^^^^ stdin(836,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) (p:'a) (x:int) = A p;; -----^^^^^ stdin(839,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) = failwith "" : Choice;; -----^^^^^ diff --git a/tests/fsharp/core/printing/z.output.test.default.stderr.bsl b/tests/fsharp/core/printing/z.output.test.default.stderr.bsl index b4d6c68a7f1..38819190c9d 100644 --- a/tests/fsharp/core/printing/z.output.test.default.stderr.bsl +++ b/tests/fsharp/core/printing/z.output.test.default.stderr.bsl @@ -268,51 +268,61 @@ stdin(619,21): warning FS1172: Infix operator member '**' has no arguments. Expe stdin(624,17): warning FS0864: This new member hides the abstract member 'System.Object.ToString() : string'. Rename the member or use 'override' instead. + member this.M() = "string" ----------------^ stdin(765,17): error FS0438: Duplicate method. The method 'M' has the same name and signature as another method in this type. + member this.P = "string" ----------------^ stdin(772,17): error FS0438: Duplicate method. The method 'get_P' has the same name and signature as another method in this type. + type public IBPublic = interface inherit IAPrivate abstract Q : int end ------------------^^^^^^^^ stdin(779,19): error FS0410: The type 'IAPrivate' is less accessible than the value, member or type 'IBPublic' it is used in. + type internal IBInternal = interface inherit IAPrivate abstract Q : int end ------------------^^^^^^^^^^ stdin(784,19): error FS0410: The type 'IAPrivate' is less accessible than the value, member or type 'IBInternal' it is used in. + type public IBPublic = interface inherit IAInternal abstract Q : int end ------------------^^^^^^^^ stdin(793,19): error FS0410: The type 'IAInternal' is less accessible than the value, member or type 'IBPublic' it is used in. + override x.M(a:string) = 1 -------------------^ stdin(825,20): error FS0361: The override 'M : string -> int' implements more than one abstract slot, e.g. 'abstract member Regression4232.D.M : 'U -> int' and 'abstract member Regression4232.D.M : 'T -> int' + let (|A|B|) (x:int) = A x;; -----^^^^^ stdin(833,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) (x:'a) = A x;; -----^^^^^ stdin(836,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) (p:'a) (x:int) = A p;; -----^^^^^ stdin(839,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) = failwith "" : Choice;; -----^^^^^ diff --git a/tests/fsharp/core/printing/z.output.test.off.stderr.bsl b/tests/fsharp/core/printing/z.output.test.off.stderr.bsl index b4d6c68a7f1..38819190c9d 100644 --- a/tests/fsharp/core/printing/z.output.test.off.stderr.bsl +++ b/tests/fsharp/core/printing/z.output.test.off.stderr.bsl @@ -268,51 +268,61 @@ stdin(619,21): warning FS1172: Infix operator member '**' has no arguments. Expe stdin(624,17): warning FS0864: This new member hides the abstract member 'System.Object.ToString() : string'. Rename the member or use 'override' instead. + member this.M() = "string" ----------------^ stdin(765,17): error FS0438: Duplicate method. The method 'M' has the same name and signature as another method in this type. + member this.P = "string" ----------------^ stdin(772,17): error FS0438: Duplicate method. The method 'get_P' has the same name and signature as another method in this type. + type public IBPublic = interface inherit IAPrivate abstract Q : int end ------------------^^^^^^^^ stdin(779,19): error FS0410: The type 'IAPrivate' is less accessible than the value, member or type 'IBPublic' it is used in. + type internal IBInternal = interface inherit IAPrivate abstract Q : int end ------------------^^^^^^^^^^ stdin(784,19): error FS0410: The type 'IAPrivate' is less accessible than the value, member or type 'IBInternal' it is used in. + type public IBPublic = interface inherit IAInternal abstract Q : int end ------------------^^^^^^^^ stdin(793,19): error FS0410: The type 'IAInternal' is less accessible than the value, member or type 'IBPublic' it is used in. + override x.M(a:string) = 1 -------------------^ stdin(825,20): error FS0361: The override 'M : string -> int' implements more than one abstract slot, e.g. 'abstract member Regression4232.D.M : 'U -> int' and 'abstract member Regression4232.D.M : 'T -> int' + let (|A|B|) (x:int) = A x;; -----^^^^^ stdin(833,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) (x:'a) = A x;; -----^^^^^ stdin(836,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) (p:'a) (x:int) = A p;; -----^^^^^ stdin(839,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) = failwith "" : Choice;; -----^^^^^ diff --git a/tests/fsharp/core/printing/z.output.test.quiet.stderr.bsl b/tests/fsharp/core/printing/z.output.test.quiet.stderr.bsl index b4d6c68a7f1..38819190c9d 100644 --- a/tests/fsharp/core/printing/z.output.test.quiet.stderr.bsl +++ b/tests/fsharp/core/printing/z.output.test.quiet.stderr.bsl @@ -268,51 +268,61 @@ stdin(619,21): warning FS1172: Infix operator member '**' has no arguments. Expe stdin(624,17): warning FS0864: This new member hides the abstract member 'System.Object.ToString() : string'. Rename the member or use 'override' instead. + member this.M() = "string" ----------------^ stdin(765,17): error FS0438: Duplicate method. The method 'M' has the same name and signature as another method in this type. + member this.P = "string" ----------------^ stdin(772,17): error FS0438: Duplicate method. The method 'get_P' has the same name and signature as another method in this type. + type public IBPublic = interface inherit IAPrivate abstract Q : int end ------------------^^^^^^^^ stdin(779,19): error FS0410: The type 'IAPrivate' is less accessible than the value, member or type 'IBPublic' it is used in. + type internal IBInternal = interface inherit IAPrivate abstract Q : int end ------------------^^^^^^^^^^ stdin(784,19): error FS0410: The type 'IAPrivate' is less accessible than the value, member or type 'IBInternal' it is used in. + type public IBPublic = interface inherit IAInternal abstract Q : int end ------------------^^^^^^^^ stdin(793,19): error FS0410: The type 'IAInternal' is less accessible than the value, member or type 'IBPublic' it is used in. + override x.M(a:string) = 1 -------------------^ stdin(825,20): error FS0361: The override 'M : string -> int' implements more than one abstract slot, e.g. 'abstract member Regression4232.D.M : 'U -> int' and 'abstract member Regression4232.D.M : 'T -> int' + let (|A|B|) (x:int) = A x;; -----^^^^^ stdin(833,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) (x:'a) = A x;; -----^^^^^ stdin(836,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) (p:'a) (x:int) = A p;; -----^^^^^ stdin(839,6): error FS1210: Active pattern '|A|B|' has a result type containing type variables that are not determined by the input. The common cause is a when a result case is not mentioned, e.g. 'let (|A|B|) (x:int) = A x'. This can be fixed with a type constraint, e.g. 'let (|A|B|) (x:int) : Choice = A x' + let (|A|B|) = failwith "" : Choice;; -----^^^^^ diff --git a/tests/service/CSharpProjectAnalysis.fs b/tests/service/CSharpProjectAnalysis.fs new file mode 100644 index 00000000000..e6df8a73b0c --- /dev/null +++ b/tests/service/CSharpProjectAnalysis.fs @@ -0,0 +1,115 @@ + +#if INTERACTIVE +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../bin/v4.5/CSharp_Analysis.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" +#load "FsUnit.fs" +#load "Common.fs" +#else +module FSharp.Compiler.Service.Tests.CSharpProjectAnalysis +#endif + + +open NUnit.Framework +open FsUnit +open System +open System.IO +open System.Collections.Generic + +open Microsoft.FSharp.Compiler +open FSharp.Compiler.Service.Tests +open Microsoft.FSharp.Compiler.SourceCodeServices + +open FSharp.Compiler.Service.Tests.Common + +let internal getProjectReferences (content, dllFiles, libDirs, otherFlags) = + let otherFlags = defaultArg otherFlags [] + let libDirs = defaultArg libDirs [] + let base1 = Path.GetTempFileName() + let dllName = Path.ChangeExtension(base1, ".dll") + let fileName1 = Path.ChangeExtension(base1, ".fs") + let projFileName = Path.ChangeExtension(base1, ".fsproj") + File.WriteAllText(fileName1, content) + let options = + checker.GetProjectOptionsFromCommandLineArgs(projFileName, + [| yield "--debug:full" + yield "--define:DEBUG" + yield "--optimize-" + yield "--out:" + dllName + yield "--doc:test.xml" + yield "--warn:3" + yield "--fullpaths" + yield "--flaterrors" + yield "--target:library" + for dllFile in dllFiles do + yield "-r:"+dllFile + for libDir in libDirs do + yield "-I:"+libDir + yield! otherFlags + yield fileName1 |]) + let results = checker.ParseAndCheckProject(options) |> Async.RunSynchronously + if results.HasCriticalErrors then + let builder = new System.Text.StringBuilder() + for err in results.Errors do + builder.AppendLine(sprintf "**** %s: %s" (if err.Severity = FSharpErrorSeverity.Error then "error" else "warning") err.Message) + |> ignore + failwith (builder.ToString()) + let assemblies = + results.ProjectContext.GetReferencedAssemblies() + |> List.map(fun x -> x.SimpleName, x) + |> dict + results, assemblies + +[] +let ``Test that csharp references are recognized as such`` () = + let csharpAssembly = PathRelativeToTestAssembly "CSharp_Analysis.dll" + let _, table = getProjectReferences("""module M""", [csharpAssembly], None, None) + let ass = table.["CSharp_Analysis"] + let search = ass.Contents.Entities |> Seq.tryFind (fun e -> e.DisplayName = "CSharpClass") + Assert.True search.IsSome + let found = search.Value + // this is no F# thing + found.IsFSharp |> shouldEqual false + + // Check that we have members + let members = found.MembersFunctionsAndValues |> Seq.map (fun e -> e.CompiledName, e) |> dict + members.ContainsKey ".ctor" |> shouldEqual true + members.ContainsKey "Method" |> shouldEqual true + members.ContainsKey "Property" |> shouldEqual true + members.ContainsKey "Event" |> shouldEqual true + members.ContainsKey "InterfaceMethod" |> shouldEqual true + members.ContainsKey "InterfaceProperty" |> shouldEqual true + members.ContainsKey "InterfaceEvent" |> shouldEqual true + members.["Event"].IsEvent |> shouldEqual true + members.["Event"].EventIsStandard |> shouldEqual true + members.["Event"].EventAddMethod.DisplayName |> shouldEqual "add_Event" + members.["Event"].EventRemoveMethod.DisplayName |> shouldEqual "remove_Event" + members.["Event"].EventDelegateType.ToString() |> shouldEqual "type System.EventHandler" + + //// Check that we get xml docs + members.[".ctor"].XmlDocSig |> shouldEqual "M:FSharp.Compiler.Service.Tests.CSharpClass.#ctor(System.Int32,System.String)" + members.["Method"].XmlDocSig |> shouldEqual "M:FSharp.Compiler.Service.Tests.CSharpClass.Method(System.String)" + members.["Property"].XmlDocSig |> shouldEqual "P:FSharp.Compiler.Service.Tests.CSharpClass.Property" + members.["Event"].XmlDocSig |> shouldEqual "E:FSharp.Compiler.Service.Tests.CSharpClass.Event" + members.["InterfaceMethod"].XmlDocSig |> shouldEqual "M:FSharp.Compiler.Service.Tests.CSharpClass.InterfaceMethod(System.String)" + members.["InterfaceProperty"].XmlDocSig |> shouldEqual "P:FSharp.Compiler.Service.Tests.CSharpClass.InterfaceProperty" + members.["InterfaceEvent"].XmlDocSig |> shouldEqual "E:FSharp.Compiler.Service.Tests.CSharpClass.InterfaceEvent" + +[] +let ``Test that symbols of csharp inner classes/enums are reported`` () = + let csharpAssembly = PathRelativeToTestAssembly "CSharp_Analysis.dll" + let content = """ +module NestedEnumClass +open FSharp.Compiler.Service.Tests + +let _ = CSharpOuterClass.InnerEnum.Case1 +let _ = CSharpOuterClass.InnerClass.StaticMember() +""" + + let results, _ = getProjectReferences(content, [csharpAssembly], None, None) + results.GetAllUsesOfAllSymbols() + |> Async.RunSynchronously + |> Array.map (fun su -> su.Symbol.ToString()) + |> shouldEqual + [|"InnerEnum"; "CSharpOuterClass"; "field Case1"; "InnerClass"; + "CSharpOuterClass"; "member StaticMember"; "NestedEnumClass"|] diff --git a/tests/service/Common.fs b/tests/service/Common.fs index cbc2b79c37e..9896f65b585 100644 --- a/tests/service/Common.fs +++ b/tests/service/Common.fs @@ -1,19 +1,48 @@ -module internal FSharp.Compiler.Service.Tests.Common +module internal FSharp.Compiler.Service.Tests.Common open System.IO open System.Collections.Generic open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.SourceCodeServices -// Create one global interactive checker instance -let checker = FSharpChecker.Create() +#if FX_RESHAPED_REFLECTION +open ReflectionAdapters +#endif -let parseAndCheckScript (file, input) = - let checkOptions, _diagnostics = checker.GetProjectOptionsFromScript(file, input) |> Async.RunSynchronously - let parseResult, typedRes = checker.ParseAndCheckFileInProject(file, 0, input, checkOptions) |> Async.RunSynchronously - match typedRes with - | FSharpCheckFileAnswer.Succeeded(res) -> parseResult, res - | res -> failwithf "Parsing did not finish... (%A)" res +#if DOTNETCORE +let readRefs (folder : string) (projectFile: string) = + let runProcess (workingDir: string) (exePath: string) (args: string) = + let psi = System.Diagnostics.ProcessStartInfo() + psi.FileName <- exePath + psi.WorkingDirectory <- workingDir + psi.RedirectStandardOutput <- false + psi.RedirectStandardError <- false + psi.Arguments <- args + psi.CreateNoWindow <- true + psi.UseShellExecute <- false + + use p = new System.Diagnostics.Process() + p.StartInfo <- psi + p.Start() |> ignore + p.WaitForExit() + + let exitCode = p.ExitCode + exitCode, () + + let runCmd exePath args = runProcess folder exePath (args |> String.concat " ") + let msbuildExec = Dotnet.ProjInfo.Inspect.dotnetMsbuild runCmd + let result = Dotnet.ProjInfo.Inspect.getProjectInfo ignore msbuildExec Dotnet.ProjInfo.Inspect.getFscArgs [] projectFile + match result with + | Ok(Dotnet.ProjInfo.Inspect.GetResult.FscArgs x) -> + x + |> List.filter (fun s -> s.StartsWith("-r:")) + |> List.map (fun s -> s.Replace("-r:", "")) + | _ -> [] +#endif + + +// Create one global interactive checker instance +let checker = FSharpChecker.Create() type TempFile(ext, contents) = let tmpFile = Path.ChangeExtension(System.IO.Path.GetTempFileName() , ext) @@ -37,11 +66,17 @@ let getBackgroundCheckResultsForScriptText (input) = let sysLib nm = +#if !FX_ATLEAST_PORTABLE if System.Environment.OSVersion.Platform = System.PlatformID.Win32NT then // file references only valid on Windows let programFilesx86Folder = System.Environment.GetEnvironmentVariable("PROGRAMFILES(X86)") programFilesx86Folder + @"\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.6.1\" + nm + ".dll" else +#endif +#if FX_NO_RUNTIMEENVIRONMENT + let sysDir = System.AppContext.BaseDirectory +#else let sysDir = System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() +#endif let (++) a b = System.IO.Path.Combine(a,b) sysDir ++ nm + ".dll" @@ -49,22 +84,30 @@ let sysLib nm = module Helpers = open System type DummyType = A | B - let PathRelativeToTestAssembly p = Path.Combine(Path.GetDirectoryName(Uri(typeof.Assembly.CodeBase).LocalPath), p) + let PathRelativeToTestAssembly p = Path.Combine(Path.GetDirectoryName(Uri(typeof.Assembly.CodeBase).LocalPath), p) let fsCoreDefaultReference() = PathRelativeToTestAssembly "FSharp.Core.dll" - // if System.Environment.OSVersion.Platform = System.PlatformID.Win32NT then // file references only valid on Windows - // let programFilesx86Folder = System.Environment.GetEnvironmentVariable("PROGRAMFILES(X86)") - // programFilesx86Folder + @"\Reference Assemblies\Microsoft\FSharp\.NETFramework\v4.0\4.3.0.0\FSharp.Core.dll" - //else - // sysLib "FSharp.Core" +(* +#if !FX_ATLEAST_PORTABLE + if System.Environment.OSVersion.Platform = System.PlatformID.Win32NT then // file references only valid on Windows + let programFilesx86Folder = System.Environment.GetEnvironmentVariable("PROGRAMFILES(X86)") + programFilesx86Folder + @"\Reference Assemblies\Microsoft\FSharp\.NETFramework\v4.0\4.4.0.0\FSharp.Core.dll" + else +#endif + sysLib "FSharp.Core" +*) let mkProjectCommandLineArgs (dllName, fileNames) = + let args = [| yield "--simpleresolution" yield "--noframework" yield "--debug:full" yield "--define:DEBUG" +#if NETCOREAPP1_0 + yield "--targetprofile:netcore" +#endif yield "--optimize-" yield "--out:" + dllName yield "--doc:test.xml" @@ -74,13 +117,85 @@ let mkProjectCommandLineArgs (dllName, fileNames) = yield "--target:library" for x in fileNames do yield x - let references = + let references = +#if DOTNETCORE + let file = "Sample_NETCoreSDK_FSharp_Library_netstandard1.6.fsproj" + let projDir = Path.Combine(__SOURCE_DIRECTORY__, "../projects/Sample_NETCoreSDK_FSharp_Library_netstandard1.6") + readRefs projDir file +#else [ yield sysLib "mscorlib" yield sysLib "System" yield sysLib "System.Core" yield fsCoreDefaultReference() ] +#endif + for r in references do + yield "-r:" + r + |] + printfn "dllName = %A, args = %A" dllName args + args + +#if DOTNETCORE +let mkProjectCommandLineArgsForScript (dllName, fileNames) = + [| yield "--simpleresolution" + yield "--noframework" + yield "--debug:full" + yield "--define:DEBUG" +#if NETCOREAPP1_0 + yield "--targetprofile:netcore" +#endif + yield "--optimize-" + yield "--out:" + dllName + yield "--doc:test.xml" + yield "--warn:3" + yield "--fullpaths" + yield "--flaterrors" + yield "--target:library" + for x in fileNames do + yield x + // let implDir = Path.GetDirectoryName(typeof.Assembly.Location) + let references = + let file = "Sample_NETCoreSDK_FSharp_Library_netstandard1.6.fsproj" + let projDir = Path.Combine(__SOURCE_DIRECTORY__, "../projects/Sample_NETCoreSDK_FSharp_Library_netstandard1.6") + readRefs projDir file for r in references do - yield "-r:" + r |] + yield "-r:" + r + |] +#endif + +let parseAndCheckScript (file, input) = + +#if DOTNETCORE + let dllName = Path.ChangeExtension(file, ".dll") + let projName = Path.ChangeExtension(file, ".fsproj") + let args = mkProjectCommandLineArgsForScript (dllName, [file]) + printfn "file = %A, args = %A" file args + let projectOptions = checker.GetProjectOptionsFromCommandLineArgs (projName, args) + +#else + let projectOptions, _diagnostics = checker.GetProjectOptionsFromScript(file, input) |> Async.RunSynchronously +#endif + + let parseResult, typedRes = checker.ParseAndCheckFileInProject(file, 0, input, projectOptions) |> Async.RunSynchronously + + // if parseResult.Errors.Length > 0 then + // printfn "---> Parse Input = %A" input + // printfn "---> Parse Error = %A" parseResult.Errors + + match typedRes with + | FSharpCheckFileAnswer.Succeeded(res) -> parseResult, res + | res -> failwithf "Parsing did not finish... (%A)" res + +let parseSourceCode (name: string, code: string) = + let location = Path.Combine(Path.GetTempPath(),"test"+string(hash (name, code))) + try Directory.CreateDirectory(location) |> ignore with _ -> () + + let projPath = Path.Combine(location, name + ".fsproj") + let filePath = Path.Combine(location, name + ".fs") + let dllPath = Path.Combine(location, name + ".dll") + let args = mkProjectCommandLineArgs(dllPath, [filePath]) + let options = checker.GetProjectOptionsFromCommandLineArgs(projPath, args) + let parseResults = checker.ParseFileInProject(filePath, code, options) |> Async.RunSynchronously + parseResults.ParseTree /// Extract range info let tups (m:Range.range) = (m.StartLine, m.StartColumn), (m.EndLine, m.EndColumn) @@ -122,10 +237,12 @@ let attribsOfSymbol (s:FSharpSymbol) = if v.IsFSharpUnion then yield "union" if v.IsInterface then yield "interface" if v.IsMeasure then yield "measure" +#if EXTENSIONTYPING if v.IsProvided then yield "provided" if v.IsStaticInstantiation then yield "staticinst" if v.IsProvidedAndErased then yield "erased" if v.IsProvidedAndGenerated then yield "generated" +#endif if v.IsUnresolved then yield "unresolved" if v.IsValueType then yield "valuetype" @@ -177,4 +294,10 @@ let rec allSymbolsInEntities compGen (entities: IList) = yield! allSymbolsInEntities compGen e.NestedEntities ] +let coreLibAssemblyName = +#if DOTNETCORE + "System.Runtime" +#else + "mscorlib" +#endif diff --git a/tests/service/EditorTests.fs b/tests/service/EditorTests.fs index 35c3b809ab1..4c53ea6f96e 100644 --- a/tests/service/EditorTests.fs +++ b/tests/service/EditorTests.fs @@ -19,8 +19,8 @@ // Use F# Interactive. This only works for FSHarp.Compiler.Service.dll which has a public API #if INTERACTIVE -#r "../../Debug/net40/bin/FSharp.LanguageService.Compiler.dll" -#r "../../Debug/net40/bin/nunit.framework.dll" +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" #load "FsUnit.fs" #load "Common.fs" #else @@ -35,11 +35,27 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.SourceCodeServices open FSharp.Compiler.Service.Tests.Common +let stringMethods = +#if DOTNETCORE + ["Chars"; "CompareTo"; "Contains"; "CopyTo"; "EndsWith"; "Equals"; + "GetHashCode"; "GetType"; "IndexOf"; + "IndexOfAny"; "Insert"; "LastIndexOf"; "LastIndexOfAny"; + "Length"; "PadLeft"; "PadRight"; "Remove"; "Replace"; "Split"; + "StartsWith"; "Substring"; "ToCharArray"; "ToLower"; "ToLowerInvariant"; + "ToString"; "ToUpper"; "ToUpperInvariant"; "Trim"; "TrimEnd"; "TrimStart"] +#else + ["Chars"; "Clone"; "CompareTo"; "Contains"; "CopyTo"; "EndsWith"; "Equals"; + "GetEnumerator"; "GetHashCode"; "GetType"; "GetTypeCode"; "IndexOf"; + "IndexOfAny"; "Insert"; "IsNormalized"; "LastIndexOf"; "LastIndexOfAny"; + "Length"; "Normalize"; "PadLeft"; "PadRight"; "Remove"; "Replace"; "Split"; + "StartsWith"; "Substring"; "ToCharArray"; "ToLower"; "ToLowerInvariant"; + "ToString"; "ToUpper"; "ToUpperInvariant"; "Trim"; "TrimEnd"; "TrimStart"] +#endif let input = """ open System - + let foo() = let msg = String.Concat("Hello"," ","world") if true then @@ -54,6 +70,7 @@ let ``Intro test`` () = let file = "/home/user/Test.fsx" let parseResult, typeCheckResults = parseAndCheckScript(file, input) let identToken = FSharpTokenTag.IDENT +// let projectOptions = checker.GetProjectOptionsFromScript(file, input) |> Async.RunSynchronously // We only expect one reported error. However, // on Unix, using filenames like /home/user/Test.fsx gives a second copy of all parse errors due to the @@ -67,16 +84,10 @@ let ``Intro test`` () = // Get tool tip at the specified location let tip = typeCheckResults.GetToolTipTextAlternate(4, 7, inputLines.[1], ["foo"], identToken) |> Async.RunSynchronously + // (sprintf "%A" tip).Replace("\n","") |> shouldEqual """FSharpToolTipText [Single ("val foo : unit -> unitFull name: Test.foo",None)]""" // Get declarations (autocomplete) for a location let decls = typeCheckResults.GetDeclarationListInfo(Some parseResult, 7, 23, inputLines.[6], [], "msg", (fun _ -> []), fun _ -> false)|> Async.RunSynchronously - CollectionAssert.AreEquivalent( - ["Chars"; "Clone"; "CompareTo"; "Contains"; "CopyTo"; "EndsWith"; "Equals"; - "GetEnumerator"; "GetHashCode"; "GetType"; "GetTypeCode"; "IndexOf"; - "IndexOfAny"; "Insert"; "IsNormalized"; "LastIndexOf"; "LastIndexOfAny"; - "Length"; "Normalize"; "PadLeft"; "PadRight"; "Remove"; "Replace"; "Split"; - "StartsWith"; "Substring"; "ToCharArray"; "ToLower"; "ToLowerInvariant"; - "ToString"; "ToUpper"; "ToUpperInvariant"; "Trim"; "TrimEnd"; "TrimStart"], - [ for item in decls.Items -> item.Name ]) + CollectionAssert.AreEquivalent(stringMethods,[ for item in decls.Items -> item.Name ]) // Get overloads of the String.Concat method let methods = typeCheckResults.GetMethodsAlternate(5, 27, inputLines.[4], Some ["String"; "Concat"]) |> Async.RunSynchronously @@ -94,10 +105,13 @@ let ``Intro test`` () = ("Concat", ["str0: string"; "str1: string"]); ("Concat", ["arg0: obj"; "arg1: obj"; "arg2: obj"]); ("Concat", ["str0: string"; "str1: string"; "str2: string"]); +#if !DOTNETCORE ("Concat", ["arg0: obj"; "arg1: obj"; "arg2: obj"; "arg3: obj"]); +#endif ("Concat", ["str0: string"; "str1: string"; "str2: string"; "str3: string"])] +#if !INTERACTIVE && !DOTNETCORE // InternalsVisibleTo on IncrementalBuild.LocallyInjectCancellationFault not working for some reason? [] let ``Basic cancellation test`` () = try @@ -116,6 +130,7 @@ let ``Basic cancellation test`` () = |> ignore Assert.Fail("expected a cancellation") with :? OperationCanceledException -> () +#endif [] let ``GetMethodsAsSymbols should return all overloads of a method as FSharpSymbolUse`` () = @@ -148,7 +163,9 @@ let ``GetMethodsAsSymbols should return all overloads of a method as FSharpSymbo ("Concat", [("str0", "string"); ("str1", "string")]); ("Concat", [("arg0", "obj"); ("arg1", "obj"); ("arg2", "obj")]); ("Concat", [("str0", "string"); ("str1", "string"); ("str2", "string")]); +#if !DOTNETCORE ("Concat", [("arg0", "obj"); ("arg1", "obj"); ("arg2", "obj"); ("arg3", "obj")]); +#endif ("Concat", [("str0", "string"); ("str1", "string"); ("str2", "string"); ("str3", "string")])] | None -> failwith "No symbols returned" @@ -239,7 +256,7 @@ let ``Symbols many tests`` () = let typeCheckContext = typeCheckResults2.ProjectContext - typeCheckContext.GetReferencedAssemblies() |> List.exists (fun s -> s.FileName.Value.Contains("mscorlib")) |> shouldEqual true + typeCheckContext.GetReferencedAssemblies() |> List.exists (fun s -> s.FileName.Value.Contains(coreLibAssemblyName)) |> shouldEqual true let input3 = @@ -268,14 +285,8 @@ let ``Expression typing test`` () = // for col in 42..43 do let decls = typeCheckResults.GetDeclarationListInfo(Some parseResult, 2, col, inputLines.[1], [], "", (fun _ -> []), fun _ -> false)|> Async.RunSynchronously - set [ for item in decls.Items -> item.Name ] |> shouldEqual - (set - ["Chars"; "Clone"; "CompareTo"; "Contains"; "CopyTo"; "EndsWith"; "Equals"; - "GetEnumerator"; "GetHashCode"; "GetType"; "GetTypeCode"; "IndexOf"; - "IndexOfAny"; "Insert"; "IsNormalized"; "LastIndexOf"; "LastIndexOfAny"; - "Length"; "Normalize"; "PadLeft"; "PadRight"; "Remove"; "Replace"; "Split"; - "StartsWith"; "Substring"; "ToCharArray"; "ToLower"; "ToLowerInvariant"; - "ToString"; "ToUpper"; "ToUpperInvariant"; "Trim"; "TrimEnd"; "TrimStart"]) + let autoCompleteSet = set [ for item in decls.Items -> item.Name ] + autoCompleteSet |> shouldEqual (set stringMethods) // The underlying problem is that the parser error recovery doesn't include _any_ information for // the incomplete member: @@ -296,10 +307,6 @@ type Test() = let decls = typeCheckResults.GetDeclarationListInfo(Some parseResult, 4, 21, inputLines.[3], [], "", (fun _ -> []), fun _ -> false)|> Async.RunSynchronously let item = decls.Items |> Array.tryFind (fun d -> d.Name = "abc") - match item with - | Some item -> - printf "%s" item.Name - | _ -> () decls.Items |> Seq.exists (fun d -> d.Name = "abc") |> shouldEqual true [] @@ -317,10 +324,6 @@ type Test() = let decls = typeCheckResults.GetDeclarationListInfo(Some parseResult, 4, 22, inputLines.[3], [], "", (fun _ -> []), fun _ -> false)|> Async.RunSynchronously let item = decls.Items |> Array.tryFind (fun d -> d.Name = "abc") - match item with - | Some item -> - printf "%s" item.Name - | _ -> () decls.Items |> Seq.exists (fun d -> d.Name = "abc") |> shouldEqual true [] @@ -353,12 +356,7 @@ type Test() = let parseResult, typeCheckResults = parseAndCheckScript(file, input) let decls = typeCheckResults.GetDeclarationListSymbols(Some parseResult, 4, 21, inputLines.[3], [], "", fun _ -> false)|> Async.RunSynchronously - let item = decls |> List.tryFind (fun d -> d.Head.Symbol.DisplayName = "abc") - match item with - | Some items -> - for symbolUse in items do - printf "%s" symbolUse.Symbol.DisplayName - | _ -> () + //decls |> List.map (fun d -> d.Head.Symbol.DisplayName) |> printfn "---> decls = %A" decls |> Seq.exists (fun d -> d.Head.Symbol.DisplayName = "abc") |> shouldEqual true [] @@ -375,14 +373,8 @@ type Test() = let parseResult, typeCheckResults = parseAndCheckScript(file, input) let decls = typeCheckResults.GetDeclarationListSymbols(Some parseResult, 4, 22, inputLines.[3], [], "", fun _ -> false)|> Async.RunSynchronously - let item = decls |> List.tryFind (fun d -> d.Head.Symbol.DisplayName = "abc") - match item with - | Some items -> - for symbolUse in items do - printf "%s" symbolUse.Symbol.DisplayName - | _ -> () + //decls |> List.map (fun d -> d.Head.Symbol.DisplayName) |> printfn "---> decls = %A" decls |> Seq.exists (fun d -> d.Head.Symbol.DisplayName = "abc") |> shouldEqual true - true |> should equal true [] let ``Symbol based find function from var`` () = @@ -398,16 +390,17 @@ type Test() = let parseResult, typeCheckResults = parseAndCheckScript(file, input) let decls = typeCheckResults.GetDeclarationListSymbols(Some parseResult, 4, 15, inputLines.[3], [], "", fun _ -> false)|> Async.RunSynchronously - decls|> Seq .exists (fun d -> d.Head.Symbol.DisplayName = "abc") |> shouldEqual true + //decls |> List.map (fun d -> d.Head.Symbol.DisplayName) |> printfn "---> decls = %A" + decls |> Seq.exists (fun d -> d.Head.Symbol.DisplayName = "abc") |> shouldEqual true [] let ``Printf specifiers for regular and verbatim strings`` () = let input = - """ + """let os = System.Text.StringBuilder() let _ = Microsoft.FSharp.Core.Printf.printf "%A" 0 let _ = Printf.printf "%A" 0 let _ = Printf.kprintf (fun _ -> ()) "%A" 1 -let _ = Printf.bprintf null "%A" 1 +let _ = Printf.bprintf os "%A" 1 let _ = sprintf "%*d" 1 let _ = sprintf "%7.1f" 1.0 let _ = sprintf "%-8.1e+567" 1.0 @@ -423,30 +416,40 @@ let _ = List.map (sprintf @"%A let _ = (10, 12) ||> sprintf "%A %O" let _ = sprintf "\n%-8.1e+567" 1.0 -let _ = sprintf @"%O\n%-5s" "1" "2" """ +let _ = sprintf @"%O\n%-5s" "1" "2" +let _ = sprintf "%%" +let _ = sprintf " %*%" 2 +let _ = sprintf " %.*%" 2 +let _ = sprintf " %*.1%" 2 +let _ = sprintf " %*s" 10 "hello" +let _ = sprintf " %*.*%" 2 3 +let _ = sprintf " %*.*f" 2 3 4.5 +let _ = sprintf " %.*f" 3 4.5 +let _ = sprintf " %*.1f" 3 4.5 +let _ = sprintf " %6.*f" 3 4.5 +let _ = sprintf " %6.*%" 3 +let _ = printf " %a" (fun _ _ -> ()) 2 +let _ = printf " %*a" 3 (fun _ _ -> ()) 2 +""" let file = "/home/user/Test.fsx" let parseResult, typeCheckResults = parseAndCheckScript(file, input) typeCheckResults.Errors |> shouldEqual [||] - typeCheckResults.GetFormatSpecifierLocations() - |> Array.map (fun range -> range.StartLine, range.StartColumn, range.EndLine, range.EndColumn) - |> shouldEqual [|(2, 45, 2, 47); - (3, 23, 3, 25); - (4, 38, 4, 40); - (5, 29, 5, 31); - (6, 17, 6, 20); - (7, 17, 7, 22); - (8, 17, 8, 23); - (9, 18, 9, 22); - (10, 18, 10, 21); - (12, 12, 12, 15); - (15, 12, 15, 15); - (16, 28, 16, 30); - (18, 30, 18, 32); - (19, 30, 19, 32); - (20, 19, 20, 25); - (21, 18, 21, 20); (21, 22, 21, 26)|] + typeCheckResults.GetFormatSpecifierLocationsAndArity() + |> Array.map (fun (range,numArgs) -> range.StartLine, range.StartColumn, range.EndLine, range.EndColumn, numArgs) + |> shouldEqual + [|(2, 45, 2, 47, 1); (3, 23, 3, 25, 1); (4, 38, 4, 40, 1); (5, 27, 5, 29 +, 1); + (6, 17, 6, 20, 2); (7, 17, 7, 22, 1); (8, 17, 8, 23, 1); (9, 18, 9, 22, 1); + (10, 18, 10, 21, 1); (12, 12, 12, 15, 1); (15, 12, 15, 15, 1); + (16, 28, 16, 30, 1); (18, 30, 18, 32, 1); (19, 30, 19, 32, 1); + (20, 19, 20, 25, 1); (21, 18, 21, 20, 1); (21, 22, 21, 26, 1); + (22, 17, 22, 19, 0); (23, 18, 23, 21, 1); (24, 19, 24, 23, 1); + (25, 20, 25, 25, 1); (26, 21, 26, 24, 2); (27, 22, 27, 27, 2); + (28, 23, 28, 28, 3); (29, 24, 29, 28, 2); (30, 25, 30, 30, 2); + (31, 26, 31, 31, 2); (32, 27, 32, 32, 1); (33, 28, 33, 30, 2); + (34, 29, 34, 32, 3)|] [] let ``Printf specifiers for triple-quote strings`` () = @@ -464,12 +467,13 @@ let _ = List.iter(printfn \"\"\"%-A let parseResult, typeCheckResults = parseAndCheckScript(file, input) typeCheckResults.Errors |> shouldEqual [||] - typeCheckResults.GetFormatSpecifierLocations() - |> Array.map (fun range -> range.StartLine, range.StartColumn, range.EndLine, range.EndColumn) - |> shouldEqual [|(2, 19, 2, 22); - (4, 12, 4, 15); - (6, 29, 6, 32); - (7, 29, 7, 31); (7, 33, 7, 35)|] + typeCheckResults.GetFormatSpecifierLocationsAndArity() + |> Array.map (fun (range,numArgs) -> range.StartLine, range.StartColumn, range.EndLine, range.EndColumn, numArgs) + |> shouldEqual [|(2, 19, 2, 22, 1); + (4, 12, 4, 15, 1); + (6, 29, 6, 32, 1); + (7, 29, 7, 31, 1); + (7, 33, 7, 35,1 )|] [] let ``Printf specifiers for user-defined functions`` () = @@ -484,25 +488,27 @@ let _ = debug "[LanguageService] Type checking fails for '%s' with content=%A an let parseResult, typeCheckResults = parseAndCheckScript(file, input) typeCheckResults.Errors |> shouldEqual [||] - typeCheckResults.GetFormatSpecifierLocations() - |> Array.map (fun range -> range.StartLine, range.StartColumn, range.EndLine, range.EndColumn) - |> shouldEqual [|(3, 24, 3, 26); - (3, 29, 3, 31); - (4, 58, 4, 60); (4, 75, 4, 77); (4, 82, 4, 84); (4, 108, 4, 110)|] + typeCheckResults.GetFormatSpecifierLocationsAndArity() + |> Array.map (fun (range, numArgs) -> range.StartLine, range.StartColumn, range.EndLine, range.EndColumn, numArgs) + |> shouldEqual [|(3, 24, 3, 26, 1); + (3, 29, 3, 31, 1); + (4, 58, 4, 60, 1); + (4, 75, 4, 77, 1); + (4, 82, 4, 84, 1); + (4, 108, 4, 110, 1)|] [] let ``should not report format specifiers for illformed format strings`` () = let input = """ let _ = sprintf "%.7f %7.1A %7.f %--8.1f" -let _ = sprintf "%%A" let _ = sprintf "ABCDE" """ let file = "/home/user/Test.fsx" let parseResult, typeCheckResults = parseAndCheckScript(file, input) - typeCheckResults.GetFormatSpecifierLocations() - |> Array.map (fun range -> range.StartLine, range.StartColumn, range.EndLine, range.EndColumn) + typeCheckResults.GetFormatSpecifierLocationsAndArity() + |> Array.map (fun (range, numArgs) -> range.StartLine, range.StartColumn, range.EndLine, range.EndColumn, numArgs) |> shouldEqual [||] [] @@ -558,10 +564,61 @@ let _ = arr.[..number2] ("val number2", (5, 15, 5, 22)); ("Test", (1, 0, 1, 0))|] + +[] +let ``Enums should have fields`` () = + let input = """ +type EnumTest = One = 1 | Two = 2 | Three = 3 +let test = EnumTest.One +let test2 = System.StringComparison.CurrentCulture +let test3 = System.Text.RegularExpressions.RegexOptions.Compiled +""" + let file = "/home/user/Test.fsx" + let parseResult, typeCheckResults = parseAndCheckScript(file, input) + let allSymbols = typeCheckResults.GetAllUsesOfAllSymbolsInFile() |> Async.RunSynchronously + let enums = + allSymbols + |> Array.choose(fun s -> match s.Symbol with :? FSharpEntity as e when e.IsEnum -> Some e | _ -> None) + |> Array.distinct + |> Array.map(fun e -> (e.DisplayName, e.FSharpFields + |> Seq.map(fun f -> f.Name, f.LiteralValue ) + |> Seq.toList)) + + enums |> shouldEqual + [| "EnumTest", [ ("value__", None) + ("One", Some (box 1)) + ("Two", Some (box 2)) + ("Three", Some (box 3)) + ] + "StringComparison", [ ("value__", None) + ("CurrentCulture", Some (box 0)) + ("CurrentCultureIgnoreCase", Some (box 1)) + ("InvariantCulture", Some (box 2)) + ("InvariantCultureIgnoreCase", Some (box 3)) + ("Ordinal", Some (box 4)) + ("OrdinalIgnoreCase", Some (box 5)) + ] + "RegexOptions", [ ("value__", None) + ("None", Some (box 0)) + ("IgnoreCase", Some (box 1)) + ("Multiline", Some (box 2)) + ("ExplicitCapture", Some (box 4)) + ("Compiled", Some (box 8)) + ("Singleline", Some (box 16)) + ("IgnorePatternWhitespace", Some (box 32)) + ("RightToLeft", Some (box 64)) + ("ECMAScript", Some (box 256)) + ("CultureInvariant", Some (box 512)) + ] + |] + + + //------------------------------------------------------------------------------- -module TPProject = +#if TEST_TP_PROJECTS +module internal TPProject = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -590,7 +647,7 @@ let _ = RegexTypedStatic.IsMatch<"ABC" >( (*$*) ) // TEST: no assert on Ctrl-sp let fileLines1 = File.ReadAllLines(fileName1) let fileNames = [fileName1] let args = Array.append (mkProjectCommandLineArgs (dllName, fileNames)) [| "-r:" + PathRelativeToTestAssembly(@"UnitTests\MockTypeProviders\DummyProviderForLanguageServiceTesting.dll") |] - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) let cleanFileName a = if a = fileName1 then "file1" else "??" [] @@ -733,6 +790,8 @@ let ``Test TPProject param info`` () = (14,[(["RegexTypedStatic.IsMatch,pattern1=\"ABC\"(input: string) : bool"], true,["input"], ["pattern1"])]); (15, [(["RegexTypedStatic.IsMatch() : int"], true, [], ["pattern1"])])] +#endif // TEST_TP_PROJECTS + #if EXE ``Intro test`` () diff --git a/tests/service/ExprTests.fs b/tests/service/ExprTests.fs new file mode 100644 index 00000000000..58f1c39e09e --- /dev/null +++ b/tests/service/ExprTests.fs @@ -0,0 +1,1177 @@ + +#if INTERACTIVE +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../Debug/net40/bin/FSharp.Compiler.Service.ProjectCracker.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" +#load "FsUnit.fs" +#load "Common.fs" +#else +module FSharp.Compiler.Service.Tests.ExprTests +#endif + + +open NUnit.Framework +open FsUnit +open System +open System.IO +open System.Collections.Generic +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.SourceCodeServices +open FSharp.Compiler.Service +open FSharp.Compiler.Service.Tests.Common + +// Create an interactive checker instance +let internal checker = FSharpChecker.Create(keepAssemblyContents=true) + + +[] +module internal Utils = + let rec printExpr low (e:FSharpExpr) = + match e with + | BasicPatterns.AddressOf(e1) -> "&"+printExpr 0 e1 + | BasicPatterns.AddressSet(e1,e2) -> printExpr 0 e1 + " <- " + printExpr 0 e2 + | BasicPatterns.Application(f,tyargs,args) -> quote low (printExpr 10 f + printTyargs tyargs + " " + printCurriedArgs args) + | BasicPatterns.BaseValue(_) -> "base" + | BasicPatterns.Call(Some obj,v,tyargs1,tyargs2,argsL) -> printObjOpt (Some obj) + v.CompiledName + printTyargs tyargs2 + printTupledArgs argsL + | BasicPatterns.Call(None,v,tyargs1,tyargs2,argsL) -> v.EnclosingEntity.CompiledName + printTyargs tyargs1 + "." + v.CompiledName + printTyargs tyargs2 + " " + printTupledArgs argsL + | BasicPatterns.Coerce(ty1,e1) -> quote low (printExpr 10 e1 + " :> " + printTy ty1) + | BasicPatterns.DefaultValue(ty1) -> "dflt" + | BasicPatterns.FastIntegerForLoop _ -> "for-loop" + | BasicPatterns.ILAsm(s,tyargs,args) -> s + printTupledArgs args + | BasicPatterns.ILFieldGet _ -> "ILFieldGet" + | BasicPatterns.ILFieldSet _ -> "ILFieldSet" + | BasicPatterns.IfThenElse (a,b,c) -> "(if " + printExpr 0 a + " then " + printExpr 0 b + " else " + printExpr 0 c + ")" + | BasicPatterns.Lambda(v,e1) -> "fun " + v.CompiledName + " -> " + printExpr 0 e1 + | BasicPatterns.Let((v,e1),b) -> "let " + (if v.IsMutable then "mutable " else "") + v.CompiledName + ": " + printTy v.FullType + " = " + printExpr 0 e1 + " in " + printExpr 0 b + | BasicPatterns.LetRec(vse,b) -> "let rec ... in " + printExpr 0 b + | BasicPatterns.NewArray(ty,es) -> "[|" + (es |> Seq.map (printExpr 0) |> String.concat "; ") + "|]" + | BasicPatterns.NewDelegate(ty,es) -> "new-delegate" + | BasicPatterns.NewObject(v,tys,args) -> "new " + v.EnclosingEntity.CompiledName + printTupledArgs args + | BasicPatterns.NewRecord(v,args) -> + let fields = v.TypeDefinition.FSharpFields + "{" + ((fields, args) ||> Seq.map2 (fun f a -> f.Name + " = " + printExpr 0 a) |> String.concat "; ") + "}" + | BasicPatterns.NewTuple(v,args) -> printTupledArgs args + | BasicPatterns.NewUnionCase(ty,uc,args) -> uc.CompiledName + printTupledArgs args + | BasicPatterns.Quote(e1) -> "quote" + printTupledArgs [e1] + | BasicPatterns.FSharpFieldGet(obj, ty,f) -> printObjOpt obj + f.Name + | BasicPatterns.FSharpFieldSet(obj, ty,f,arg) -> printObjOpt obj + f.Name + " <- " + printExpr 0 arg + | BasicPatterns.Sequential(e1,e2) -> "(" + printExpr 0 e1 + "; " + printExpr 0 e2 + ")" + | BasicPatterns.ThisValue _ -> "this" + | BasicPatterns.TryFinally(e1,e2) -> "try " + printExpr 0 e1 + " finally " + printExpr 0 e2 + | BasicPatterns.TryWith(e1,_,_,vC,eC) -> "try " + printExpr 0 e1 + " with " + vC.CompiledName + " -> " + printExpr 0 eC + | BasicPatterns.TupleGet(ty,n,e1) -> printExpr 10 e1 + ".Item" + string n + | BasicPatterns.DecisionTree(dtree,targets) -> "match " + printExpr 10 dtree + " targets ..." + | BasicPatterns.DecisionTreeSuccess (tg,es) -> "$" + string tg + | BasicPatterns.TypeLambda(gp1,e1) -> "FUN ... -> " + printExpr 0 e1 + | BasicPatterns.TypeTest(ty,e1) -> printExpr 10 e1 + " :? " + printTy ty + | BasicPatterns.UnionCaseSet(obj,ty,uc,f1,e1) -> printExpr 10 obj + "." + f1.Name + " <- " + printExpr 0 e1 + | BasicPatterns.UnionCaseGet(obj,ty,uc,f1) -> printExpr 10 obj + "." + f1.Name + | BasicPatterns.UnionCaseTest(obj,ty,f1) -> printExpr 10 obj + ".Is" + f1.Name + | BasicPatterns.UnionCaseTag(obj,ty) -> printExpr 10 obj + ".Tag" + | BasicPatterns.ObjectExpr(ty,basecall,overrides,iimpls) -> "{ " + printExpr 10 basecall + " with " + printOverrides overrides + " " + printIimpls iimpls + " }" + | BasicPatterns.TraitCall(tys,nm,_,argtys,tinst,args) -> "trait call " + nm + printTupledArgs args + | BasicPatterns.Const(obj,ty) -> + match obj with + | :? string as s -> "\"" + s + "\"" + | null -> "()" + | _ -> string obj + | BasicPatterns.Value(v) -> v.CompiledName + | BasicPatterns.ValueSet(v,e1) -> quote low (v.CompiledName + " <- " + printExpr 0 e1) + | BasicPatterns.WhileLoop(e1,e2) -> "while " + printExpr 0 e1 + " do " + printExpr 0 e2 + " done" + | _ -> failwith (sprintf "unrecognized %+A" e) + + and quote low s = if low > 0 then "(" + s + ")" else s + and printObjOpt e = match e with None -> "" | Some e -> printExpr 10 e + "." + and printTupledArgs args = "(" + String.concat "," (List.map (printExpr 0) args) + ")" + and printCurriedArgs args = String.concat " " (List.map (printExpr 10) args) + and printParams (vs: FSharpMemberOrFunctionOrValue list) = "(" + String.concat "," (vs |> List.map (fun v -> v.CompiledName)) + ")" + and printCurriedParams (vs: FSharpMemberOrFunctionOrValue list list) = String.concat " " (List.map printParams vs) + and printTy ty = ty.Format(FSharpDisplayContext.Empty) + and printTyargs tyargs = match tyargs with [] -> "" | args -> "<" + String.concat "," (List.map printTy tyargs) + ">" + and printOverrides ors = String.concat ";" (List.map printOverride ors) + and printOverride o = + match o.CurriedParameterGroups with + | [t] :: a -> + "member " + t.CompiledName + "." + o.Signature.Name + printCurriedParams a + " = " + printExpr 10 o.Body + | _ -> failwith "wrong this argument in object expression override" + and printIimpls iis = String.concat ";" (List.map printImlementation iis) + and printImlementation (i, ors) = "interface " + printTy i + " with " + printOverrides ors + + let rec printDeclaration (excludes:HashSet<_> option) (d: FSharpImplementationFileDeclaration) = + seq { + match d with + | FSharpImplementationFileDeclaration.Entity(e,ds) -> + yield sprintf "type %s" e.LogicalName + yield! printDeclarations excludes ds + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(v,vs,e) -> + + if not v.IsCompilerGenerated && + not (match excludes with None -> false | Some t -> t.Contains v.CompiledName) then + let text = + //printfn "%s" v.CompiledName +// try + if v.IsMember then + sprintf "member %s%s = %s @ %s" v.CompiledName (printCurriedParams vs) (printExpr 0 e) (e.Range.ToShortString()) + else + sprintf "let %s%s = %s @ %s" v.CompiledName (printCurriedParams vs) (printExpr 0 e) (e.Range.ToShortString()) +// with e -> +// printfn "FAILURE STACK: %A" e +// sprintf "!!!!!!!!!! FAILED on %s @ %s, message: %s" v.CompiledName (v.DeclarationLocation.ToString()) e.Message + yield text + | FSharpImplementationFileDeclaration.InitAction(e) -> + yield sprintf "do %s" (printExpr 0 e) } + and printDeclarations excludes ds = + seq { for d in ds do + yield! printDeclaration excludes d } + + let rec exprsOfDecl (d: FSharpImplementationFileDeclaration) = + seq { + match d with + | FSharpImplementationFileDeclaration.Entity(e,ds) -> + yield! exprsOfDecls ds + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(v,vs,e) -> + if not v.IsCompilerGenerated then + yield e, e.Range + | FSharpImplementationFileDeclaration.InitAction(e) -> + yield e, e.Range } + and exprsOfDecls ds = + seq { for d in ds do + yield! exprsOfDecl d } + + let printGenericConstraint name (p: FSharpGenericParameterConstraint) = + if p.IsCoercesToConstraint then + Some <| name + " :> " + printTy p.CoercesToTarget + elif p.IsComparisonConstraint then + Some <| name + " : comparison" + elif p.IsEqualityConstraint then + Some <| name + " : equality" + elif p.IsReferenceTypeConstraint then + Some <| name + " : class" + elif p.IsNonNullableValueTypeConstraint then + Some <| name + " : struct" + elif p.IsEnumConstraint then + Some <| name + " : enum" + elif p.IsSupportsNullConstraint then + Some <| name + " : null" + else None + + let printGenericParameter (p: FSharpGenericParameter) = + let name = + if p.Name.StartsWith "?" then "_" + elif p.IsSolveAtCompileTime then "^" + p.Name + else "'" + p.Name + let constraints = + p.Constraints |> Seq.choose (printGenericConstraint name) |> List.ofSeq + name, constraints + + let printMemberSignature (v: FSharpMemberOrFunctionOrValue) = + let genParams = + let ps = v.GenericParameters |> Seq.map printGenericParameter |> List.ofSeq + if List.isEmpty ps then "" else + let constraints = ps |> List.collect snd + "<" + (ps |> Seq.map fst |> String.concat ", ") + + (if List.isEmpty constraints then "" else " when " + String.concat " and " constraints) + ">" + + v.CompiledName + genParams + ": " + printTy v.FullType + + let rec collectMembers (e:FSharpExpr) = + match e with + | BasicPatterns.AddressOf(e) -> collectMembers e + | BasicPatterns.AddressSet(e1,e2) -> Seq.append (collectMembers e1) (collectMembers e2) + | BasicPatterns.Application(f,_,args) -> Seq.append (collectMembers f) (Seq.collect collectMembers args) + | BasicPatterns.BaseValue(_) -> Seq.empty + | BasicPatterns.Call(Some obj,v,_,_,argsL) -> Seq.concat [ collectMembers obj; Seq.singleton v; Seq.collect collectMembers argsL ] + | BasicPatterns.Call(None,v,_,_,argsL) -> Seq.concat [ Seq.singleton v; Seq.collect collectMembers argsL ] + | BasicPatterns.Coerce(_,e) -> collectMembers e + | BasicPatterns.DefaultValue(_) -> Seq.empty + | BasicPatterns.FastIntegerForLoop (fromArg, toArg, body, _) -> Seq.collect collectMembers [ fromArg; toArg; body ] + | BasicPatterns.ILAsm(_,_,args) -> Seq.collect collectMembers args + | BasicPatterns.ILFieldGet (Some e,_,_) -> collectMembers e + | BasicPatterns.ILFieldGet _ -> Seq.empty + | BasicPatterns.ILFieldSet (Some e,_,_,v) -> Seq.append (collectMembers e) (collectMembers v) + | BasicPatterns.ILFieldSet _ -> Seq.empty + | BasicPatterns.IfThenElse (a,b,c) -> Seq.collect collectMembers [ a; b; c ] + | BasicPatterns.Lambda(v,e1) -> collectMembers e1 + | BasicPatterns.Let((v,e1),b) -> Seq.append (collectMembers e1) (collectMembers b) + | BasicPatterns.LetRec(vse,b) -> Seq.append (vse |> Seq.collect (snd >> collectMembers)) (collectMembers b) + | BasicPatterns.NewArray(_,es) -> Seq.collect collectMembers es + | BasicPatterns.NewDelegate(ty,es) -> collectMembers es + | BasicPatterns.NewObject(v,tys,args) -> Seq.append (Seq.singleton v) (Seq.collect collectMembers args) + | BasicPatterns.NewRecord(v,args) -> Seq.collect collectMembers args + | BasicPatterns.NewTuple(v,args) -> Seq.collect collectMembers args + | BasicPatterns.NewUnionCase(ty,uc,args) -> Seq.collect collectMembers args + | BasicPatterns.Quote(e1) -> collectMembers e1 + | BasicPatterns.FSharpFieldGet(Some obj, _,_) -> collectMembers obj + | BasicPatterns.FSharpFieldGet _ -> Seq.empty + | BasicPatterns.FSharpFieldSet(Some obj,_,_,arg) -> Seq.append (collectMembers obj) (collectMembers arg) + | BasicPatterns.FSharpFieldSet(None,_,_,arg) -> collectMembers arg + | BasicPatterns.Sequential(e1,e2) -> Seq.append (collectMembers e1) (collectMembers e2) + | BasicPatterns.ThisValue _ -> Seq.empty + | BasicPatterns.TryFinally(e1,e2) -> Seq.append (collectMembers e1) (collectMembers e2) + | BasicPatterns.TryWith(e1,_,f,_,eC) -> Seq.collect collectMembers [ e1; f; eC ] + | BasicPatterns.TupleGet(ty,n,e1) -> collectMembers e1 + | BasicPatterns.DecisionTree(dtree,targets) -> Seq.append (collectMembers dtree) (targets |> Seq.collect (snd >> collectMembers)) + | BasicPatterns.DecisionTreeSuccess (tg,es) -> Seq.collect collectMembers es + | BasicPatterns.TypeLambda(gp1,e1) -> collectMembers e1 + | BasicPatterns.TypeTest(ty,e1) -> collectMembers e1 + | BasicPatterns.UnionCaseSet(obj,ty,uc,f1,e1) -> Seq.append (collectMembers obj) (collectMembers e1) + | BasicPatterns.UnionCaseGet(obj,ty,uc,f1) -> collectMembers obj + | BasicPatterns.UnionCaseTest(obj,ty,f1) -> collectMembers obj + | BasicPatterns.UnionCaseTag(obj,ty) -> collectMembers obj + | BasicPatterns.ObjectExpr(ty,basecall,overrides,iimpls) -> + seq { + yield! collectMembers basecall + for o in overrides do + yield! collectMembers o.Body + for _, i in iimpls do + for o in i do + yield! collectMembers o.Body + } + | BasicPatterns.TraitCall(tys,nm,_,argtys,tinst,args) -> Seq.collect collectMembers args + | BasicPatterns.Const(obj,ty) -> Seq.empty + | BasicPatterns.Value(v) -> Seq.singleton v + | BasicPatterns.ValueSet(v,e1) -> Seq.append (Seq.singleton v) (collectMembers e1) + | BasicPatterns.WhileLoop(e1,e2) -> Seq.append (collectMembers e1) (collectMembers e2) + | _ -> failwith (sprintf "unrecognized %+A" e) + + let rec printMembersOfDeclatations ds = + seq { + for d in ds do + match d with + | FSharpImplementationFileDeclaration.Entity(_,ds) -> + yield! printMembersOfDeclatations ds + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(v,vs,e) -> + yield printMemberSignature v + yield! collectMembers e |> Seq.map printMemberSignature + | FSharpImplementationFileDeclaration.InitAction(e) -> + yield! collectMembers e |> Seq.map printMemberSignature + } + + +//--------------------------------------------------------------------------------------------------------- +// This project is a smoke test for a whole range of standard and obscure expressions + +module internal Project1 = + open System.IO + + let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") + let base2 = Path.GetTempFileName() + let fileName2 = Path.ChangeExtension(base2, ".fs") + let dllName = Path.ChangeExtension(base2, ".dll") + let projFileName = Path.ChangeExtension(base2, ".fsproj") + let fileSource1 = """ +module M + +type IntAbbrev = int + +let boolEx1 = true +let intEx1 = 1 +let int64Ex1 = 1L +let tupleEx1 = (1, 1L) +let tupleEx2 = (1, 1L, 1u) +let tupleEx3 = (1, 1L, 1u, 1s) + +let localExample = + let y = 1 + let z = 1 + y, z + +let localGenericFunctionExample() = + let y = 1 + let compiledAsLocalGenericFunction x = x + compiledAsLocalGenericFunction y, compiledAsLocalGenericFunction 1.0 + +let funcEx1 (x:int) = x +let genericFuncEx1 (x:'T) = x +let (topPair1a, topPair1b) = (1,2) +let tyfuncEx1<'T> = typeof<'T> +let testILCall1 = new obj() +let testILCall2 = System.Console.WriteLine("176") + +// Test recursive values in a module +let rec recValNeverUsedAtRuntime = recFuncIgnoresFirstArg (fun _ -> recValNeverUsedAtRuntime) 1 +and recFuncIgnoresFirstArg g v = v + +let testFun4() = + // Test recursive values in expression position + let rec recValNeverUsedAtRuntime = recFuncIgnoresFirstArg (fun _ -> recValNeverUsedAtRuntime) 1 + and recFuncIgnoresFirstArg g v = v + + recValNeverUsedAtRuntime + +type ClassWithImplicitConstructor(compiledAsArg: int) = + inherit obj() + let compiledAsField = 1 + let compiledAsLocal = 1 + let compiledAsLocal2 = compiledAsLocal + compiledAsLocal + let compiledAsInstanceMethod () = compiledAsField + compiledAsField + let compiledAsGenericInstanceMethod x = x + + static let compiledAsStaticField = 1 + static let compiledAsStaticLocal = 1 + static let compiledAsStaticLocal2 = compiledAsStaticLocal + compiledAsStaticLocal + static let compiledAsStaticMethod () = compiledAsStaticField + compiledAsStaticField + static let compiledAsGenericStaticMethod x = x + + member __.M1() = compiledAsField + compiledAsGenericInstanceMethod compiledAsField + compiledAsArg + member __.M2() = compiledAsInstanceMethod() + static member SM1() = compiledAsStaticField + compiledAsGenericStaticMethod compiledAsStaticField + static member SM2() = compiledAsStaticMethod() + override __.ToString() = base.ToString() + string 999 + member this.TestCallinToString() = this.ToString() + +exception Error of int * int + +let err = Error(3,4) + +let matchOnException err = match err with Error(a,b) -> 3 | e -> raise e + +let upwardForLoop () = + let mutable a = 1 + for i in 0 .. 10 do a <- a + 1 + a + +let upwardForLoop2 () = + let mutable a = 1 + for i = 0 to 10 do a <- a + 1 + a + +let downwardForLoop () = + let mutable a = 1 + for i = 10 downto 1 do a <- a + 1 + a + +let quotationTest1() = <@ 1 + 1 @> +let quotationTest2 v = <@ %v + 1 @> + +type RecdType = { Field1: int; Field2: int } +type UnionType = Case1 of int | Case2 | Case3 of int * string + +type ClassWithEventsAndProperties() = + let ev = new Event<_>() + static let sev = new Event<_>() + member x.InstanceProperty = ev.Trigger(1); 1 + static member StaticProperty = sev.Trigger(1); 1 + member x.InstanceEvent = ev.Publish + member x.StaticEvent = sev.Publish + +let c = ClassWithEventsAndProperties() +let v = c.InstanceProperty + +System.Console.WriteLine("777") // do a top-levl action + +let functionWithSubmsumption(x:obj) = x :?> string +let functionWithCoercion(x:string) = (x :> obj) :?> string |> functionWithSubmsumption |> functionWithSubmsumption + +type MultiArgMethods(c:int,d:int) = + member x.Method(a:int, b : int) = 1 + member x.CurriedMethod(a1:int, b1: int) (a2:int, b2:int) = 1 + +let testFunctionThatCallsMultiArgMethods() = + let m = MultiArgMethods(3,4) + (m.Method(7,8) + m.CurriedMethod (9,10) (11,12)) + +let functionThatUsesObjectExpression() = + { new obj() with member x.ToString() = string 888 } + +let functionThatUsesObjectExpressionWithInterfaceImpl() = + { new obj() with + member x.ToString() = string 888 + interface System.IComparable with + member x.CompareTo(y:obj) = 0 } + +let testFunctionThatUsesUnitsOfMeasure (x : float<_>) (y: float<_>) = x + y + +let testFunctionThatUsesAddressesAndByrefs (x: byref) = + let mutable w = 4 + let y1 = &x // address-of + let y2 = &w // address-of + let arr = [| 3;4 |] // address-of + let r = ref 3 // address-of + let y3 = &arr.[0] // address-of array + let y4 = &r.contents // address-of field + let z = x + y1 + y2 + y3 // dereference + w <- 3 // assign to pointer + x <- 4 // assign to byref + y2 <- 4 // assign to byref + y3 <- 5 // assign to byref + z + x + y1 + y2 + y3 + y4 + arr.[0] + r.contents + +let testFunctionThatUsesStructs1 (dt:System.DateTime) = dt.AddDays(3.0) + +let testFunctionThatUsesStructs2 () = + let dt1 = System.DateTime.Now + let mutable dt2 = System.DateTime.Now + let dt3 = dt1 - dt2 + let dt4 = dt1.AddDays(3.0) + let dt5 = dt1.Millisecond + let dt6 = &dt2 + let dt7 = dt6 - dt4 + dt7 + +let testFunctionThatUsesWhileLoop() = + let mutable x = 1 + while x < 100 do + x <- x + 1 + x + +let testFunctionThatUsesTryWith() = + try + testFunctionThatUsesWhileLoop() + with :? System.ArgumentException as e -> e.Message.Length + + +let testFunctionThatUsesTryFinally() = + try + testFunctionThatUsesWhileLoop() + finally + System.Console.WriteLine("8888") + +type System.Console with + static member WriteTwoLines() = System.Console.WriteLine(); System.Console.WriteLine() + +type System.DateTime with + member x.TwoMinute = x.Minute + x.Minute + +let testFunctionThatUsesExtensionMembers() = + System.Console.WriteTwoLines() + let v = System.DateTime.Now.TwoMinute + System.Console.WriteTwoLines() + +let testFunctionThatUsesOptionMembers() = + let x = Some(3) + (x.IsSome, x.IsNone) + +let testFunctionThatUsesOverAppliedFunction() = + id id 3 + +let testFunctionThatUsesPatternMatchingOnLists(x) = + match x with + | [] -> 1 + | [h] -> 2 + | [h;h2] -> 3 + | _ -> 4 + +let testFunctionThatUsesPatternMatchingOnOptions(x) = + match x with + | None -> 1 + | Some h -> 2 + h + +let testFunctionThatUsesPatternMatchingOnOptions2(x) = + match x with + | None -> 1 + | Some _ -> 2 + +let testFunctionThatUsesConditionalOnOptions2(x: int option) = + if x.IsSome then 1 else 2 + +let f x y = x+y +let g = f 1 +let h = (g 2) + 3 + +type TestFuncProp() = + member this.Id = fun x -> x + +let wrong = TestFuncProp().Id 0 = 0 + +let start (name:string) = + name, name + +let last (name:string, values:string ) = + id (name, values) + +let last2 (name:string) = + id name + +let test7(s:string) = + start s |> last + +let test8() = + last + +let test9(s:string) = + (s,s) |> last + +let test10() = + last2 + +let test11(s:string) = + s |> last2 + +let rec badLoop : (int -> int) = + () // so that it is a function value + fun x -> badLoop (x + 1) + +module LetLambda = + let f = + () // so that it is a function value + fun a b -> a + b + +let letLambdaRes = [ 1, 2 ] |> List.map (fun (a, b) -> LetLambda.f a b) + + + """ + File.WriteAllText(fileName1, fileSource1) + + let fileSource2 = """ +module N + +type IntAbbrev = int + + +let bool2 = false + + """ + File.WriteAllText(fileName2, fileSource2) + + let fileNames = [fileName1; fileName2] + let args = mkProjectCommandLineArgs (dllName, fileNames) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + +//<@ let x = Some(3) in x.IsSome @> +#if EXTENSIONTYPING +[] +let ``Test Declarations project1`` () = + let wholeProjectResults = checker.ParseAndCheckProject(Project1.options) |> Async.RunSynchronously + + for e in wholeProjectResults.Errors do + printfn "Project1 error: <<<%s>>>" e.Message + + wholeProjectResults.Errors.Length |> shouldEqual 3 // recursive value warning + wholeProjectResults.Errors.[0].Severity |> shouldEqual FSharpErrorSeverity.Warning + wholeProjectResults.Errors.[1].Severity |> shouldEqual FSharpErrorSeverity.Warning + wholeProjectResults.Errors.[2].Severity |> shouldEqual FSharpErrorSeverity.Warning + + wholeProjectResults.AssemblyContents.ImplementationFiles.Length |> shouldEqual 2 + let file1 = wholeProjectResults.AssemblyContents.ImplementationFiles.[0] + let file2 = wholeProjectResults.AssemblyContents.ImplementationFiles.[1] + + // This behaves slightly differently on Mono versions, 'null' is printed somethimes, 'None' other times + // Presumably this is very small differences in Mono reflection causing F# printing to change behavious + // For now just disabling this test. See https://github.com/fsharp/FSharp.Compiler.Service/pull/766 + let filterHack l = + l |> List.map (fun (s:string) -> + s.Replace("ILArrayShape [(Some 0, None)]", "ILArrayShapeFIX") + .Replace("ILArrayShape [(Some 0, null)]", "ILArrayShapeFIX")) + + let expected = + ["type M"; "type IntAbbrev"; "let boolEx1 = True @ (6,14--6,18)"; + "let intEx1 = 1 @ (7,13--7,14)"; "let int64Ex1 = 1 @ (8,15--8,17)"; + "let tupleEx1 = (1,1) @ (9,16--9,21)"; + "let tupleEx2 = (1,1,1) @ (10,16--10,25)"; + "let tupleEx3 = (1,1,1,1) @ (11,16--11,29)"; + "let localExample = let y: Microsoft.FSharp.Core.int = 1 in let z: Microsoft.FSharp.Core.int = 1 in (y,z) @ (14,7--14,8)"; + "let localGenericFunctionExample(unitVar0) = let y: Microsoft.FSharp.Core.int = 1 in let compiledAsLocalGenericFunction: 'a -> 'a = FUN ... -> fun x -> x in (compiledAsLocalGenericFunction y,compiledAsLocalGenericFunction 1) @ (19,7--19,8)"; + "let funcEx1(x) = x @ (23,23--23,24)"; + "let genericFuncEx1(x) = x @ (24,29--24,30)"; + "let topPair1b = M.patternInput@25 ().Item1 @ (25,4--25,26)"; + "let topPair1a = M.patternInput@25 ().Item0 @ (25,4--25,26)"; + "let tyfuncEx1 = Operators.TypeOf<'T> () @ (26,20--26,26)"; + "let testILCall1 = new Object() @ (27,18--27,27)"; + "let testILCall2 = Console.WriteLine (\"176\") @ (28,18--28,49)"; + "let recValNeverUsedAtRuntime = recValNeverUsedAtRuntime@31.Force(()) @ (31,8--31,32)"; + "let recFuncIgnoresFirstArg(g) (v) = v @ (32,33--32,34)"; + "let testFun4(unitVar0) = let rec ... in recValNeverUsedAtRuntime @ (36,4--39,28)"; + "type ClassWithImplicitConstructor"; + "member .ctor(compiledAsArg) = (new Object(); (this.compiledAsArg <- compiledAsArg; (this.compiledAsField <- 1; let compiledAsLocal: Microsoft.FSharp.Core.int = 1 in let compiledAsLocal2: Microsoft.FSharp.Core.int = Operators.op_Addition (compiledAsLocal,compiledAsLocal) in ()))) @ (41,5--41,33)"; + "member .cctor(unitVar) = (compiledAsStaticField <- 1; let compiledAsStaticLocal: Microsoft.FSharp.Core.int = 1 in let compiledAsStaticLocal2: Microsoft.FSharp.Core.int = Operators.op_Addition (compiledAsStaticLocal,compiledAsStaticLocal) in ()) @ (49,11--49,40)"; + "member M1(__) (unitVar1) = Operators.op_Addition (Operators.op_Addition (__.compiledAsField,let x: Microsoft.FSharp.Core.int = __.compiledAsField in __.compiledAsGenericInstanceMethod(x)),__.compiledAsArg) @ (55,21--55,102)"; + "member M2(__) (unitVar1) = __.compiledAsInstanceMethod(()) @ (56,21--56,47)"; + "member SM1(unitVar0) = Operators.op_Addition (compiledAsStaticField,let x: Microsoft.FSharp.Core.int = compiledAsStaticField in ClassWithImplicitConstructor.compiledAsGenericStaticMethod (x)) @ (57,26--57,101)"; + "member SM2(unitVar0) = ClassWithImplicitConstructor.compiledAsStaticMethod (()) @ (58,26--58,50)"; + "member ToString(__) (unitVar1) = Operators.op_Addition (base.ToString(),Operators.ToString (999)) @ (59,29--59,57)"; + "member TestCallinToString(this) (unitVar1) = this.ToString() @ (60,39--60,54)"; + "type Error"; "let err = {Data0 = 3; Data1 = 4} @ (64,10--64,20)"; + "let matchOnException(err) = match (if err :? M.Error then $0 else $1) targets ... @ (66,33--66,36)"; + "let upwardForLoop(unitVar0) = let mutable a: Microsoft.FSharp.Core.int = 1 in (for-loop; a) @ (69,16--69,17)"; + "let upwardForLoop2(unitVar0) = let mutable a: Microsoft.FSharp.Core.int = 1 in (for-loop; a) @ (74,16--74,17)"; + "let downwardForLoop(unitVar0) = let mutable a: Microsoft.FSharp.Core.int = 1 in (for-loop; a) @ (79,16--79,17)"; + "let quotationTest1(unitVar0) = quote(Operators.op_Addition (1,1)) @ (83,24--83,35)"; + "let quotationTest2(v) = quote(Operators.op_Addition (ExtraTopLevelOperators.SpliceExpression (v),1)) @ (84,24--84,36)"; + "type RecdType"; "type UnionType"; "type ClassWithEventsAndProperties"; + "member .ctor(unitVar0) = (new Object(); (this.ev <- new FSharpEvent`1(()); ())) @ (89,5--89,33)"; + "member .cctor(unitVar) = (sev <- new FSharpEvent`1(()); ()) @ (91,11--91,35)"; + "member get_InstanceProperty(x) (unitVar1) = (x.ev.Trigger(1); 1) @ (92,32--92,48)"; + "member get_StaticProperty(unitVar0) = (sev.Trigger(1); 1) @ (93,35--93,52)"; + "member get_InstanceEvent(x) (unitVar1) = x.ev.get_Publish(()) @ (94,29--94,39)"; + "member get_StaticEvent(x) (unitVar1) = sev.get_Publish(()) @ (95,27--95,38)"; + "let c = new ClassWithEventsAndProperties(()) @ (97,8--97,38)"; + "let v = M.c ().get_InstanceProperty(()) @ (98,8--98,26)"; + "do Console.WriteLine (\"777\")"; + "let functionWithSubmsumption(x) = IntrinsicFunctions.UnboxGeneric (x) @ (102,40--102,52)"; + "let functionWithCoercion(x) = Operators.op_PipeRight (Operators.op_PipeRight (IntrinsicFunctions.UnboxGeneric (x :> Microsoft.FSharp.Core.obj),fun x -> M.functionWithSubmsumption (x :> Microsoft.FSharp.Core.obj)),fun x -> M.functionWithSubmsumption (x :> Microsoft.FSharp.Core.obj)) @ (103,39--103,116)"; + "type MultiArgMethods"; + "member .ctor(c,d) = (new Object(); ()) @ (105,5--105,20)"; + "member Method(x) (a,b) = 1 @ (106,37--106,38)"; + "member CurriedMethod(x) (a1,b1) (a2,b2) = 1 @ (107,63--107,64)"; + "let testFunctionThatCallsMultiArgMethods(unitVar0) = let m: M.MultiArgMethods = new MultiArgMethods(3,4) in Operators.op_Addition (m.Method(7,8),fun tupledArg -> let arg00: Microsoft.FSharp.Core.int = tupledArg.Item0 in let arg01: Microsoft.FSharp.Core.int = tupledArg.Item1 in fun tupledArg -> let arg10: Microsoft.FSharp.Core.int = tupledArg.Item0 in let arg11: Microsoft.FSharp.Core.int = tupledArg.Item1 in m.CurriedMethod(arg00,arg01,arg10,arg11) (9,10) (11,12)) @ (110,8--110,9)"; + "let functionThatUsesObjectExpression(unitVar0) = { new Object() with member x.ToString(unitVar1) = Operators.ToString (888) } @ (114,3--114,55)"; + "let functionThatUsesObjectExpressionWithInterfaceImpl(unitVar0) = { new Object() with member x.ToString(unitVar1) = Operators.ToString (888) interface System.IComparable with member x.CompareTo(y) = 0 } :> System.IComparable @ (117,3--120,38)"; + "let testFunctionThatUsesUnitsOfMeasure(x) (y) = Operators.op_Addition,Microsoft.FSharp.Core.float<'u>,Microsoft.FSharp.Core.float<'u>> (x,y) @ (122,70--122,75)"; + "let testFunctionThatUsesAddressesAndByrefs(x) = let mutable w: Microsoft.FSharp.Core.int = 4 in let y1: Microsoft.FSharp.Core.byref = x in let y2: Microsoft.FSharp.Core.byref = &w in let arr: Microsoft.FSharp.Core.int Microsoft.FSharp.Core.[] = [|3; 4|] in let r: Microsoft.FSharp.Core.int Microsoft.FSharp.Core.ref = Operators.Ref (3) in let y3: Microsoft.FSharp.Core.byref = [I_ldelema (NormalAddress,false,ILArrayShape [(Some 0, None)],TypeVar 0us)](arr,0) in let y4: Microsoft.FSharp.Core.byref = &r.contents in let z: Microsoft.FSharp.Core.int = Operators.op_Addition (Operators.op_Addition (Operators.op_Addition (x,y1),y2),y3) in (w <- 3; (x <- 4; (y2 <- 4; (y3 <- 5; Operators.op_Addition (Operators.op_Addition (Operators.op_Addition (Operators.op_Addition (Operators.op_Addition (Operators.op_Addition (Operators.op_Addition (z,x),y1),y2),y3),y4),IntrinsicFunctions.GetArray (arr,0)),r.contents))))) @ (125,16--125,17)"; + "let testFunctionThatUsesStructs1(dt) = dt.AddDays(3) @ (139,57--139,72)"; + "let testFunctionThatUsesStructs2(unitVar0) = let dt1: System.DateTime = DateTime.get_Now () in let mutable dt2: System.DateTime = DateTime.get_Now () in let dt3: System.TimeSpan = Operators.op_Subtraction (dt1,dt2) in let dt4: System.DateTime = dt1.AddDays(3) in let dt5: Microsoft.FSharp.Core.int = dt1.get_Millisecond() in let dt6: Microsoft.FSharp.Core.byref = &dt2 in let dt7: System.TimeSpan = Operators.op_Subtraction (dt6,dt4) in dt7 @ (142,7--142,10)"; + "let testFunctionThatUsesWhileLoop(unitVar0) = let mutable x: Microsoft.FSharp.Core.int = 1 in (while Operators.op_LessThan (x,100) do x <- Operators.op_Addition (x,1) done; x) @ (152,15--152,16)"; + "let testFunctionThatUsesTryWith(unitVar0) = try M.testFunctionThatUsesWhileLoop (()) with matchValue -> match (if matchValue :? System.ArgumentException then $0 else $1) targets ... @ (158,3--160,60)"; + "let testFunctionThatUsesTryFinally(unitVar0) = try M.testFunctionThatUsesWhileLoop (()) finally Console.WriteLine (\"8888\") @ (164,3--167,37)"; + "member Console.WriteTwoLines.Static(unitVar0) = (Console.WriteLine (); Console.WriteLine ()) @ (170,36--170,90)"; + "member DateTime.get_TwoMinute(x) (unitVar1) = Operators.op_Addition (x.get_Minute(),x.get_Minute()) @ (173,25--173,44)"; + "let testFunctionThatUsesExtensionMembers(unitVar0) = (M.Console.WriteTwoLines.Static (()); let v: Microsoft.FSharp.Core.int = DateTime.get_Now ().DateTime.get_TwoMinute(()) in M.Console.WriteTwoLines.Static (())) @ (176,3--178,33)"; + "let testFunctionThatUsesOptionMembers(unitVar0) = let x: Microsoft.FSharp.Core.int Microsoft.FSharp.Core.option = Some(3) in (x.get_IsSome() (),x.get_IsNone() ()) @ (181,7--181,8)"; + "let testFunctionThatUsesOverAppliedFunction(unitVar0) = Operators.Identity Microsoft.FSharp.Core.int> (fun x -> Operators.Identity (x)) 3 @ (185,3--185,10)"; + "let testFunctionThatUsesPatternMatchingOnLists(x) = match (if x.Isop_ColonColon then (if x.Tail.Isop_ColonColon then (if x.Tail.Tail.Isop_Nil then $2 else $3) else $1) else $0) targets ... @ (188,10--188,11)"; + "let testFunctionThatUsesPatternMatchingOnOptions(x) = match (if x.IsSome then $1 else $0) targets ... @ (195,10--195,11)"; + "let testFunctionThatUsesPatternMatchingOnOptions2(x) = match (if x.IsSome then $1 else $0) targets ... @ (200,10--200,11)"; + "let testFunctionThatUsesConditionalOnOptions2(x) = (if x.get_IsSome() () then 1 else 2) @ (205,4--205,29)"; + "let f(x) (y) = Operators.op_Addition (x,y) @ (207,12--207,15)"; + "let g = let x: Microsoft.FSharp.Core.int = 1 in fun y -> M.f (x,y) @ (208,8--208,11)"; + "let h = Operators.op_Addition (M.g () 2,3) @ (209,8--209,17)"; + "type TestFuncProp"; + "member .ctor(unitVar0) = (new Object(); ()) @ (211,5--211,17)"; + "member get_Id(this) (unitVar1) = fun x -> x @ (212,21--212,31)"; + "let wrong = Operators.op_Equality (new TestFuncProp(()).get_Id(()) 0,0) @ (214,12--214,35)"; + "let start(name) = (name,name) @ (217,4--217,14)"; + "let last(name,values) = Operators.Identity ((name,values)) @ (220,4--220,21)"; + "let last2(name) = Operators.Identity (name) @ (223,4--223,11)"; + "let test7(s) = Operators.op_PipeRight (M.start (s),fun tupledArg -> let name: Microsoft.FSharp.Core.string = tupledArg.Item0 in let values: Microsoft.FSharp.Core.string = tupledArg.Item1 in M.last (name,values)) @ (226,4--226,19)"; + "let test8(unitVar0) = fun tupledArg -> let name: Microsoft.FSharp.Core.string = tupledArg.Item0 in let values: Microsoft.FSharp.Core.string = tupledArg.Item1 in M.last (name,values) @ (229,4--229,8)"; + "let test9(s) = Operators.op_PipeRight ((s,s),fun tupledArg -> let name: Microsoft.FSharp.Core.string = tupledArg.Item0 in let values: Microsoft.FSharp.Core.string = tupledArg.Item1 in M.last (name,values)) @ (232,4--232,17)"; + "let test10(unitVar0) = fun name -> M.last2 (name) @ (235,4--235,9)"; + "let test11(s) = Operators.op_PipeRight (s,fun name -> M.last2 (name)) @ (238,4--238,14)"; + "let badLoop = badLoop@240.Force Microsoft.FSharp.Core.int>(()) @ (240,8--240,15)"; + "type LetLambda"; + "let f = ((); fun a -> fun b -> Operators.op_Addition (a,b)) @ (246,8--247,24)"; + "let letLambdaRes = Operators.op_PipeRight<(Microsoft.FSharp.Core.int * Microsoft.FSharp.Core.int) Microsoft.FSharp.Collections.list,Microsoft.FSharp.Core.int Microsoft.FSharp.Collections.list> (Cons((1,2),Empty()),let mapping: Microsoft.FSharp.Core.int * Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.int = fun tupledArg -> let a: Microsoft.FSharp.Core.int = tupledArg.Item0 in let b: Microsoft.FSharp.Core.int = tupledArg.Item1 in (LetLambda.f () a) b in fun list -> ListModule.Map (mapping,list)) @ (249,19--249,71)"] + + printDeclarations None (List.ofSeq file1.Declarations) + |> Seq.toList + |> filterHack + |> shouldEqual (filterHack expected) + + () +#endif + +//--------------------------------------------------------------------------------------------------------- +// This big list expression was causing us trouble + +module internal ProjectStressBigExpressions = + open System.IO + + let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") + let base2 = Path.GetTempFileName() + let dllName = Path.ChangeExtension(base2, ".dll") + let projFileName = Path.ChangeExtension(base2, ".fsproj") + let fileSource1 = """ +module StressBigExpressions + + +let BigListExpression = + + [("C", "M.C", "file1", ((3, 5), (3, 6)), ["class"]); + ("( .ctor )", "M.C.( .ctor )", "file1", ((3, 5), (3, 6)),["member"; "ctor"]); + ("P", "M.C.P", "file1", ((4, 13), (4, 14)), ["member"; "getter"]); + ("x", "x", "file1", ((4, 11), (4, 12)), []); + ("( + )", "Microsoft.FSharp.Core.Operators.( + )", "file1",((6, 12), (6, 13)), ["val"]); + ("xxx", "M.xxx", "file1", ((6, 4), (6, 7)), ["val"]); + ("( + )", "Microsoft.FSharp.Core.Operators.( + )", "file1",((7, 17), (7, 18)), ["val"]); + ("xxx", "M.xxx", "file1", ((7, 13), (7, 16)), ["val"]); + ("xxx", "M.xxx", "file1", ((7, 19), (7, 22)), ["val"]); + ("fff", "M.fff", "file1", ((7, 4), (7, 7)), ["val"]); + ("C", "M.C", "file1", ((9, 15), (9, 16)), ["class"]); + ("C", "M.C", "file1", ((9, 15), (9, 16)), ["class"]); + ("C", "M.C", "file1", ((9, 15), (9, 16)), ["class"]); + ("C", "M.C", "file1", ((9, 15), (9, 16)), ["class"]); + ("CAbbrev", "M.CAbbrev", "file1", ((9, 5), (9, 12)), ["abbrev"]); + ("M", "M", "file1", ((1, 7), (1, 8)), ["module"]); + ("D1", "N.D1", "file2", ((5, 5), (5, 7)), ["class"]); + ("( .ctor )", "N.D1.( .ctor )", "file2", ((5, 5), (5, 7)),["member"; "ctor"]); + ("SomeProperty", "N.D1.SomeProperty", "file2", ((6, 13), (6, 25)),["member"; "getter"]); + ("x", "x", "file2", ((6, 11), (6, 12)), []); + ("M", "M", "file2", ((6, 28), (6, 29)), ["module"]); + ("xxx", "M.xxx", "file2", ((6, 28), (6, 33)), ["val"]); + ("D2", "N.D2", "file2", ((8, 5), (8, 7)), ["class"]); + ("( .ctor )", "N.D2.( .ctor )", "file2", ((8, 5), (8, 7)),["member"; "ctor"]); + ("SomeProperty", "N.D2.SomeProperty", "file2", ((9, 13), (9, 25)),["member"; "getter"]); ("x", "x", "file2", ((9, 11), (9, 12)), []); + ("( + )", "Microsoft.FSharp.Core.Operators.( + )", "file2",((9, 36), (9, 37)), ["val"]); + ("M", "M", "file2", ((9, 28), (9, 29)), ["module"]); + ("fff", "M.fff", "file2", ((9, 28), (9, 33)), ["val"]); + ("D1", "N.D1", "file2", ((9, 38), (9, 40)), ["member"; "ctor"]); + ("M", "M", "file2", ((12, 27), (12, 28)), ["module"]); + ("xxx", "M.xxx", "file2", ((12, 27), (12, 32)), ["val"]); + ("y2", "N.y2", "file2", ((12, 4), (12, 6)), ["val"]); + ("DefaultValueAttribute", "Microsoft.FSharp.Core.DefaultValueAttribute","file2", ((18, 6), (18, 18)), ["class"]); + ("DefaultValueAttribute", "Microsoft.FSharp.Core.DefaultValueAttribute","file2", ((18, 6), (18, 18)), ["class"]); + ("DefaultValueAttribute", "Microsoft.FSharp.Core.DefaultValueAttribute","file2", ((18, 6), (18, 18)), ["member"]); + ("int", "Microsoft.FSharp.Core.int", "file2", ((19, 20), (19, 23)),["abbrev"]); + ("DefaultValueAttribute", "Microsoft.FSharp.Core.DefaultValueAttribute","file2", ((18, 6), (18, 18)), ["class"]); + ("DefaultValueAttribute", "Microsoft.FSharp.Core.DefaultValueAttribute","file2", ((18, 6), (18, 18)), ["class"]); + ("DefaultValueAttribute", "Microsoft.FSharp.Core.DefaultValueAttribute","file2", ((18, 6), (18, 18)), ["member"]); + ("x", "N.D3.x", "file2", ((19, 16), (19, 17)),["field"; "default"; "mutable"]); + ("D3", "N.D3", "file2", ((15, 5), (15, 7)), ["class"]); + ("int", "Microsoft.FSharp.Core.int", "file2", ((15, 10), (15, 13)),["abbrev"]); ("a", "a", "file2", ((15, 8), (15, 9)), []); + ("( .ctor )", "N.D3.( .ctor )", "file2", ((15, 5), (15, 7)),["member"; "ctor"]); + ("SomeProperty", "N.D3.SomeProperty", "file2", ((21, 13), (21, 25)),["member"; "getter"]); + ("( + )", "Microsoft.FSharp.Core.Operators.( + )", "file2",((16, 14), (16, 15)), ["val"]); + ("a", "a", "file2", ((16, 12), (16, 13)), []); + ("b", "b", "file2", ((16, 8), (16, 9)), []); + ("x", "x", "file2", ((21, 11), (21, 12)), []); + ("( + )", "Microsoft.FSharp.Core.Operators.( + )", "file2",((21, 30), (21, 31)), ["val"]); + ("a", "a", "file2", ((21, 28), (21, 29)), []); + ("b", "b", "file2", ((21, 32), (21, 33)), []); + ("( + )", "Microsoft.FSharp.Core.Operators.( + )", "file2",((23, 25), (23, 26)), ["val"]); + ("( + )", "Microsoft.FSharp.Core.Operators.( + )", "file2",((23, 21), (23, 22)), ["val"]); + ("int32", "Microsoft.FSharp.Core.Operators.int32", "file2",((23, 27), (23, 32)), ["val"]); + ("DateTime", "System.DateTime", "file2", ((23, 40), (23, 48)),["valuetype"]); + ("System", "System", "file2", ((23, 33), (23, 39)), ["namespace"]); + ("Now", "System.DateTime.Now", "file2", ((23, 33), (23, 52)),["member"; "prop"]); + ("Ticks", "System.DateTime.Ticks", "file2", ((23, 33), (23, 58)),["member"; "prop"]); + ("( + )", "Microsoft.FSharp.Core.Operators.( + )", "file2",((23, 62), (23, 63)), ["val"]); + ("pair2", "N.pair2", "file2", ((23, 10), (23, 15)), ["val"]); + ("pair1", "N.pair1", "file2", ((23, 4), (23, 9)), ["val"]); + ("None", "N.SaveOptions.None", "file2", ((27, 4), (27, 8)),["field"; "static"; "0"]); + ("DisableFormatting", "N.SaveOptions.DisableFormatting", "file2",((28, 4), (28, 21)), ["field"; "static"; "1"]); + ("SaveOptions", "N.SaveOptions", "file2", ((26, 5), (26, 16)),["enum"; "valuetype"]); + ("SaveOptions", "N.SaveOptions", "file2", ((30, 16), (30, 27)),["enum"; "valuetype"]); + ("DisableFormatting", "N.SaveOptions.DisableFormatting", "file2",((30, 16), (30, 45)), ["field"; "static"; "1"]); + ("enumValue", "N.enumValue", "file2", ((30, 4), (30, 13)), ["val"]); + ("x", "x", "file2", ((32, 9), (32, 10)), []); + ("y", "y", "file2", ((32, 11), (32, 12)), []); + ("( + )", "Microsoft.FSharp.Core.Operators.( + )", "file2",((32, 17), (32, 18)), ["val"]); + ("x", "x", "file2", ((32, 15), (32, 16)), []); + ("y", "y", "file2", ((32, 19), (32, 20)), []); + ("( ++ )", "N.( ++ )", "file2", ((32, 5), (32, 7)), ["val"]); + ("( ++ )", "N.( ++ )", "file2", ((34, 11), (34, 13)), ["val"]); + ("c1", "N.c1", "file2", ((34, 4), (34, 6)), ["val"]); + ("( ++ )", "N.( ++ )", "file2", ((36, 11), (36, 13)), ["val"]); + ("c2", "N.c2", "file2", ((36, 4), (36, 6)), ["val"]); + ("M", "M", "file2", ((38, 12), (38, 13)), ["module"]); + ("C", "M.C", "file2", ((38, 12), (38, 15)), ["class"]); + ("M", "M", "file2", ((38, 22), (38, 23)), ["module"]); + ("C", "M.C", "file2", ((38, 22), (38, 25)), ["class"]); + ("C", "M.C", "file2", ((38, 22), (38, 25)), ["member"; "ctor"]); + ("mmmm1", "N.mmmm1", "file2", ((38, 4), (38, 9)), ["val"]); + ("M", "M", "file2", ((39, 12), (39, 13)), ["module"]); + ("CAbbrev", "M.CAbbrev", "file2", ((39, 12), (39, 21)), ["abbrev"]); + ("M", "M", "file2", ((39, 28), (39, 29)), ["module"]); + ("CAbbrev", "M.CAbbrev", "file2", ((39, 28), (39, 37)), ["abbrev"]); + ("C", "M.C", "file2", ((39, 28), (39, 37)), ["member"; "ctor"]); + ("mmmm2", "N.mmmm2", "file2", ((39, 4), (39, 9)), ["val"]); + ("N", "N", "file2", ((1, 7), (1, 8)), ["module"])] + +let BigSequenceExpression(outFileOpt,docFileOpt,baseAddressOpt) = + [ yield "--simpleresolution" + yield "--noframework" + match outFileOpt with + | None -> () + | Some outFile -> yield "--out:" + outFile + match docFileOpt with + | None -> () + | Some docFile -> yield "--doc:" + docFile + match baseAddressOpt with + | None -> () + | Some baseAddress -> yield "--baseaddress:" + baseAddress + match baseAddressOpt with + | None -> () + | Some keyFile -> yield "--keyfile:" + keyFile + match baseAddressOpt with + | None -> () + | Some sigFile -> yield "--sig:" + sigFile + match baseAddressOpt with + | None -> () + | Some pdbFile -> yield "--pdb:" + pdbFile + match baseAddressOpt with + | None -> () + | Some versionFile -> yield "--versionfile:" + versionFile + match baseAddressOpt with + | None -> () + | Some warnLevel -> yield "--warn:" + warnLevel + match baseAddressOpt with + | None -> () + | Some s -> yield "--subsystemversion:" + s + if true then yield "--highentropyva+" + match baseAddressOpt with + | None -> () + | Some win32Res -> yield "--win32res:" + win32Res + match baseAddressOpt with + | None -> () + | Some win32Manifest -> yield "--win32manifest:" + win32Manifest + match baseAddressOpt with + | None -> () + | Some targetProfile -> yield "--targetprofile:" + targetProfile + yield "--fullpaths" + yield "--flaterrors" + if true then yield "--warnaserror" + yield + if true then "--target:library" + else "--target:exe" + for symbol in [] do + if not (System.String.IsNullOrWhiteSpace symbol) then yield "--define:" + symbol + for nw in [] do + if not (System.String.IsNullOrWhiteSpace nw) then yield "--nowarn:" + nw + for nw in [] do + if not (System.String.IsNullOrWhiteSpace nw) then yield "--warnaserror:" + nw + yield if true then "--debug+" + else "--debug-" + yield if true then "--optimize+" + else "--optimize-" + yield if true then "--tailcalls+" + else "--tailcalls-" + match baseAddressOpt with + | None -> () + | Some debugType -> + match "" with + | "NONE" -> () + | "PDBONLY" -> yield "--debug:pdbonly" + | "FULL" -> yield "--debug:full" + | _ -> () + match baseAddressOpt |> Option.map (fun o -> ""), true, baseAddressOpt |> Option.map (fun o -> "") with + | Some "ANYCPU", true, Some "EXE" | Some "ANYCPU", true, Some "WINEXE" -> yield "--platform:anycpu32bitpreferred" + | Some "ANYCPU", _, _ -> yield "--platform:anycpu" + | Some "X86", _, _ -> yield "--platform:x86" + | Some "X64", _, _ -> yield "--platform:x64" + | Some "ITANIUM", _, _ -> yield "--platform:Itanium" + | _ -> () + match baseAddressOpt |> Option.map (fun o -> "") with + | Some "LIBRARY" -> yield "--target:library" + | Some "EXE" -> yield "--target:exe" + | Some "WINEXE" -> yield "--target:winexe" + | Some "MODULE" -> yield "--target:module" + | _ -> () + yield! [] + for f in [] do + yield "--resource:" + f + for i in [] do + yield "--lib:" + for r in [] do + yield "-r:" + r + yield! [] ] + + + """ + File.WriteAllText(fileName1, fileSource1) + + let fileNames = [fileName1] + let args = mkProjectCommandLineArgs (dllName, fileNames) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + + +[] +let ``Test expressions of declarations stress big expressions`` () = + let wholeProjectResults = checker.ParseAndCheckProject(ProjectStressBigExpressions.options) |> Async.RunSynchronously + + wholeProjectResults.Errors.Length |> shouldEqual 0 + + wholeProjectResults.AssemblyContents.ImplementationFiles.Length |> shouldEqual 1 + let file1 = wholeProjectResults.AssemblyContents.ImplementationFiles.[0] + + // This should not stack overflow + printDeclarations None (List.ofSeq file1.Declarations) |> Seq.toList |> ignore + +#if FX_ATLEAST_45 && !DOTNETCORE + +[] +let ``Check use of type provider that provides calls to F# code`` () = + let config = +#if DEBUG + ["Configuration", "Debug"] +#else + ["Configuration", "Release"] +#endif + let options = + ProjectCracker.GetProjectOptionsFromProjectFile (Path.Combine(Path.Combine(Path.Combine(__SOURCE_DIRECTORY__, "data"),"TestProject"),"TestProject.fsproj"), config) + + let res = + options + |> checker.ParseAndCheckProject + |> Async.RunSynchronously + + Assert.AreEqual ([||], res.Errors, sprintf "Should not be errors, but: %A" res.Errors) + + let results = + [ for f in res.AssemblyContents.ImplementationFiles do + for d in f.Declarations do + for line in d |> printDeclaration None do + yield line ] + + results |> List.iter (printfn "%s") + + results |> shouldEqual + ["type TestProject"; "type AssemblyInfo"; "type TestProject"; "type T"; + """type Class1"""; + """member .ctor(unitVar0) = (new Object(); ()) @ (5,5--5,11)"""; + """member get_X1(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in Helper.doNothing () @ (6,21--6,36)""" + """member get_X2(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in Helper.doNothingGeneric (3) @ (7,21--7,43)""" + """member get_X3(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in Helper.doNothingOneArg (3) @ (8,21--8,42)""" + """member get_X4(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in C.DoNothing () @ (9,21--9,41)""" + """member get_X5(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in C.DoNothingGeneric (3) @ (10,21--10,48)""" + """member get_X6(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in C.DoNothingOneArg (3) @ (11,21--11,47)""" + """member get_X7(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in C.DoNothingTwoArg (new C(),3) @ (12,21--12,47)""" + """member get_X8(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new C().InstanceDoNothing() @ (13,21--13,49)""" + """member get_X9(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new C().InstanceDoNothingGeneric(3) @ (14,21--14,56)""" + """member get_X10(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new C().InstanceDoNothingOneArg(3) @ (15,22--15,56)""" + """member get_X11(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new C().InstanceDoNothingTwoArg(new C(),3) @ (16,22--16,56)""" + """member get_X12(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in G`1.DoNothing () @ (17,22--17,49)""" + """member get_X13(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in G`1.DoNothingOneArg (3) @ (18,22--18,55)""" + """member get_X14(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in G`1.DoNothingTwoArg (new C(),3) @ (19,22--19,55)""" + """member get_X15(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in let matchValue: Microsoft.FSharp.Core.Option = FSharpOption`1.Some (1) in (if Operators.op_Equality (matchValue.Tag,1) then let x: Microsoft.FSharp.Core.int = matchValue.get_Value() in x else 0) @ (20,22--20,54)""" + """member get_X16(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in let matchValue: Microsoft.FSharp.Core.Choice = Choice1Of2(1) in (if Operators.op_Equality (matchValue.Tag,0) then 1 else 0) @ (21,22--21,54)""" + """member get_X17(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in let r: TestTP.Helper.R = {A = 1; B = 0} in (r.B <- 1; r.A) @ (22,22--22,60)""" + """member get_X18(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in Helper.doNothingTwoArg (3,4) @ (23,22--23,43)""" + """member get_X19(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in Helper.doNothingTwoArgCurried (3,4) @ (24,22--24,50)""" + """member get_X21(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in (fun arg00 -> fun arg10 -> C.DoNothingTwoArgCurried (arg00,arg10) new C()) 3 @ (25,22--25,55)""" + """member get_X23(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in (let objectArg: TestTP.Helper.C = new C() in fun arg00 -> fun arg10 -> objectArg.InstanceDoNothingTwoArgCurried(arg00,arg10) new C()) 3 @ (26,22--26,63)""" + """member get_X24(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in Helper.doNothingGenericWithConstraint (3) @ (27,22--27,58)""" + """member get_X25(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in Helper.doNothingGenericWithTypeConstraint,Microsoft.FSharp.Core.int> (FSharpList`1.Cons (3,FSharpList`1.get_Empty ())) @ (28,22--28,62)""" + """member get_X26(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in Helper.doNothingGenericWithTypeConstraint,Microsoft.FSharp.Core.int> (FSharpList`1.Cons (3,FSharpList`1.get_Empty ())) @ (29,22--29,62)""" + """member get_X27(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in Helper.DoNothingReally () @ (30,22--30,53)""" + """member get_X28(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new CSharpClass(0).Method("x") :> Microsoft.FSharp.Core.Unit @ (31,22--31,40)""" + """member get_X29(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in Operators.op_Addition (new CSharpClass(0).Method2("x"),new CSharpClass(0).Method2("empty")) :> Microsoft.FSharp.Core.Unit @ (32,22--32,53)""" + """member get_X30(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new CSharpClass(0).Method3([|"x"; "y"|]) :> Microsoft.FSharp.Core.Unit @ (33,22--33,50)""" + """member get_X31(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new CSharpClass(0).GenericMethod(2) @ (34,22--34,47)""" + """member get_X32(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new CSharpClass(0).GenericMethod2(new Object()) @ (35,22--35,61)""" + """member get_X33(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new CSharpClass(0).GenericMethod3(3) @ (36,22--36,65)""" + """member get_X34(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in C.DoNothingReally () @ (37,22--37,58)""" + """member get_X35(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new C().DoNothingReallyInst() @ (38,22--38,66)""" + """member get_X36(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in (new CSharpClass(0) :> FSharp.Compiler.Service.Tests.ICSharpExplicitInterface).ExplicitMethod("x") :> Microsoft.FSharp.Core.Unit @ (39,22--39,62)""" + """member get_X37(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in (new C() :> TestTP.Helper.I).DoNothing() @ (40,22--40,46)""" + """member get_X38(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in new C().VirtualDoNothing() @ (41,22--41,45)""" + """member get_X39(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in let t: Microsoft.FSharp.Core.int * Microsoft.FSharp.Core.int * Microsoft.FSharp.Core.int = (1,2,3) in let i: Microsoft.FSharp.Core.int = t.Item1 in i @ (42,22--42,51)""" + """member get_X40(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in (moduleValue <- 1; moduleValue) @ (43,22--43,39)""" + """member get_X41(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in let x: TestTP.Helper.C = new C() in (x.set_Property(1); x.get_Property()) @ (44,22--44,41)""" + """member get_X42(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in let x: TestTP.Helper.C = new C() in (x.set_AutoProperty(1); x.get_AutoProperty()) @ (45,22--45,45)""" + """member get_X43(this) (unitVar1) = let this: Microsoft.FSharp.Core.obj = ("My internal state" :> Microsoft.FSharp.Core.obj) :> ErasedWithConstructor.Provided.MyType in (C.set_StaticAutoProperty (1); C.get_StaticAutoProperty ()) @ (46,22--46,51)""" + ] + + let members = + [ for f in res.AssemblyContents.ImplementationFiles do yield! printMembersOfDeclatations f.Declarations ] + + members |> List.iter (printfn "%s") + + members |> shouldEqual + [ + ".ctor: Microsoft.FSharp.Core.unit -> TestProject.Class1" + ".ctor: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X1: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "doNothing: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X2: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "doNothingGeneric<'T>: 'T -> Microsoft.FSharp.Core.unit" + "get_X3: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "doNothingOneArg: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "get_X4: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "DoNothing: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X5: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "DoNothingGeneric<'T>: 'T -> Microsoft.FSharp.Core.unit" + "get_X6: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "DoNothingOneArg: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "get_X7: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "DoNothingTwoArg: TestTP.Helper.C * Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "get_X8: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "InstanceDoNothing: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X9: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "InstanceDoNothingGeneric<'T>: 'T -> Microsoft.FSharp.Core.unit" + "get_X10: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "InstanceDoNothingOneArg: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "get_X11: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "InstanceDoNothingTwoArg: TestTP.Helper.C * Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "get_X12: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "DoNothing: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X13: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "DoNothingOneArg: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "get_X14: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "DoNothingTwoArg: TestTP.Helper.C * Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "get_X15: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + "Some: 'T -> 'T Microsoft.FSharp.Core.option" + "op_Equality<'T when 'T : equality>: 'T -> 'T -> Microsoft.FSharp.Core.bool" + "matchValue: Microsoft.FSharp.Core.Option" + "matchValue: Microsoft.FSharp.Core.Option" + "get_Value: Microsoft.FSharp.Core.unit -> 'T" + "x: Microsoft.FSharp.Core.int" + "get_X16: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + "op_Equality<'T when 'T : equality>: 'T -> 'T -> Microsoft.FSharp.Core.bool" + "matchValue: Microsoft.FSharp.Core.Choice" + "get_X17: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + "r: TestTP.Helper.R" + "r: TestTP.Helper.R" + "get_X18: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "doNothingTwoArg: Microsoft.FSharp.Core.int * Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "get_X19: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "doNothingTwoArgCurried: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "get_X21: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "DoNothingTwoArgCurried: TestTP.Helper.C -> Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "arg00: TestTP.Helper.C" + "arg10: Microsoft.FSharp.Core.int" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "get_X23: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "objectArg: TestTP.Helper.C" + "InstanceDoNothingTwoArgCurried: TestTP.Helper.C -> Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "arg00: TestTP.Helper.C" + "arg10: Microsoft.FSharp.Core.int" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "get_X24: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "doNothingGenericWithConstraint<'T when 'T : equality>: 'T -> Microsoft.FSharp.Core.unit" + "get_X25: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "doNothingGenericWithTypeConstraint<'T, _ when 'T :> Microsoft.FSharp.Collections.seq<'a>>: 'T -> Microsoft.FSharp.Core.unit" + "Cons: 'T * 'T Microsoft.FSharp.Collections.list -> 'T Microsoft.FSharp.Collections.list" + "get_Empty: Microsoft.FSharp.Core.unit -> 'T Microsoft.FSharp.Collections.list" + "get_X26: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "doNothingGenericWithTypeConstraint<'T, _ when 'T :> Microsoft.FSharp.Collections.seq<'a>>: 'T -> Microsoft.FSharp.Core.unit" + "Cons: 'T * 'T Microsoft.FSharp.Collections.list -> 'T Microsoft.FSharp.Collections.list" + "get_Empty: Microsoft.FSharp.Core.unit -> 'T Microsoft.FSharp.Collections.list" + "get_X27: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "DoNothingReally: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X28: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "Method: Microsoft.FSharp.Core.string -> Microsoft.FSharp.Core.int" + "get_X29: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "op_Addition<^T1, ^T2, ^T3>: ^T1 -> ^T2 -> ^T3" + ".ctor: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "Method2: Microsoft.FSharp.Core.string -> Microsoft.FSharp.Core.int" + ".ctor: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "Method2: Microsoft.FSharp.Core.string -> Microsoft.FSharp.Core.int" + "get_X30: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "Method3: Microsoft.FSharp.Core.string Microsoft.FSharp.Core.[] -> Microsoft.FSharp.Core.int" + "get_X31: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "GenericMethod<'T>: 'T -> Microsoft.FSharp.Core.unit" + "get_X32: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "GenericMethod2<'T when 'T : class>: 'T -> Microsoft.FSharp.Core.unit" + ".ctor: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X33: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "GenericMethod3<'T when 'T :> System.IComparable<'T>>: 'T -> Microsoft.FSharp.Core.unit" + "get_X34: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + "DoNothingReally: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X35: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "DoNothingReallyInst: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X36: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "ExplicitMethod: Microsoft.FSharp.Core.string -> Microsoft.FSharp.Core.int" + "get_X37: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "DoNothing: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X38: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.Unit" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "VirtualDoNothing: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.unit" + "get_X39: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + "t: Microsoft.FSharp.Core.int * Microsoft.FSharp.Core.int * Microsoft.FSharp.Core.int" + "i: Microsoft.FSharp.Core.int" + "get_X40: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + "moduleValue: Microsoft.FSharp.Core.int" + "moduleValue: Microsoft.FSharp.Core.int" + "get_X41: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "x: TestTP.Helper.C" + "set_Property: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "x: TestTP.Helper.C" + "get_Property: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + "get_X42: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + ".ctor: Microsoft.FSharp.Core.unit -> TestTP.Helper.C" + "x: TestTP.Helper.C" + "set_AutoProperty: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "x: TestTP.Helper.C" + "get_AutoProperty: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + "get_X43: TestProject.Class1 -> Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + "set_StaticAutoProperty: Microsoft.FSharp.Core.int -> Microsoft.FSharp.Core.unit" + "get_StaticAutoProperty: Microsoft.FSharp.Core.unit -> Microsoft.FSharp.Core.int" + ] + +#endif + +#if SELF_HOST_STRESS + + +[] +let ``Test Declarations selfhost`` () = + let projectFile = __SOURCE_DIRECTORY__ + @"/FSharp.Compiler.Service.Tests.fsproj" + // Check with Configuration = Release + let options = ProjectCracker.GetProjectOptionsFromProjectFile(projectFile, [("Configuration", "Debug")]) + let wholeProjectResults = checker.ParseAndCheckProject(options) |> Async.RunSynchronously + + wholeProjectResults.Errors.Length |> shouldEqual 0 + + wholeProjectResults.AssemblyContents.ImplementationFiles.Length |> shouldEqual 13 + + let textOfAll = [ for file in wholeProjectResults.AssemblyContents.ImplementationFiles -> Array.ofSeq (printDeclarations None (List.ofSeq file.Declarations)) ] + + () + + +[] +let ``Test Declarations selfhost whole compiler`` () = + + Directory.SetCurrentDirectory(__SOURCE_DIRECTORY__ + @"/../../src/fsharp/FSharp.Compiler.Service") + let projectFile = __SOURCE_DIRECTORY__ + @"/../../src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj" + + //let v = FSharpProjectFileInfo.Parse(projectFile, [("Configuration", "Debug"); ("NoFsSrGenTask", "true")],enableLogging=true) + let options = ProjectCracker.GetProjectOptionsFromProjectFile(projectFile, [("Configuration", "Debug"); ("NoFsSrGenTask", "true")]) + + // For subsets of the compiler: + //let options = { options with OtherOptions = options.OtherOptions.[0..51] } + + //for x in options.OtherOptions do printfn "%s" x + + let wholeProjectResults = checker.ParseAndCheckProject(options) |> Async.RunSynchronously + + (wholeProjectResults.Errors |> Array.filter (fun x -> x.Severity = FSharpErrorSeverity.Error)).Length |> shouldEqual 0 + + for file in (wholeProjectResults.AssemblyContents.ImplementationFiles |> List.toArray) do + for d in file.Declarations do + for s in printDeclaration None d do + () //printfn "%s" s + + // Very Quick (1 sec - expressions are computed on demand) + for file in (wholeProjectResults.AssemblyContents.ImplementationFiles |> List.toArray) do + for d in file.Declarations do + for s in exprsOfDecl d do + () + + // Quickish (~4.5 seconds for all of FSharp.Compiler.Service.dll) + #time "on" + for file in (wholeProjectResults.AssemblyContents.ImplementationFiles |> List.toArray) do + for d in file.Declarations do + for (e,m) in exprsOfDecl d do + // This forces the computation of the expression + match e with + | BasicPatterns.Const _ -> () //printfn "%s" s + | _ -> () //printfn "%s" s + +[] +let ``Test Declarations selfhost FSharp.Core`` () = + + Directory.SetCurrentDirectory(__SOURCE_DIRECTORY__ + @"/../../../fsharp/src/fsharp/FSharp.Core") + let projectFile = __SOURCE_DIRECTORY__ + @"/../../../fsharp/src/fsharp/FSharp.Core/FSharp.Core.fsproj" + + let options = ProjectCracker.GetProjectOptionsFromProjectFile(projectFile, [("Configuration", "Debug")]) + + let wholeProjectResults = checker.ParseAndCheckProject(options) |> Async.RunSynchronously + + //(wholeProjectResults.Errors |> Array.filter (fun x -> x.Severity = FSharpErrorSeverity.Error)).Length |> shouldEqual 0 + + for file in (wholeProjectResults.AssemblyContents.ImplementationFiles |> List.toArray) do + for d in file.Declarations do + for s in printDeclaration (Some (HashSet [])) d do + printfn "%s" s + + #time "on" + + for file in (wholeProjectResults.AssemblyContents.ImplementationFiles |> List.toArray) do + for d in file.Declarations do + for (e,m) in exprsOfDecl d do + // This forces the computation of the expression + match e with + | BasicPatterns.Const _ -> () + | _ -> () + +#endif + diff --git a/tests/service/FSharp.Compiler.Service.Tests.netcore.fsproj b/tests/service/FSharp.Compiler.Service.Tests.netcore.fsproj new file mode 100644 index 00000000000..9047b922109 --- /dev/null +++ b/tests/service/FSharp.Compiler.Service.Tests.netcore.fsproj @@ -0,0 +1,61 @@ + + + netcoreapp1.0 + $(DefineConstants);DOTNETCORE;FX_ATLEAST_45;FX_ATLEAST_PORTABLE;FX_NO_RUNTIMEENVIRONMENT;FX_RESHAPED_REFLECTION;TODO_REWORK_ASSEMBLY_LOAD; + $(NoWarn);44; + true + true + true + false + + + + ReshapedReflection.fs + + + FsUnit.fs + + + Common.fs + + + EditorTests.fs + + + ExprTests.fs + + + TokenizerTests.fs + + + PerfTests.fs + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/tests/service/FileSystemTests.fs b/tests/service/FileSystemTests.fs index d9f25f42890..9db245b6ac2 100644 --- a/tests/service/FileSystemTests.fs +++ b/tests/service/FileSystemTests.fs @@ -1,6 +1,6 @@ #if INTERACTIVE -#r "../../Debug/net40/bin/FSharp.LanguageService.Compiler.dll" -#r "../../Debug/net40/bin/nunit.framework.dll" +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" #load "FsUnit.fs" #load "Common.fs" #else @@ -71,6 +71,8 @@ let UseMyFileSystem() = Shim.FileSystem <- myFileSystem { new IDisposable with member x.Dispose() = Shim.FileSystem <- myFileSystem } +#if !FX_ATLEAST_PORTABLE + [] let ``FileSystem compilation test``() = if System.Environment.OSVersion.Platform = System.PlatformID.Win32NT then // file references only valid on Windows @@ -89,10 +91,8 @@ let ``FileSystem compilation test``() = yield "--fullpaths"; yield "--flaterrors"; yield "--target:library"; - for r in [ programFilesx86Folder + @"\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.0\mscorlib.dll"; - programFilesx86Folder + @"\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.0\System.dll"; - programFilesx86Folder + @"\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.0\System.Core.dll"] do - yield "-r:" + r |] + for r in [ sysLib "mscorlib"; sysLib "System"; sysLib "System.Core"; fsCoreDefaultReference() ] do + yield "-r:" + r |] { ProjectFileName = @"c:\mycode\compilation.fsproj" // Make a name that is unique in this directory. ProjectFileNames = [| fileName1; fileName2 |] @@ -111,3 +111,5 @@ let ``FileSystem compilation test``() = results.AssemblySignature.Entities.Count |> shouldEqual 2 results.AssemblySignature.Entities.[0].MembersFunctionsAndValues.Count |> shouldEqual 1 results.AssemblySignature.Entities.[0].MembersFunctionsAndValues.[0].DisplayName |> shouldEqual "B" + +#endif diff --git a/tests/service/FsUnit.fs b/tests/service/FsUnit.fs index 26997463698..497b492cc5d 100644 --- a/tests/service/FsUnit.fs +++ b/tests/service/FsUnit.fs @@ -38,8 +38,6 @@ let Empty = new EmptyConstraint() let EmptyString = new EmptyStringConstraint() -//let NullOrEmptyString = new NullOrEmptyStringConstraint() - let True = new TrueConstraint() let False = new FalseConstraint() diff --git a/tests/service/FscTests.fs b/tests/service/FscTests.fs new file mode 100644 index 00000000000..a29db37681c --- /dev/null +++ b/tests/service/FscTests.fs @@ -0,0 +1,398 @@ + +#if INTERACTIVE +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" +#load "FsUnit.fs" +#load "Common.fs" +#else +module FSharp.Compiler.Service.Tests.FscTests +#endif + + +open System +open System.Diagnostics +open System.IO + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.SourceCodeServices +open FSharp.Compiler.Service.Tests +open FSharp.Compiler.Service.Tests.Common + +open NUnit.Framework + +#if FX_RESHAPED_REFLECTION +open ReflectionAdapters +#endif + +exception + VerificationException of (*assembly:*)string * (*errorCode:*)int * (*output:*)string + with override e.Message = sprintf "Verification of '%s' failed with code %d, message <<<%s>>>" e.Data0 e.Data1 e.Data2 + +exception + CompilationError of (*assembly:*)string * (*errorCode:*)int * (*info:*)FSharpErrorInfo [] + with override e.Message = sprintf "Compilation of '%s' failed with code %d (%A)" e.Data0 e.Data1 e.Data2 + +let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e-> false +let pdbExtension isDll = (if runningOnMono then (if isDll then ".dll.mdb" else ".exe.mdb") else ".pdb") + +type PEVerifier () = + + static let expectedExitCode = 0 + static let runsOnMono = try System.Type.GetType("Mono.Runtime") <> null with _ -> false + + let verifierInfo = +#if FX_ATLEAST_PORTABLE + None +#else + if runsOnMono then + Some ("pedump", "--verify all") + else + let rec tryFindFile (fileName : string) (dir : DirectoryInfo) = + let file = Path.Combine(dir.FullName, fileName) + if File.Exists file then Some file + else + dir.GetDirectories() + |> Array.sortBy(fun d -> d.Name) + |> Array.filter(fun d -> + match d.Name with + // skip old SDK directories + | "v6.0" | "v6.0A" | "v7.0" | "v7.0A" | "v7.1" | "v7.1A" -> false + | _ -> true) + |> Array.rev // order by descending -- get latest version + |> Array.tryPick (tryFindFile fileName) + + let tryGetSdkDir (progFiles : Environment.SpecialFolder) = + let progFilesFolder = Environment.GetFolderPath(progFiles) + let dI = DirectoryInfo(Path.Combine(progFilesFolder, "Microsoft SDKs", "Windows")) + if dI.Exists then Some dI + else None + + match Array.tryPick tryGetSdkDir [| Environment.SpecialFolder.ProgramFilesX86; Environment.SpecialFolder.ProgramFiles |] with + | None -> None + | Some sdkDir -> + match tryFindFile "peverify.exe" sdkDir with + | None -> None + | Some pe -> Some (pe, "/UNIQUE /IL /NOLOGO") +#endif + + static let execute (fileName : string, arguments : string) = + printfn "executing '%s' with arguments %s" fileName arguments + let psi = new ProcessStartInfo(fileName, arguments) + psi.UseShellExecute <- false + //psi.ErrorDialog <- false + psi.CreateNoWindow <- true + psi.RedirectStandardOutput <- true + psi.RedirectStandardError <- true + + use proc = Process.Start(psi) + let stdOut = proc.StandardOutput.ReadToEnd() + let stdErr = proc.StandardError.ReadToEnd() + while not proc.HasExited do () + proc.ExitCode, stdOut, stdErr + + member __.Verify(assemblyPath : string) = + match verifierInfo with + | Some (verifierPath, switches) -> + let id,stdOut,stdErr = execute(verifierPath, sprintf "%s \"%s\"" switches assemblyPath) + if id = expectedExitCode && String.IsNullOrWhiteSpace stdErr then () + else + printfn "Verification failure, stdout: <<<%s>>>" stdOut + printfn "Verification failure, stderr: <<<%s>>>" stdErr + raise <| VerificationException(assemblyPath, id, stdOut + "\n" + stdErr) + | None -> + printfn "Skipping verification part of test because verifier not found" + + + +type DebugMode = + | Off + | PdbOnly + | Full + +let checker = FSharpChecker.Create() + +/// Ensures the default FSharp.Core referenced by the F# compiler service (if none is +/// provided explicitly) is available in the output directory. +let ensureDefaultFSharpCoreAvailable tmpDir = +#if FX_ATLEAST_PORTABLE + ignore tmpDir +#else + // FSharp.Compiler.Service references FSharp.Core 4.3.0.0 by default. That's wrong? But the output won't verify + // or run on a system without FSharp.Core 4.3.0.0 in the GAC or in the same directory, or with a binding redirect in place. + // + // So just copy the FSharp.Core 4.3.0.0 to the tmp directory. Only need to do this on Windows. + if System.Environment.OSVersion.Platform = System.PlatformID.Win32NT then // file references only valid on Windows + File.Copy(fsCoreDefaultReference(), Path.Combine(tmpDir, Path.GetFileName(fsCoreDefaultReference())), overwrite = true) +#endif + +let compile isDll debugMode (assemblyName : string) (ext: string) (code : string) (dependencies : string list) (extraArgs: string list) = + let tmp = Path.Combine(Path.GetTempPath(),"test"+string(hash (isDll,debugMode,assemblyName,code,dependencies))) + try Directory.CreateDirectory(tmp) |> ignore with _ -> () + let sourceFile = Path.Combine(tmp, assemblyName + "." + ext) + let outFile = Path.Combine(tmp, assemblyName + if isDll then ".dll" else ".exe") + let pdbFile = Path.Combine(tmp, assemblyName + pdbExtension isDll) + do File.WriteAllText(sourceFile, code) + let args = + [| + // fsc parser skips the first argument by default; + // perhaps this shouldn't happen in library code. + yield "fsc.exe" + + if isDll then yield "--target:library" + + match debugMode with + | Off -> () // might need to include some switches here + | PdbOnly -> + yield "--debug:pdbonly" + if not runningOnMono then // on Mono, the debug file name is not configurable + yield sprintf "--pdb:%s" pdbFile + | Full -> + yield "--debug:full" + if not runningOnMono then // on Mono, the debug file name is not configurable + yield sprintf "--pdb:%s" pdbFile + + for d in dependencies do + yield sprintf "-r:%s" d + + yield sprintf "--out:%s" outFile + + yield! extraArgs + + yield sourceFile + + |] + + ensureDefaultFSharpCoreAvailable tmp + + printfn "args: %A" args + let errorInfo, id = checker.Compile args |> Async.RunSynchronously + for err in errorInfo do + printfn "error: %A" err + if id <> 0 then raise <| CompilationError(assemblyName, id, errorInfo) + Assert.AreEqual (errorInfo.Length, 0) + outFile + +//sizeof +let compileAndVerify isDll debugMode assemblyName ext code dependencies = + let verifier = new PEVerifier () + let outFile = compile isDll debugMode assemblyName ext code dependencies [] + verifier.Verify outFile + outFile + +let compileAndVerifyAst (name : string, ast : Ast.ParsedInput list, references : string list) = + let outDir = Path.Combine(Path.GetTempPath(),"test"+string(hash (name, references))) + try Directory.CreateDirectory(outDir) |> ignore with _ -> () + + let outFile = Path.Combine(outDir, name + ".dll") + + ensureDefaultFSharpCoreAvailable outDir + + let errors, id = checker.Compile(ast, name, outFile, references, executable = false) |> Async.RunSynchronously + for err in errors do printfn "error: %A" err + Assert.AreEqual (errors.Length, 0) + if id <> 0 then raise <| CompilationError(name, id, errors) + + // copy local explicit references for verification + for ref in references do + let name = Path.GetFileName ref + File.Copy(ref, Path.Combine(outDir, name), overwrite = true) + + let verifier = new PEVerifier() + + verifier.Verify outFile + +[] +let ``1. PEVerifier sanity check`` () = + let verifier = new PEVerifier() + + let fscorlib = typeof.Assembly + verifier.Verify fscorlib.Location + + let nonAssembly = Path.Combine(Directory.GetCurrentDirectory(), typeof.Assembly.GetName().Name + ".pdb") + Assert.Throws(fun () -> verifier.Verify nonAssembly |> ignore) |> ignore + + +[] +let ``2. Simple FSC library test`` () = + let code = """ +module Foo + + let f x = (x,x) + + type Foo = class end + + exception E of int * string + + printfn "done!" // make the code have some initialization effect +""" + + compileAndVerify true PdbOnly "Foo" "fs" code [] |> ignore + +[] +let ``3. Simple FSC executable test`` () = + let code = """ +module Bar + + [] + let main _ = printfn "Hello, World!" ; 42 + +""" + let outFile = compileAndVerify false PdbOnly "Bar" "fs" code [] + + use proc = Process.Start(outFile, "") + proc.WaitForExit() + Assert.AreEqual(proc.ExitCode, 42) + + + +[] +let ``4. Compile from simple AST`` () = + let code = """ +module Foo + + let f x = (x,x) + + type Foo = class end + + exception E of int * string + + printfn "done!" // make the code have some initialization effect +""" + let ast = parseSourceCode("foo", code) |> Option.toList + compileAndVerifyAst("foo", ast, []) + +[] +let ``5. Compile from AST with explicit assembly reference`` () = + let code = """ +module Bar + + open Microsoft.FSharp.Compiler.SourceCodeServices + + let f x = (x,x) + + type Bar = class end + + exception E of int * string + + // depends on FSharp.Compiler.Service + // note : mono's pedump fails if this is a value; will not verify type initializer for module + let checker () = FSharpChecker.Create() + + printfn "done!" // make the code have some initialization effect +""" + let serviceAssembly = typeof.Assembly.Location + let ast = parseSourceCode("bar", code) |> Option.toList + compileAndVerifyAst("bar", ast, [serviceAssembly]) + + +[] +let ``Check line nos are indexed by 1`` () = + let code = """ +module Bar + let doStuff a b = + a + b + + let sum = doStuff "1" 2 + +""" + try + let outFile : string = compile false PdbOnly "Bar" "fs" code [] [] + () + with + | :? CompilationError as exn -> + Assert.AreEqual(6,exn.Data2.[0].StartLineAlternate) + Assert.True(exn.Data2.[0].ToString().Contains("Bar.fs (6,27)-(6,28)")) + | _ -> failwith "No compilation error" + +[] +let ``Check cols are indexed by 1`` () = + let code = "let x = 1 + a" + + try + let outFile : string = compile false PdbOnly "Foo" "fs" code [] [] + () + with + | :? CompilationError as exn -> + Assert.True(exn.Data2.[0].ToString().Contains("Foo.fs (1,13)-(1,14)")) + | _ -> failwith "No compilation error" + + +[] +let ``Check compile of bad fsx`` () = + let code = """ +#load "missing.fsx" +#r "missing.dll" + """ + + try + let outFile : string = compile false PdbOnly "Foo" "fsx" code [] [] + () + with + | :? CompilationError as exn -> + let errorText1 = exn.Data2.[0].ToString() + let errorText2 = exn.Data2.[1].ToString() + printfn "errorText1 = <<<%s>>>" errorText1 + printfn "errorText2 = <<<%s>>>" errorText2 + Assert.True(errorText1.Contains("Could not load file '")) + Assert.True(errorText1.Contains("missing.fsx")) + //Assert.True(errorText2.Contains("Could not locate the assembly \"missing.dll\"")) + | _ -> failwith "No compilation error" + + +[] +let ``Check compile of good fsx with bad option`` () = + let code = """ +let x = 1 + """ + + try + let outFile : string = compile false PdbOnly "Foo" "fsx" code [] ["-r:missing.dll"] + () + with + | :? CompilationError as exn -> + let contains (s1:string) s2 = + Assert.True(s1.Contains(s2), sprintf "Expected '%s' to contain '%s'" s1 s2) + contains (exn.Data2.[0].ToString()) "startup (1,1)-(1,1) parameter error" + contains (exn.Data2.[0].ToString()) "missing.dll" + | _ -> failwith "No compilation error" + + +#if STRESS +// For this stress test the aim is to check if we have a memory leak + +module StressTest1 = + open System.IO + + [] + let ``stress test repeated in-memory compilation``() = + for i = 1 to 500 do + printfn "stress test iteration %d" i + let code = """ +module M + +type C() = + member x.P = 1 + +let x = 3 + 4 +""" + + let outFile : string = compile true PdbOnly "Foo" "fs" code [] [] + () + +#endif + +(* + +[] +let ``Check read of mscorlib`` () = + let options = Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader.mkDefault Microsoft.FSharp.Compiler.AbstractIL.IL.EcmaILGlobals + let options = { options with optimizeForMemory=true} + let reader = Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader.OpenILModuleReaderAfterReadingAllBytes "C:\\Program Files (x86)\\Reference Assemblies\\Microsoft\\Framework\\.NETFramework\\v4.5\\mscorlib.dll" options + let greg = reader.ILModuleDef.TypeDefs.FindByName "System.Globalization.GregorianCalendar" + for attr in greg.CustomAttrs.AsList do + printfn "%A" attr.Method + +*) + + + \ No newline at end of file diff --git a/tests/service/FsiTests.fs b/tests/service/FsiTests.fs new file mode 100644 index 00000000000..2fb90723e33 --- /dev/null +++ b/tests/service/FsiTests.fs @@ -0,0 +1,448 @@ + +#if INTERACTIVE +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" +#load "FsUnit.fs" +#load "Common.fs" +#else +module FSharp.Compiler.Service.Tests.FsiTests +#endif + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Interactive.Shell +open Microsoft.FSharp.Compiler.SourceCodeServices + +open NUnit.Framework +open FsUnit +open System +open System.IO +open System.Text + +// Intialize output and input streams +let inStream = new StringReader("") +let outStream = new CompilerOutputStream() +let errStream = new CompilerOutputStream() + +// Build command line arguments & start FSI session +let argv = [| "C:\\fsi.exe" |] +let allArgs = Array.append argv [|"--noninteractive"|] + +#if DOTNETCORE +let fsiConfig = FsiEvaluationSession.GetDefaultConfiguration() +#else +let fsiConfig = FsiEvaluationSession.GetDefaultConfiguration(fsi) +#endif +let fsiSession = FsiEvaluationSession.Create(fsiConfig, allArgs, inStream, new StreamWriter(outStream), new StreamWriter(errStream)) + +/// Evaluate expression & return the result +let evalExpression text = + match fsiSession.EvalExpression(text) with + | Some value -> sprintf "%A" value.ReflectionValue + | None -> sprintf "null or no result" + +let formatErrors (errs: FSharpErrorInfo[]) = + [ for err in errs do yield sprintf "%s %d,%d - %d,%d; %s" (match err.Severity with FSharpErrorSeverity.Error -> "error" | FSharpErrorSeverity.Warning -> "warning") err.StartLineAlternate err.StartColumn err.EndLineAlternate err.EndColumn err.Message ] + +let showErrorsAndResult (x, errs) = + [ match x with + | Choice1Of2 res -> yield sprintf "result %A" res + | Choice2Of2 (exn:exn) -> yield sprintf "exception %s" exn.Message + yield! formatErrors errs ] + +let showErrors (x, errs: FSharpErrorInfo[]) = + [ match x with + | Choice1Of2 () -> () + | Choice2Of2 (exn:exn) -> yield sprintf "exception %s" exn.Message + yield! formatErrors errs ] + +/// Evaluate expression & return the result +let evalExpressionNonThrowing text = + let res, errs = fsiSession.EvalExpressionNonThrowing(text) + [ match res with + | Choice1Of2 valueOpt -> + match valueOpt with + | Some value -> yield sprintf "%A" value.ReflectionValue + | None -> yield sprintf "null or no result" + | Choice2Of2 (exn:exn) -> yield sprintf "exception %s" exn.Message + yield! formatErrors errs ] + +// For some reason NUnit doesn't like running these FsiEvaluationSession tests. We need to work out why. +//#if INTERACTIVE +[] +let ``EvalExpression test 1``() = + evalExpression "42+1" |> shouldEqual "43" + +[] +let ``EvalExpression test 1 nothrow``() = + evalExpressionNonThrowing "42+1" |> shouldEqual ["43"] + +[] +// 'fsi' can be evaluated because we passed it in explicitly up above +let ``EvalExpression fsi test``() = + evalExpression "fsi" |> shouldEqual "Microsoft.FSharp.Compiler.Interactive.InteractiveSession" + +[] +// 'fsi' can be evaluated because we passed it in explicitly up above +let ``EvalExpression fsi test 2``() = + fsiSession.EvalInteraction "fsi.AddPrinter |> ignore" + +[] +// 'fsi' can be evaluated because we passed it in explicitly up above +let ``EvalExpression fsi test 2 non throwing``() = + fsiSession.EvalInteractionNonThrowing "fsi.AddPrinter |> ignore" + |> showErrors + |> shouldEqual [] + + +[] +let ``EvalExpression typecheck failure``() = + (try evalExpression "42+1.0" |> ignore + false + with e -> true) + |> shouldEqual true + +[] +let ``EvalExpression typecheck failure nothrow``() = + evalExpressionNonThrowing("42+1.0") + |> shouldEqual + ["exception Operation could not be completed due to earlier error"; + "error 1,3 - 1,6; The type 'float' does not match the type 'int'"; + "error 1,2 - 1,3; The type 'float' does not match the type 'int'"] + + +[] +let ``EvalExpression function value 1``() = + fsiSession.EvalExpression "(fun x -> x + 1)" |> fun s -> s.IsSome + |> shouldEqual true + +[] +let ``EvalExpression function value 2``() = + fsiSession.EvalExpression "fun x -> x + 1" |> fun s -> s.IsSome + |> shouldEqual true + +[] +let ``EvalExpression function value 3``() = + fsiSession.EvalExpression "incr" |> fun s -> s.IsSome + |> shouldEqual true + +[] +let ``EvalExpression display value 1``() = + let v = fsiSession.EvalExpression "[1..200]" |> Option.get + let s = fsiSession.FormatValue(v.ReflectionValue, v.ReflectionType) + let equalToString (s1: string) (s2: string) = + s1.Replace("\r\n","\n") |> shouldEqual (s2.Replace("\r\n","\n")) + + s |> equalToString """[1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21; 22; + 23; 24; 25; 26; 27; 28; 29; 30; 31; 32; 33; 34; 35; 36; 37; 38; 39; 40; 41; + 42; 43; 44; 45; 46; 47; 48; 49; 50; 51; 52; 53; 54; 55; 56; 57; 58; 59; 60; + 61; 62; 63; 64; 65; 66; 67; 68; 69; 70; 71; 72; 73; 74; 75; 76; 77; 78; 79; + 80; 81; 82; 83; 84; 85; 86; 87; 88; 89; 90; 91; 92; 93; 94; 95; 96; 97; 98; + 99; 100; ...]""" + begin + use _holder = + let origPrintLength = fsi.PrintLength + fsi.PrintLength <- 200 + { new System.IDisposable with member __.Dispose() = fsi.PrintLength <- origPrintLength } + let sB = fsiSession.FormatValue(v.ReflectionValue, v.ReflectionType) + + sB |> equalToString """[1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21; 22; + 23; 24; 25; 26; 27; 28; 29; 30; 31; 32; 33; 34; 35; 36; 37; 38; 39; 40; 41; + 42; 43; 44; 45; 46; 47; 48; 49; 50; 51; 52; 53; 54; 55; 56; 57; 58; 59; 60; + 61; 62; 63; 64; 65; 66; 67; 68; 69; 70; 71; 72; 73; 74; 75; 76; 77; 78; 79; + 80; 81; 82; 83; 84; 85; 86; 87; 88; 89; 90; 91; 92; 93; 94; 95; 96; 97; 98; + 99; 100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112; 113; 114; + 115; 116; 117; 118; 119; 120; 121; 122; 123; 124; 125; 126; 127; 128; 129; + 130; 131; 132; 133; 134; 135; 136; 137; 138; 139; 140; 141; 142; 143; 144; + 145; 146; 147; 148; 149; 150; 151; 152; 153; 154; 155; 156; 157; 158; 159; + 160; 161; 162; 163; 164; 165; 166; 167; 168; 169; 170; 171; 172; 173; 174; + 175; 176; 177; 178; 179; 180; 181; 182; 183; 184; 185; 186; 187; 188; 189; + 190; 191; 192; 193; 194; 195; 196; 197; 198; 199; 200]""" + + end + let v2 = fsiSession.EvalExpression "(System.Math.PI, System.Math.PI*10.0)" |> Option.get + let s2 = fsiSession.FormatValue(v2.ReflectionValue, v2.ReflectionType) + + s2 |> equalToString "(3.141592654, 31.41592654)" + + begin + use _holder2 = + let orig = fsi.FloatingPointFormat + fsi.FloatingPointFormat <- "g3" + { new System.IDisposable with member __.Dispose() = fsi.FloatingPointFormat <- orig } + + let s2B = fsiSession.FormatValue(v2.ReflectionValue, v2.ReflectionType) + + s2B |> equalToString "(3.14, 31.4)" + end + + + +[] +let ``EvalExpression function value 4``() = + fsiSession.EvalInteraction "let hello(s : System.IO.TextReader) = printfn \"Hello World\"" + fsiSession.EvalExpression "hello" |> fun s -> s.IsSome + |> shouldEqual true + +[] +let ``EvalExpression runtime failure``() = + (try evalExpression """ (failwith "fail" : int) """ |> ignore + false + with e -> true) + |> shouldEqual true + +[] +let ``EvalExpression parse failure``() = + (try evalExpression """ let let let let x = 1 """ |> ignore + false + with e -> true) + |> shouldEqual true + +[] +let ``EvalExpression parse failure nothrow``() = + evalExpressionNonThrowing """ let let let let x = 1 """ + |> shouldEqual + ["exception Operation could not be completed due to earlier error"; + "error 1,5 - 1,8; Unexpected keyword 'let' or 'use' in binding"; + "error 1,1 - 1,4; The block following this 'let' is unfinished. Every code block is an expression and must have a result. 'let' cannot be the final code element in a block. Consider giving this block an explicit result."] + +[] +let ``EvalInteraction typecheck failure``() = + (try fsiSession.EvalInteraction "let x = 42+1.0" |> ignore + false + with e -> true) + |> shouldEqual true + +[] +let ``EvalInteraction typecheck failure nothrow``() = + fsiSession.EvalInteractionNonThrowing "let x = 42+1.0" + |> showErrors + |> shouldEqual + ["exception Operation could not be completed due to earlier error"; + "error 1,11 - 1,14; The type 'float' does not match the type 'int'"; + "error 1,10 - 1,11; The type 'float' does not match the type 'int'"] + +[] +let ``EvalInteraction runtime failure``() = + (try fsiSession.EvalInteraction """let x = (failwith "fail" : int) """ |> ignore + false + with e -> true) + |> shouldEqual true + +[] +let ``EvalInteraction runtime failure nothrow``() = + fsiSession.EvalInteractionNonThrowing """let x = (failwith "fail" : int) """ + |> showErrors + |> shouldEqual ["exception fail"] + +[] +let ``EvalInteraction parse failure``() = + (try fsiSession.EvalInteraction """ let let let let x = """ |> ignore + false + with e -> true) + |> shouldEqual false // EvalInteraction doesn't fail for parse failures, it just reports errors. + +[] +let ``EvalInteraction parse failure nothrow``() = + fsiSession.EvalInteractionNonThrowing """ let let let let x = """ + |> showErrors + |> shouldEqual + ["exception Operation could not be completed due to earlier error"; + "error 1,5 - 1,8; Unexpected keyword 'let' or 'use' in binding"; + "warning 1,0 - 1,22; Possible incorrect indentation: this token is offside of context started at position (1:14). Try indenting this token further or using standard formatting conventions."; + "warning 1,22 - 1,22; Possible incorrect indentation: this token is offside of context started at position (1:14). Try indenting this token further or using standard formatting conventions."] + +[] +let ``PartialAssemblySignatureUpdated test``() = + let count = ref 0 + fsiSession.PartialAssemblySignatureUpdated.Add(fun x -> count := count.Value + 1) + count.Value |> shouldEqual 0 + fsiSession.EvalInteraction """ let x = 1 """ + count.Value |> shouldEqual 1 + fsiSession.EvalInteraction """ let x = 1 """ + count.Value |> shouldEqual 2 + + +[] +let ``ParseAndCheckInteraction test 1``() = + fsiSession.EvalInteraction """ let xxxxxx = 1 """ + fsiSession.EvalInteraction """ type CCCC() = member x.MMMMM() = 1 + 1 """ + let untypedResults, typedResults, _ = fsiSession.ParseAndCheckInteraction("xxxxxx") |> Async.RunSynchronously + Path.GetFileName(untypedResults.FileName) |> shouldEqual "stdin.fsx" + untypedResults.Errors.Length |> shouldEqual 0 + untypedResults.ParseHadErrors |> shouldEqual false + + // Check we can't get a declaration location for text in the F# interactive state (because the file doesn't exist) + // TODO: check that if we use # line directives, then the file will exist correctly + let identToken = FSharpTokenTag.IDENT + typedResults.GetDeclarationLocationAlternate(1,6,"xxxxxx",["xxxxxx"]) |> Async.RunSynchronously |> shouldEqual (FSharpFindDeclResult.DeclNotFound FSharpFindDeclFailureReason.NoSourceCode) + + // Check we can get a tooltip for text in the F# interactive state + let tooltip = + match typedResults.GetToolTipTextAlternate(1,6,"xxxxxx",["xxxxxx"],identToken) |> Async.RunSynchronously with + | FSharpToolTipText [FSharpToolTipElement.Single(text, FSharpXmlDoc.None)] -> text + | _ -> failwith "incorrect tool tip" + + Assert.True(tooltip.Contains("val xxxxxx : int")) + +[] +let ``ParseAndCheckInteraction test 2``() = + let fileName1 = Path.Combine(Path.Combine(__SOURCE_DIRECTORY__, "data"), "testscript.fsx") + File.WriteAllText(fileName1, "let x = 1") + let interaction1 = + sprintf """ +#load @"%s" +let y = Testscript.x + 1 +""" fileName1 + let untypedResults, typedResults, _ = fsiSession.ParseAndCheckInteraction interaction1 |> Async.RunSynchronously + Path.GetFileName(untypedResults.FileName) |> shouldEqual "stdin.fsx" + untypedResults.Errors.Length |> shouldEqual 0 + untypedResults.ParseHadErrors |> shouldEqual false + + +[] +let ``Bad arguments to session creation 1``() = + let inStream = new StringReader("") + let outStream = new CompilerOutputStream() + let errStream = new CompilerOutputStream() + let errWriter = new StreamWriter(errStream) + let fsiSession = + try + FsiEvaluationSession.Create(fsiConfig, [| "fsi.exe"; "-r:nonexistent.dll" |], inStream, new StreamWriter(outStream), errWriter) |> ignore + false + with _ -> true + Assert.True fsiSession + Assert.False (String.IsNullOrEmpty (errStream.Read())) // error stream contains some output + Assert.True (String.IsNullOrEmpty (outStream.Read())) // output stream contains no output + +[] +let ``Bad arguments to session creation 2``() = + let inStream = new StringReader("") + let outStream = new CompilerOutputStream() + let errStream = new CompilerOutputStream() + let errWriter = new StreamWriter(errStream) + let fsiSession = + try + FsiEvaluationSession.Create(fsiConfig, [| "fsi.exe"; "-badarg" |], inStream, new StreamWriter(outStream), errWriter) |> ignore + false + with _ -> true + Assert.True fsiSession + Assert.False (String.IsNullOrEmpty (errStream.Read())) // error stream contains some output + Assert.True (String.IsNullOrEmpty (outStream.Read())) // output stream contains no output + +[] +// Regression test for #184 +let ``EvalScript accepts paths verbatim``() = + // Path contains escape sequences (\b and \n) + // Let's ensure the exception thrown (if any) is FileNameNotResolved + (try + let scriptPath = @"C:\bad\path\no\donut.fsx" + fsiSession.EvalScript scriptPath |> ignore + false + with + | e -> + true) + |> shouldEqual true + +[] +// Regression test for #184 +let ``EvalScript accepts paths verbatim nothrow``() = + // Path contains escape sequences (\b and \n) + // Let's ensure the exception thrown (if any) is FileNameNotResolved + let scriptPath = @"C:\bad\path\no\donut.fsx" + fsiSession.EvalScriptNonThrowing scriptPath + |> showErrors + |> List.map (fun s -> s.[0..20]) // avoid seeing the hardwired paths + |> Seq.toList + |> shouldEqual + ["exception Operation c"; + "error 1,0 - 1,33; Una"] + + +[] +let ``Disposing interactive session (collectible)``() = + + let createSession i = + let defaultArgs = [|"fsi.exe";"--noninteractive";"--nologo";"--gui-"|] + let sbOut = StringBuilder() + use inStream = new StringReader("") + use outStream = new StringWriter(sbOut) + let sbErr = StringBuilder("") + use errStream = new StringWriter(sbErr) + + let fsiConfig = FsiEvaluationSession.GetDefaultConfiguration() + use session = FsiEvaluationSession.Create(fsiConfig, defaultArgs, inStream, outStream, errStream, collectible=true) + + session.EvalInteraction <| sprintf "let x%i = 42" i + + // Dynamic assemblies should be collected and handle count should not be increased + for i in 1 .. 50 do + printfn "iteration %d" i + createSession i + +[] +let ``interactive session events``() = + + let defaultArgs = [|"fsi.exe";"--noninteractive";"--nologo";"--gui-"|] + let sbOut = StringBuilder() + use inStream = new StringReader("") + use outStream = new StringWriter(sbOut) + let sbErr = StringBuilder("") + use errStream = new StringWriter(sbErr) + + let fsiConfig = FsiEvaluationSession.GetDefaultConfiguration() + let evals = ResizeArray() + use evaluator = fsiConfig.OnEvaluation.Subscribe (fun eval -> evals.Add (eval.FsiValue, eval.Name, eval.SymbolUse)) + + use session = FsiEvaluationSession.Create(fsiConfig, defaultArgs, inStream, outStream, errStream, collectible=true) + session.EvalInteraction "let x = 42" + + let value, name, symbol = evals.[0] + name |> should equal "x" + value.IsSome |> should equal true + value.Value.ReflectionValue |> should equal 42 + symbol.Symbol.GetType() |> should equal typeof + symbol.Symbol.DisplayName |> should equal "x" + + session.EvalInteraction "type C() = member x.P = 1" + + let value, name, symbol = evals.[1] + name |> should equal "C" + value.IsNone |> should equal true + symbol.Symbol.GetType() |> should equal typeof + symbol.Symbol.DisplayName |> should equal "C" + + session.EvalInteraction "module M = let x = ref 1" + let value, name, symbol = evals.[2] + name |> should equal "M" + value.IsNone |> should equal true + symbol.Symbol.GetType() |> should equal typeof + symbol.Symbol.DisplayName |> should equal "M" + +let RunManually() = + ``EvalExpression test 1``() + ``EvalExpression test 1 nothrow``() + ``EvalExpression fsi test``() + ``EvalExpression fsi test 2``() + ``EvalExpression typecheck failure``() + ``EvalExpression typecheck failure nothrow``() + ``EvalExpression function value 1``() + ``EvalExpression function value 2``() + ``EvalExpression runtime failure``() + ``EvalExpression parse failure``() + ``EvalExpression parse failure nothrow``() + ``EvalInteraction typecheck failure``() + ``EvalInteraction typecheck failure nothrow``() + ``EvalInteraction runtime failure``() + ``EvalInteraction runtime failure nothrow``() + ``EvalInteraction parse failure``() + ``EvalInteraction parse failure nothrow``() + ``PartialAssemblySignatureUpdated test``() + ``ParseAndCheckInteraction test 1``() + ``Bad arguments to session creation 1``() + ``Bad arguments to session creation 2``() + ``EvalScript accepts paths verbatim``() + ``EvalScript accepts paths verbatim nothrow``() + ``interactive session events``() + ``Disposing interactive session (collectible)``() + +//#endif diff --git a/tests/service/InteractiveCheckerTests.fs b/tests/service/InteractiveCheckerTests.fs new file mode 100644 index 00000000000..ea4ba10c015 --- /dev/null +++ b/tests/service/InteractiveCheckerTests.fs @@ -0,0 +1,100 @@ + +#if INTERACTIVE +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" +#load "FsUnit.fs" +#load "Common.fs" +#else +module FSharp.Compiler.Service.Tests.InteractiveChecker +#endif + +open NUnit.Framework +open FsUnit +open System +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.SourceCodeServices +open FSharp.Compiler.Service.Tests.Common + +let internal longIdentToString (longIdent: Ast.LongIdent) = + String.Join(".", longIdent |> List.map (fun ident -> ident.ToString())) +let internal longIdentWithDotsToString (Ast.LongIdentWithDots (longIdent, _)) = longIdentToString longIdent + +let internal posToTuple (pos: Range.pos) = (pos.Line, pos.Column) +let internal rangeToTuple (range: Range.range) = (posToTuple range.Start, posToTuple range.End) + +let internal identsAndRanges (input: Ast.ParsedInput) = + let identAndRange ident (range: Range.range) = + (ident, rangeToTuple range) + let extractFromComponentInfo (componentInfo: Ast.SynComponentInfo) = + let ((Ast.SynComponentInfo.ComponentInfo(_attrs, _typarDecls, _typarConstraints, longIdent, _, _, _, range))) = componentInfo + // TODO : attrs, typarDecls and typarConstraints + [identAndRange (longIdentToString longIdent) range] + let extractFromTypeDefn (typeDefn: Ast.SynTypeDefn) = + let (Ast.SynTypeDefn.TypeDefn(componentInfo, _repr, _members, _)) = typeDefn + // TODO : repr and members + extractFromComponentInfo componentInfo + let rec extractFromModuleDecl (moduleDecl: Ast.SynModuleDecl) = + match moduleDecl with + | Ast.SynModuleDecl.Types(typeDefns, _) -> (typeDefns |> List.collect extractFromTypeDefn) + | Ast.SynModuleDecl.ModuleAbbrev(ident, _, range) -> [ identAndRange (ident.ToString()) range ] + | Ast.SynModuleDecl.NestedModule(componentInfo, _, decls, _, _) -> (extractFromComponentInfo componentInfo) @ (decls |> List.collect extractFromModuleDecl) + | Ast.SynModuleDecl.Let(_, _, _) -> failwith "Not implemented yet" + | Ast.SynModuleDecl.DoExpr(_, _, _range) -> failwith "Not implemented yet" + | Ast.SynModuleDecl.Exception(_, _range) -> failwith "Not implemented yet" + | Ast.SynModuleDecl.Open(longIdentWithDots, range) -> [ identAndRange (longIdentWithDotsToString longIdentWithDots) range ] + | Ast.SynModuleDecl.Attributes(_attrs, _range) -> failwith "Not implemented yet" + | Ast.SynModuleDecl.HashDirective(_, _range) -> failwith "Not implemented yet" + | Ast.SynModuleDecl.NamespaceFragment(moduleOrNamespace) -> extractFromModuleOrNamespace moduleOrNamespace + and extractFromModuleOrNamespace (Ast.SynModuleOrNamespace(longIdent, _, _, moduleDecls, _, _, _, range)) = + (identAndRange (longIdentToString longIdent) range) :: (moduleDecls |> List.collect extractFromModuleDecl) + + match input with + | Ast.ParsedInput.ImplFile(Ast.ParsedImplFileInput(_, _, _, _, _, modulesOrNamespaces, _)) -> + modulesOrNamespaces |> List.collect extractFromModuleOrNamespace + | Ast.ParsedInput.SigFile _ -> [] + +let internal parseAndExtractRanges code = + let file = "Test" + let result = parseSourceCode (file, code) + match result with + | Some tree -> tree |> identsAndRanges + | None -> failwith "fail to parse..." + +let input = + """ + namespace N + + type Sample () = class end + """ + +[] +let ``Test ranges - namespace`` () = + let res = parseAndExtractRanges input + printfn "Test ranges - namespace, res = %A" res + res |> shouldEqual [("N", ((4, 4), (6, 0))); ("Sample", ((4, 9), (4, 15)))] + +let input2 = + """ + module M + + type Sample () = class end + """ + +[] +let ``Test ranges - module`` () = + let res = parseAndExtractRanges input2 + printfn "Test ranges - module, res = %A" res + res |> shouldEqual [("M", ((2, 4), (4, 26))); ("Sample", ((4, 9), (4, 15)))] + +let input3 = + """ + namespace global + + type Sample () = class end + """ + +[] +let ``Test ranges - global namespace`` () = + let res = parseAndExtractRanges input3 + printfn "Test ranges - global namespace, res = %A" res + res |> shouldEqual [("", ((4, 4), (6, 0))); ("Sample", ((4, 9), (4, 15)))] diff --git a/tests/service/MultiProjectAnalysisTests.fs b/tests/service/MultiProjectAnalysisTests.fs index 86f4ef50819..c5e6db145fd 100644 --- a/tests/service/MultiProjectAnalysisTests.fs +++ b/tests/service/MultiProjectAnalysisTests.fs @@ -1,24 +1,34 @@  #if INTERACTIVE -#r "../../Debug/net40/bin/FSharp.LanguageService.Compiler.dll" -#r "../../Debug/net40/bin/nunit.framework.dll" +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" #load "FsUnit.fs" #load "Common.fs" #else module Tests.Service.MultiProjectAnalysisTests #endif +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.SourceCodeServices + open NUnit.Framework open FsUnit open System open System.IO + +open System open System.Collections.Generic -open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.SourceCodeServices open FSharp.Compiler.Service.Tests.Common +let numProjectsForStressTest = 100 +let internal checker = FSharpChecker.Create(projectCacheSize=numProjectsForStressTest + 10) + +/// Extract range info +let internal tups (m:Range.range) = (m.StartLine, m.StartColumn), (m.EndLine, m.EndColumn) + -module Project1A = +module internal Project1A = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -42,12 +52,12 @@ let x2 = C.M(arg1 = 3, arg2 = 4, ?arg3 = Some 5) let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) //----------------------------------------------------------------------------------------- -module Project1B = +module internal Project1B = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -71,11 +81,11 @@ let x = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) // A project referencing two sub-projects -module MultiProject1 = +module internal MultiProject1 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -96,7 +106,7 @@ let p = (Project1A.x1, Project1B.b) let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = + let options = let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) { options with OtherOptions = Array.append options.OtherOptions [| ("-r:" + Project1A.dllName); ("-r:" + Project1B.dllName) |] @@ -111,6 +121,9 @@ let ``Test multi project 1 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(MultiProject1.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "multi project 1 error: <<<%s>>>" e.Message + wholeProjectResults .Errors.Length |> shouldEqual 0 wholeProjectResults.ProjectContext.GetReferencedAssemblies().Length |> shouldEqual 6 @@ -242,6 +255,10 @@ let ``Test ManyProjectsStressTest whole project errors`` () = let checker = ManyProjectsStressTest.makeCheckerForStressTest true let wholeProjectResults = checker.ParseAndCheckProject(ManyProjectsStressTest.jointProject.Options) |> Async.RunSynchronously + let wholeProjectResults = checker.ParseAndCheckProject(ManyProjectsStressTest.jointProject.Options) |> Async.RunSynchronously + + for e in wholeProjectResults.Errors do + printfn "ManyProjectsStressTest error: <<<%s>>>" e.Message wholeProjectResults .Errors.Length |> shouldEqual 0 wholeProjectResults.ProjectContext.GetReferencedAssemblies().Length |> shouldEqual (ManyProjectsStressTest.numProjectsForStressTest + 4) @@ -279,8 +296,6 @@ let ``Test ManyProjectsStressTest cache too small`` () = [ for x in wholeProjectResults.AssemblySignature.Entities.[0].MembersFunctionsAndValues -> x.DisplayName ] |> shouldEqual ["p"] - for d in disposals do d.Dispose() - [] let ``Test ManyProjectsStressTest all symbols`` () = @@ -531,7 +546,7 @@ let ``Test multi project symbols should pick up changes in dependent projects`` //------------------------------------------------------------------ -module Project2A = +module internal Project2A = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -557,11 +572,11 @@ type C() = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) //Project2A.fileSource1 // A project referencing Project2A -module Project2B = +module internal Project2B = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -577,7 +592,7 @@ let v = Project2A.C().InternalMember // access an internal symbol let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = + let options = let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) { options with OtherOptions = Array.append options.OtherOptions [| ("-r:" + Project2A.dllName); |] @@ -586,7 +601,7 @@ let v = Project2A.C().InternalMember // access an internal symbol //Project2A.fileSource1 // A project referencing Project2A but without access to the internals of A -module Project2C = +module internal Project2C = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -602,7 +617,7 @@ let v = Project2A.C().InternalMember // access an internal symbol let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = + let options = let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) { options with OtherOptions = Array.append options.OtherOptions [| ("-r:" + Project2A.dllName); |] @@ -613,6 +628,9 @@ let v = Project2A.C().InternalMember // access an internal symbol let ``Test multi project2 errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project2B.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "multi project2 error: <<<%s>>>" e.Message + wholeProjectResults .Errors.Length |> shouldEqual 0 @@ -648,7 +666,7 @@ let ``Test multi project 2 all symbols`` () = //------------------------------------------------------------------------------------ -module Project3A = +module internal Project3A = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -668,11 +686,11 @@ let (|DivisibleBy|_|) by n = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) // A project referencing a sub-project -module MultiProject3 = +module internal MultiProject3 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -694,7 +712,7 @@ let fizzBuzz = function let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = + let options = let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) { options with OtherOptions = Array.append options.OtherOptions [| ("-r:" + Project3A.dllName) |] @@ -705,6 +723,8 @@ let fizzBuzz = function let ``Test multi project 3 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(MultiProject3.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "multi project 3 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -731,3 +751,39 @@ let ``Test active patterns' XmlDocSig declared in referenced projects`` () = let divisibleByEntity = divisibleByGroup.EnclosingEntity.Value divisibleByEntity.ToString() |> shouldEqual "Project3A" +//------------------------------------------------------------------------------------ + + + +[] +let ``Test max memory gets triggered`` () = + let checker = FSharpChecker.Create() + let reached = ref false + checker.MaxMemoryReached.Add (fun () -> reached := true) + let wholeProjectResults = checker.ParseAndCheckProject(MultiProject3.options) |> Async.RunSynchronously + reached.Value |> shouldEqual false + checker.MaxMemory <- 0 + let wholeProjectResults2 = checker.ParseAndCheckProject(MultiProject3.options) |> Async.RunSynchronously + reached.Value |> shouldEqual true + let wholeProjectResults3 = checker.ParseAndCheckProject(MultiProject3.options) |> Async.RunSynchronously + reached.Value |> shouldEqual true + + +//------------------------------------------------------------------------------------ + +#if FX_ATLEAST_45 + +[] +let ``Type provider project references should not throw exceptions`` () = + let projectFile = __SOURCE_DIRECTORY__ + @"/data/TypeProviderConsole/TypeProviderConsole.fsproj" + let options = ProjectCracker.GetProjectOptionsFromProjectFile(projectFile, [("Configuration", "Debug")]) + //printfn "options: %A" options + let fileName = __SOURCE_DIRECTORY__ + @"/data/TypeProviderConsole/Program.fs" + let fileSource = File.ReadAllText(fileName) + let fileCheckResults, _ = checker.ParseAndCheckFileInProject(fileName, 0, fileSource, options) |> Async.RunSynchronously + //printfn "Errors: %A" fileCheckResults.Errors + fileCheckResults.Errors |> Array.exists (fun error -> error.Severity = FSharpErrorSeverity.Error) |> shouldEqual false + +#endif + +//------------------------------------------------------------------------------------ diff --git a/tests/service/PerfTests.fs b/tests/service/PerfTests.fs new file mode 100644 index 00000000000..f579897b69f --- /dev/null +++ b/tests/service/PerfTests.fs @@ -0,0 +1,79 @@ +#if INTERACTIVE +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" +#load "FsUnit.fs" +#load "Common.fs" +#else +module FSharp.Compiler.Service.Tests.PerfTests +#endif + + +open NUnit.Framework +open FsUnit +open System +open System.IO +open System.Collections.Generic + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.SourceCodeServices + +open FSharp.Compiler.Service.Tests.Common + +// Create an interactive checker instance +let internal checker = FSharpChecker.Create() + +module internal Project1 = + open System.IO + + let fileNamesI = [ for i in 1 .. 10 -> (i, Path.ChangeExtension(Path.GetTempFileName(), ".fs")) ] + let base2 = Path.GetTempFileName() + let dllName = Path.ChangeExtension(base2, ".dll") + let projFileName = Path.ChangeExtension(base2, ".fsproj") + let fileSources = [ for (i,f) in fileNamesI -> (f, "module M" + string i) ] + for (f,text) in fileSources do File.WriteAllText(f, text) + let fileSources2 = [ for (i,f) in fileSources -> f ] + + let fileNames = [ for (_,f) in fileNamesI -> f ] + let args = mkProjectCommandLineArgs (dllName, fileNames) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + + +[] +let ``Test request for parse and check doesn't check whole project`` () = + + let backgroundParseCount = ref 0 + let backgroundCheckCount = ref 0 + checker.FileChecked.Add (fun x -> incr backgroundCheckCount) + checker.FileParsed.Add (fun x -> incr backgroundParseCount) + + let pB, tB = FSharpChecker.GlobalForegroundParseCountStatistic, FSharpChecker.GlobalForegroundTypeCheckCountStatistic + let parseResults1 = checker.ParseFileInProject(Project1.fileNames.[5], Project1.fileSources2.[5], Project1.options) |> Async.RunSynchronously + let pC, tC = FSharpChecker.GlobalForegroundParseCountStatistic, FSharpChecker.GlobalForegroundTypeCheckCountStatistic + (pC - pB) |> shouldEqual 1 + (tC - tB) |> shouldEqual 0 + backgroundParseCount.Value |> shouldEqual 0 + backgroundCheckCount.Value |> shouldEqual 0 + let checkResults1 = checker.CheckFileInProject(parseResults1, Project1.fileNames.[5], 0, Project1.fileSources2.[5], Project1.options) |> Async.RunSynchronously + let pD, tD = FSharpChecker.GlobalForegroundParseCountStatistic, FSharpChecker.GlobalForegroundTypeCheckCountStatistic + backgroundParseCount.Value |> shouldEqual 5 + backgroundCheckCount.Value |> shouldEqual 5 + (pD - pC) |> shouldEqual 0 + (tD - tC) |> shouldEqual 1 + + let checkResults2 = checker.CheckFileInProject(parseResults1, Project1.fileNames.[7], 0, Project1.fileSources2.[7], Project1.options) |> Async.RunSynchronously + let pE, tE = FSharpChecker.GlobalForegroundParseCountStatistic, FSharpChecker.GlobalForegroundTypeCheckCountStatistic + (pE - pD) |> shouldEqual 0 + (tE - tD) |> shouldEqual 1 + (backgroundParseCount.Value <= 8) |> shouldEqual true // but note, the project does not get reparsed + (backgroundCheckCount.Value <= 8) |> shouldEqual true // only two extra typechecks of files + + // A subsequent ParseAndCheck of identical source code doesn't do any more anything + let checkResults2 = checker.ParseAndCheckFileInProject(Project1.fileNames.[7], 0, Project1.fileSources2.[7], Project1.options) |> Async.RunSynchronously + let pF, tF = FSharpChecker.GlobalForegroundParseCountStatistic, FSharpChecker.GlobalForegroundTypeCheckCountStatistic + (pF - pE) |> shouldEqual 0 // note, no new parse of the file + (tF - tE) |> shouldEqual 0 // note, no new typecheck of the file + (backgroundParseCount.Value <= 8) |> shouldEqual true // but note, the project does not get reparsed + (backgroundCheckCount.Value <= 8) |> shouldEqual true // only two extra typechecks of files + + () + diff --git a/tests/service/Program.fs b/tests/service/Program.fs new file mode 100644 index 00000000000..45d9a343374 --- /dev/null +++ b/tests/service/Program.fs @@ -0,0 +1,14 @@ +open System +open System.IO +open System.Reflection +open NUnitLite +open NUnit.Common + +type private TypeInThisAssembly = class end + +[] +let main argv = + printfn "Dotnet Core NUnit Tests..." + let writer = new ExtendedTextWrapper(Console.Out) + let runner = new AutoRun(typeof.GetTypeInfo().Assembly) + runner.Execute(argv, writer, Console.In) diff --git a/tests/service/ProjectAnalysisTests.fs b/tests/service/ProjectAnalysisTests.fs index a79c445a604..d2802ba4bf9 100644 --- a/tests/service/ProjectAnalysisTests.fs +++ b/tests/service/ProjectAnalysisTests.fs @@ -1,6 +1,6 @@ #if INTERACTIVE -#r "../../Debug/net40/bin/FSharp.LanguageService.Compiler.dll" -#r "../../Debug/net40/bin/nunit.framework.dll" +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" #load "FsUnit.fs" #load "Common.fs" #else @@ -87,10 +87,9 @@ let mmmm2 : M.CAbbrev = new M.CAbbrev() // note, these don't count as uses of C let fileNames = [fileName1; fileName2] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) let cleanFileName a = if a = fileName1 then "file1" else if a = fileName2 then "file2" else "??" - [] let ``Test project1 whole project errors`` () = @@ -109,7 +108,11 @@ let ``Test project1 whole project errors`` () = let ``Test Project1 should have protected FullName and TryFullName return same results`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project1.options) |> Async.RunSynchronously let rec getFullNameComparisons (entity: FSharpEntity) = + #if EXTENSIONTYPING seq { if not entity.IsProvided && entity.Accessibility.IsPublic then + #else + seq { if entity.Accessibility.IsPublic then + #endif yield (entity.TryFullName = try Some entity.FullName with _ -> None) for e in entity.NestedEntities do yield! getFullNameComparisons e } @@ -122,8 +125,12 @@ let ``Test Project1 should have protected FullName and TryFullName return same r [] let ``Test project1 should not throw exceptions on entities from referenced assemblies`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project1.options) |> Async.RunSynchronously - let rec getAllBaseTypes (entity: FSharpEntity) = + let rec getAllBaseTypes (entity: FSharpEntity) = + #if EXTENSIONTYPING seq { if not entity.IsProvided && entity.Accessibility.IsPublic then + #else + seq{ + #endif if not entity.IsUnresolved then yield entity.BaseType for e in entity.NestedEntities do yield! getAllBaseTypes e } @@ -521,6 +528,7 @@ let ``Test project1 all uses of all symbols`` () = set expected - set allUsesOfAllSymbols |> shouldEqual Set.empty (set expected = set allUsesOfAllSymbols) |> shouldEqual true +#if EXTENSIONTYPING [] let ``Test file explicit parse symbols`` () = @@ -607,11 +615,11 @@ let ``Test file explicit parse all symbols`` () = ("C", "file1", ((9, 15), (9, 16)), ["class"]); ("CAbbrev", "file1", ((9, 5), (9, 12)), ["abbrev"]); ("M", "file1", ((1, 7), (1, 8)), ["module"])] - +#endif //----------------------------------------------------------------------------------------- -module Project2 = +module internal Project2 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -648,7 +656,7 @@ let _ = GenericFunction(3, 4) let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) @@ -808,7 +816,7 @@ let ``Test project2 all uses of all symbols`` () = //----------------------------------------------------------------------------------------- -module Project3 = +module internal Project3 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -900,7 +908,7 @@ let getM (foo: IFoo) = foo.InterfaceMethod("d") let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) @@ -1249,7 +1257,7 @@ let ``Test project3 all uses of all signature symbols`` () = //----------------------------------------------------------------------------------------- -module Project4 = +module internal Project4 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -1267,7 +1275,7 @@ let inline twice(x : ^U, y : ^U) = x + y let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) @@ -1404,7 +1412,7 @@ let ``Test project4 T symbols`` () = //----------------------------------------------------------------------------------------- -module Project5 = +module internal Project5 = open System.IO @@ -1442,13 +1450,15 @@ let parseNumeric str = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test project5 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project5.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project5 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -1622,7 +1632,7 @@ let ``Test partial active patterns' exact ranges from uses of symbols`` () = //----------------------------------------------------------------------------------------- -module Project6 = +module internal Project6 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -1643,13 +1653,15 @@ let f () = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test project6 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project6.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project6 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -1674,7 +1686,7 @@ let ``Test project 6 all symbols`` () = //----------------------------------------------------------------------------------------- -module Project7 = +module internal Project7 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -1698,13 +1710,15 @@ let x2 = C.M(arg1 = 3, arg2 = 4, ?arg3 = Some 5) let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test project7 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project7.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project7 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -1734,7 +1748,7 @@ let ``Test project 7 all symbols`` () = //----------------------------------------------------------------------------------------- -module Project8 = +module internal Project8 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -1758,13 +1772,15 @@ let x = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test project8 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project8.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project8 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -1817,7 +1833,7 @@ let ``Test project 8 all symbols`` () = (Some ((4, 14), (4, 17)), "file1", ((10, 9), (10, 12)))|] //----------------------------------------------------------------------------------------- -module Project9 = +module internal Project9 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -1837,13 +1853,15 @@ let inline check< ^T when ^T : (static member IsInfinity : ^T -> bool)> (num: ^T let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test project9 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project9.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project9 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -1893,7 +1911,7 @@ let ``Test project 9 all symbols`` () = //----------------------------------------------------------------------------------------- // see https://github.com/fsharp/FSharp.Compiler.Service/issues/95 -module Project10 = +module internal Project10 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -1915,13 +1933,15 @@ C.M("http://goo", query = 1) let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project10 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project10.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project10 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -1974,7 +1994,7 @@ let ``Test Project10 all symbols`` () = //----------------------------------------------------------------------------------------- // see https://github.com/fsharp/FSharp.Compiler.Service/issues/92 -module Project11 = +module internal Project11 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -1994,13 +2014,15 @@ let fff (x:System.Collections.Generic.Dictionary.Enumerator) = () let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project11 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project11.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project11 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2045,7 +2067,7 @@ let ``Test Project11 all symbols`` () = //----------------------------------------------------------------------------------------- // see https://github.com/fsharp/FSharp.Compiler.Service/issues/92 -module Project12 = +module internal Project12 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2067,13 +2089,15 @@ let x2 = query { for i in 0 .. 100 do let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project12 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project12.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project12 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2112,7 +2136,7 @@ let ``Test Project12 all symbols`` () = //----------------------------------------------------------------------------------------- // Test fetching information about some external types (e.g. System.Object, System.DateTime) -module Project13 = +module internal Project13 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2133,13 +2157,15 @@ let x3 = new System.DateTime() let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project13 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project13.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project13 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2186,7 +2212,9 @@ let ``Test Project13 all symbols`` () = ["type System.IComparable"; "type System.IFormattable"; "type System.IConvertible"; +#if !DOTNETCORE "type System.Runtime.Serialization.ISerializable"; +#endif "type System.IComparable"; "type System.IEquatable"]) @@ -2260,7 +2288,7 @@ let ``Test Project13 all symbols`` () = //----------------------------------------------------------------------------------------- // Misc - structs -module Project14 = +module internal Project14 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2284,13 +2312,15 @@ let x2 = S(3) let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project14 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project14.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project14 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2327,7 +2357,7 @@ let ``Test Project14 all symbols`` () = //----------------------------------------------------------------------------------------- // Misc - union patterns -module Project15 = +module internal Project15 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2351,13 +2381,15 @@ let f x = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project15 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project15.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project15 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2385,7 +2417,7 @@ let ``Test Project15 all symbols`` () = //----------------------------------------------------------------------------------------- // Misc - signature files -module Project16 = +module internal Project16 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2435,13 +2467,15 @@ and G = Case1 | Case2 of int let fileNames = [sigFileName1; fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project16 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project16.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project16 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2591,12 +2625,73 @@ let ``Test Project16 sig symbols are equal to impl symbols`` () = testFind ("implementation", symbolsImpl) ("implementation", symbolsImpl) // of course this should pass... testFind ("signature", symbolsSig) ("signature", symbolsSig) // of course this should pass... +[] +let ``Test Project16 sym locations`` () = + + let wholeProjectResults = checker.ParseAndCheckProject(Project16.options) |> Async.RunSynchronously + + let fmtLoc (mOpt: Range.range option) = + match mOpt with + | None -> None + | Some m -> + let file = Project16.cleanFileName m.FileName + if file = "??" then None + else Some (file, (m.StartLine, m.StartColumn), (m.EndLine, m.EndColumn )) + + let allUsesOfAllSymbols = + wholeProjectResults.GetAllUsesOfAllSymbols() + |> Async.RunSynchronously + |> Array.choose (fun su -> + match fmtLoc su.Symbol.SignatureLocation, fmtLoc su.Symbol.DeclarationLocation, fmtLoc su.Symbol.ImplementationLocation with + | Some a, Some b, Some c -> Some (su.Symbol.ToString(), a, b, c) + | _ -> None) + + allUsesOfAllSymbols |> shouldEqual + [|("field Field1", ("sig1", (16, 10), (16, 16)),("sig1", (16, 10), (16, 16)), ("file1", (13, 10), (13, 16))); + ("field Field2", ("sig1", (16, 24), (16, 30)),("sig1", (16, 24), (16, 30)), ("file1", (13, 24), (13, 30))); + ("Case1", ("sig1", (17, 8), (17, 13)), ("sig1", (17, 8), (17, 13)),("file1", (14, 8), (14, 13))); + ("Case2", ("sig1", (17, 16), (17, 21)), ("sig1", (17, 16), (17, 21)),("file1", (14, 16), (14, 21))); + ("C", ("sig1", (4, 5), (4, 6)), ("sig1", (4, 5), (4, 6)),("file1", (4, 5), (4, 6))); + ("C", ("sig1", (4, 5), (4, 6)), ("sig1", (4, 5), (4, 6)),("file1", (4, 5), (4, 6))); + ("member .ctor", ("sig1", (5, 4), (5, 7)), ("sig1", (5, 4), (5, 7)),("file1", (4, 5), (4, 6))); + ("member get_PC", ("sig1", (6, 11), (6, 13)), ("sig1", (6, 11), (6, 13)),("file1", (5, 13), (5, 15))); + ("D", ("sig1", (8, 14), (8, 15)), ("sig1", (8, 14), (8, 15)),("file1", (7, 4), (7, 5))); + ("D", ("sig1", (8, 14), (8, 15)), ("sig1", (8, 14), (8, 15)),("file1", (7, 4), (7, 5))); + ("member .ctor", ("sig1", (9, 4), (9, 7)), ("sig1", (9, 4), (9, 7)),("file1", (7, 4), (7, 5))); + ("member get_PD", ("sig1", (10, 11), (10, 13)),("sig1", (10, 11), (10, 13)), ("file1", (8, 13), (8, 15))); + ("E", ("sig1", (12, 14), (12, 15)), ("sig1", (12, 14), (12, 15)),("file1", (10, 4), (10, 5))); + ("E", ("sig1", (12, 14), (12, 15)), ("sig1", (12, 14), (12, 15)),("file1", (10, 4), (10, 5))); + ("member .ctor", ("sig1", (13, 4), (13, 7)), ("sig1", (13, 4), (13, 7)),("file1", (10, 4), (10, 5))); + ("member get_PE", ("sig1", (14, 11), (14, 13)),("sig1", (14, 11), (14, 13)), ("file1", (11, 13), (11, 15))); + ("F", ("sig1", (16, 4), (16, 5)), ("sig1", (16, 4), (16, 5)),("file1", (13, 4), (13, 5))); + ("G", ("sig1", (17, 4), (17, 5)), ("sig1", (17, 4), (17, 5)),("file1", (14, 4), (14, 5))); + ("Impl", ("sig1", (2, 7), (2, 11)), ("sig1", (2, 7), (2, 11)),("file1", (2, 7), (2, 11))); + ("field Field1", ("sig1", (16, 10), (16, 16)),("file1", (13, 10), (13, 16)), ("file1", (13, 10), (13, 16))); + ("field Field2", ("sig1", (16, 24), (16, 30)),("file1", (13, 24), (13, 30)), ("file1", (13, 24), (13, 30))); + ("Case1", ("sig1", (17, 8), (17, 13)), ("file1", (14, 8), (14, 13)),("file1", (14, 8), (14, 13))); + ("Case2", ("sig1", (17, 16), (17, 21)), ("file1", (14, 16), (14, 21)),("file1", (14, 16), (14, 21))); + ("C", ("sig1", (4, 5), (4, 6)), ("file1", (4, 5), (4, 6)),("file1", (4, 5), (4, 6))); + ("D", ("sig1", (8, 14), (8, 15)), ("file1", (7, 4), (7, 5)),("file1", (7, 4), (7, 5))); + ("E", ("sig1", (12, 14), (12, 15)), ("file1", (10, 4), (10, 5)),("file1", (10, 4), (10, 5))); + ("F", ("sig1", (16, 4), (16, 5)), ("file1", (13, 4), (13, 5)),("file1", (13, 4), (13, 5))); + ("G", ("sig1", (17, 4), (17, 5)), ("file1", (14, 4), (14, 5)),("file1", (14, 4), (14, 5))); + ("member .ctor", ("sig1", (5, 4), (5, 7)), ("file1", (4, 5), (4, 6)),("file1", (4, 5), (4, 6))); + ("member get_PC", ("sig1", (6, 11), (6, 13)), ("file1", (5, 13), (5, 15)),("file1", (5, 13), (5, 15))); + ("member .ctor", ("sig1", (9, 4), (9, 7)), ("file1", (7, 4), (7, 5)),("file1", (7, 4), (7, 5))); + ("member get_PD", ("sig1", (10, 11), (10, 13)),("file1", (8, 13), (8, 15)), ("file1", (8, 13), (8, 15))); + ("member .ctor", ("sig1", (13, 4), (13, 7)), ("file1", (10, 4), (10, 5)),("file1", (10, 4), (10, 5))); + ("member get_PE", ("sig1", (14, 11), (14, 13)),("file1", (11, 13), (11, 15)), ("file1", (11, 13), (11, 15))); + ("val x", ("file1", (5, 11), (5, 12)), ("file1", (5, 11), (5, 12)),("file1", (5, 11), (5, 12))); + ("val x", ("file1", (8, 11), (8, 12)), ("file1", (8, 11), (8, 12)),("file1", (8, 11), (8, 12))); + ("val x", ("file1", (11, 11), (11, 12)), ("file1", (11, 11), (11, 12)),("file1", (11, 11), (11, 12))); + ("Impl", ("sig1", (2, 7), (2, 11)), ("file1", (2, 7), (2, 11)),("file1", (2, 7), (2, 11)))|] + //----------------------------------------------------------------------------------------- // Misc - namespace symbols -module Project17 = +module internal Project17 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2619,13 +2714,15 @@ let f3 (x: System.Exception) = x.HelpLink <- "" // check use of .NET setter prop let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project17 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project17.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project17 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2694,7 +2791,7 @@ let ``Test Project17 all symbols`` () = //----------------------------------------------------------------------------------------- // Misc - generic type definnitions -module Project18 = +module internal Project18 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2711,13 +2808,15 @@ let _ = list<_>.Empty let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project18 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project18.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project18 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2743,7 +2842,7 @@ let ``Test Project18 all symbols`` () = //----------------------------------------------------------------------------------------- // Misc - enums -module Project19 = +module internal Project19 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2766,13 +2865,15 @@ let s = System.DayOfWeek.Monday let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project19 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project19.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project19 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2820,7 +2921,7 @@ let ``Test Project19 all symbols`` () = //----------------------------------------------------------------------------------------- // Misc - https://github.com/fsharp/FSharp.Compiler.Service/issues/109 -module Project20 = +module internal Project20 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2839,13 +2940,15 @@ type A<'T>() = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project20 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project20.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project20 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2871,7 +2974,7 @@ let ``Test Project20 all symbols`` () = //----------------------------------------------------------------------------------------- // Misc - https://github.com/fsharp/FSharp.Compiler.Service/issues/137 -module Project21 = +module internal Project21 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2899,13 +3002,15 @@ let _ = { new IMyInterface with let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project21 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project21.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project21 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 2 @@ -2948,7 +3053,7 @@ let ``Test Project21 all symbols`` () = //----------------------------------------------------------------------------------------- // Misc - namespace symbols -module Project22 = +module internal Project22 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -2964,13 +3069,15 @@ type AnotherMutableList() = let f1 (x: System.Collections.Generic.IList<'T>) = () // grab the IList symbol and look into it let f2 (x: AnotherMutableList) = () // grab the AnotherMutableList symbol and look into it let f3 (x: System.Collections.ObjectModel.ObservableCollection<'T>) = () // grab the ObservableCollection symbol and look into it +let f4 (x: int[]) = () // test a one-dimensional array +let f5 (x: int[,,]) = () // test a multi-dimensional array """ File.WriteAllText(fileName1, fileSource1) let cleanFileName a = if a = fileName1 then "file1" else "??" let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) @@ -2978,6 +3085,8 @@ let f3 (x: System.Collections.ObjectModel.ObservableCollection<'T>) = () // grab let ``Test Project22 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project22.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project22 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -2986,21 +3095,33 @@ let ``Test Project22 IList contents`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project22.options) |> Async.RunSynchronously - let ilistTypeUse = + let allUsesOfAllSymbols = wholeProjectResults.GetAllUsesOfAllSymbols() |> Async.RunSynchronously + + let ilistTypeUse = + allUsesOfAllSymbols |> Array.find (fun su -> su.Symbol.DisplayName = "IList") let ocTypeUse = - wholeProjectResults.GetAllUsesOfAllSymbols() - |> Async.RunSynchronously + allUsesOfAllSymbols |> Array.find (fun su -> su.Symbol.DisplayName = "ObservableCollection") let alistTypeUse = - wholeProjectResults.GetAllUsesOfAllSymbols() - |> Async.RunSynchronously + allUsesOfAllSymbols |> Array.find (fun su -> su.Symbol.DisplayName = "AnotherMutableList") + let allTypes = + allUsesOfAllSymbols + |> Array.choose (fun su -> match su.Symbol with :? FSharpMemberOrFunctionOrValue as s -> Some s.FullType | _ -> None ) + + let arrayTypes = + allTypes + |> Array.choose (fun t -> + if t.HasTypeDefinition then + let td = t.TypeDefinition + if td.IsArrayType then Some (td.DisplayName, td.ArrayRank) else None + else None ) let ilistTypeDefn = ilistTypeUse.Symbol :?> FSharpEntity let ocTypeDefn = ocTypeUse.Symbol :?> FSharpEntity @@ -3049,6 +3170,8 @@ let ``Test Project22 IList contents`` () = (set [("IList", ["interface"]); ("ICollection", ["interface"]); ("IEnumerable", ["interface"]); ("IEnumerable", ["interface"])]) + arrayTypes |> shouldEqual [|("[]", 1); ("[,,]", 3)|] + [] let ``Test Project22 IList properties`` () = @@ -3063,12 +3186,14 @@ let ``Test Project22 IList properties`` () = attribsOfSymbol ilistTypeDefn |> shouldEqual ["interface"] - ilistTypeDefn.Assembly.SimpleName |> shouldEqual "mscorlib" +#if !TODO_REWORK_ASSEMBLY_LOAD + ilistTypeDefn.Assembly.SimpleName |> shouldEqual coreLibAssemblyName +#endif //----------------------------------------------------------------------------------------- // Misc - properties -module Project23 = +module internal Project23 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -3100,12 +3225,14 @@ module Setter = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project23 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project23.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project23 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 [] @@ -3199,7 +3326,7 @@ let ``Test Project23 extension properties' getters/setters should refer to the c ("System.Int32", "Impl.Getter", ["member"; "prop"; "extmem"]) ] // Misc - property symbols -module Project24 = +module internal Project24 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -3268,11 +3395,13 @@ TypeWithProperties.StaticAutoPropGetSet <- 3 let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project24 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project24.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project24 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 [] @@ -3496,9 +3625,10 @@ let ``Test symbol uses of properties with both getters and setters`` () = usesOfGetSampleSymbol |> shouldEqual [|("file1", ((9, 13), (9, 20))); ("file1", ((36, 9), (36, 37)))|] -#if CHECK_USE_OF_FSHARP_DATA_DLL +#if NO_CHECK_USE_OF_FSHARP_DATA_DLL +#endif // Misc - type provider symbols -module Project25 = +module internal Project25 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -3522,19 +3652,27 @@ let _ = XmlProvider<"13">.GetSample() let fileNames = [fileName1] let args = [| yield! mkProjectCommandLineArgs (dllName, fileNames) - yield "-r:" + Path.Combine(__SOURCE_DIRECTORY__, "FSharp.Data.dll") + yield @"-r:" + Path.Combine(__SOURCE_DIRECTORY__, Path.Combine("data", "FSharp.Data.dll")) yield @"-r:" + sysLib "System.Xml.Linq" |] - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) +#if DOTNETCORE +[] +#else [] +#endif let ``Test Project25 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project25.options) |> Async.RunSynchronously for e in wholeProjectResults.Errors do printfn "Project25 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 +#if DOTNETCORE +[] +#else [] -let ``Test symbol uses of type-provided members`` () = +#endif +let ``Test Project25 symbol uses of type-provided members`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project25.options) |> Async.RunSynchronously let backgroundParseResults1, backgroundTypedParse1 = checker.GetBackgroundCheckResultsForFileInProject(Project25.fileName1, Project25.options) @@ -3586,7 +3724,11 @@ let ``Test symbol uses of type-provided members`` () = usesOfGetSampleSymbol |> shouldEqual [|("file1", ((5, 8), (5, 25))); ("file1", ((10, 8), (10, 78)))|] +#if DOTNETCORE +[] +#else [] +#endif let ``Test symbol uses of type-provided types`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project25.options) |> Async.RunSynchronously let backgroundParseResults1, backgroundTypedParse1 = @@ -3625,9 +3767,9 @@ let ``Test symbol uses of fully-qualified records`` () = |> Array.map (fun s -> (Project25.cleanFileName s.FileName, tups s.RangeAlternate)) usesOfGetSampleSymbol |> shouldEqual [|("file1", ((7, 5), (7, 11))); ("file1", ((8, 10), (8, 16)))|] -#endif -module Project26 = + +module internal Project26 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -3650,13 +3792,15 @@ type Class() = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project26 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project26.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project26 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 @@ -3713,7 +3857,7 @@ let ``Test Project26 parameter symbols`` () = ("M2", None, "type Microsoft.FSharp.Core.unit", ""); ("M3", None, "type Microsoft.FSharp.Core.unit", "")]) -module Project27 = +module internal Project27 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -3735,7 +3879,7 @@ type CFooImpl() = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test project27 whole project errors`` () = @@ -3759,7 +3903,7 @@ let ``Test project27 all symbols in signature`` () = ("member .ctor", ["member"; "ctor"]); ("member AbstractMethod", ["member"; "overridemem"])] -module Project28 = +module internal Project28 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -3801,8 +3945,8 @@ type Use() = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) - + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) +#if EXTENSIONTYPING [] let ``Test project28 all symbols in signature`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project28.options) |> Async.RunSynchronously @@ -3812,14 +3956,18 @@ let ``Test project28 all symbols in signature`` () = |> Seq.map (fun s -> let typeName = s.GetType().Name match s with + #if EXTENSIONTYPING | :? FSharpEntity as fse -> typeName, fse.DisplayName, fse.XmlDocSig + #endif | :? FSharpField as fsf -> typeName, fsf.DisplayName, fsf.XmlDocSig | :? FSharpMemberOrFunctionOrValue as fsm -> typeName, fsm.DisplayName, fsm.XmlDocSig | :? FSharpUnionCase as fsu -> typeName, fsu.DisplayName, fsu.XmlDocSig | :? FSharpActivePatternCase as ap -> typeName, ap.DisplayName, ap.XmlDocSig | :? FSharpGenericParameter as fsg -> typeName, fsg.DisplayName, "" | :? FSharpParameter as fsp -> typeName, fsp.DisplayName, "" + #if EXTENSIONTYPING | :? FSharpStaticParameter as fss -> typeName, fss.DisplayName, "" + #endif | _ -> typeName, s.DisplayName, "unknown") |> Seq.toArray @@ -3857,8 +4005,8 @@ let ``Test project28 all symbols in signature`` () = ("FSharpMemberOrFunctionOrValue", "( .ctor )", "M:M.Use.#ctor"); ("FSharpMemberOrFunctionOrValue", "Test", "M:M.Use.Test``1(``0)"); ("FSharpGenericParameter", "?", "")|] - -module Project29 = +#endif +module internal Project29 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -3874,13 +4022,15 @@ let f (x: INotifyPropertyChanged) = failwith "" let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test project29 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project29.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project29 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 [] @@ -3913,7 +4063,7 @@ let ``Test project29 event symbols`` () = ("remove_PropertyChanged", None, "unit")]) -module Project30 = +module internal Project30 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -3932,11 +4082,13 @@ type T() = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) let ``Test project30 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project30.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project30 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 [] @@ -3972,7 +4124,7 @@ let ``Test project30 Format attributes`` () = [("""[]""", """[]""")]) -module Project31 = +module internal Project31 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -3992,30 +4144,38 @@ let g = Console.ReadKey() let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) let ``Test project31 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project31.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project31 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 [] +#if DOTNETCORE +[] +#endif let ``Test project31 C# type attributes`` () = if not runningOnMono then let wholeProjectResults = checker.ParseAndCheckProject(Project31.options) |> Async.RunSynchronously let objSymbol = wholeProjectResults.GetAllUsesOfAllSymbols() |> Async.RunSynchronously |> Array.find (fun su -> su.Symbol.DisplayName = "List") let objEntity = objSymbol.Symbol :?> FSharpEntity - - [ for attrib in objEntity.Attributes do + let attributes = objEntity.Attributes |> Seq.filter (fun attrib -> attrib.AttributeType.DisplayName <> "__DynamicallyInvokableAttribute") + + [ for attrib in attributes do let args = try Seq.toList attrib.ConstructorArguments with _ -> [] let namedArgs = try Seq.toList attrib.NamedArguments with _ -> [] let output = sprintf "%A" (attrib.AttributeType, args, namedArgs) yield output.Replace("\r\n", "\n").Replace("\n", "") ] |> set |> shouldEqual - (set ["(DebuggerTypeProxyAttribute, [], [])"; - """(DebuggerDisplayAttribute, [(type Microsoft.FSharp.Core.string, "Count = {Count}")], [])"""; - """(DefaultMemberAttribute, [(type Microsoft.FSharp.Core.string, "Item")], [])"""]) + (set [ + "(DebuggerTypeProxyAttribute, [], [])"; + """(DebuggerDisplayAttribute, [(type Microsoft.FSharp.Core.string, "Count = {Count}")], [])"""; + """(DefaultMemberAttribute, [(type Microsoft.FSharp.Core.string, "Item")], [])"""; + ]) [] let ``Test project31 C# method attributes`` () = @@ -4035,23 +4195,31 @@ let ``Test project31 C# method attributes`` () = objMethodsAttributes |> set |> shouldEqual - (set ["(SecuritySafeCriticalAttribute, [], [])"; - "(CLSCompliantAttribute, [(type Microsoft.FSharp.Core.bool, false)], [])"]) + (set [ +#if !DOTNETCORE + "(SecuritySafeCriticalAttribute, [], [])"; +#endif + "(CLSCompliantAttribute, [(type Microsoft.FSharp.Core.bool, false)], [])"]) [] +#if DOTNETCORE +[] +#endif let ``Test project31 Format C# type attributes`` () = if not runningOnMono then let wholeProjectResults = checker.ParseAndCheckProject(Project31.options) |> Async.RunSynchronously let objSymbol = wholeProjectResults.GetAllUsesOfAllSymbols() |> Async.RunSynchronously |> Array.find (fun su -> su.Symbol.DisplayName = "List") let objEntity = objSymbol.Symbol :?> FSharpEntity - - [ for attrib in objEntity.Attributes -> attrib.Format(objSymbol.DisplayContext) ] + let attributes = objEntity.Attributes |> Seq.filter (fun attrib -> attrib.AttributeType.DisplayName <> "__DynamicallyInvokableAttribute") + + [ for attrib in attributes -> attrib.Format(objSymbol.DisplayContext) ] |> set |> shouldEqual (set ["[>)>]"; """[]"""; - """[]"""]) + """[]"""; + ]) [] let ``Test project31 Format C# method attributes`` () = @@ -4069,9 +4237,12 @@ let ``Test project31 Format C# method attributes`` () = |> set |> shouldEqual (set ["[]"; - "[]"]) +#if !DOTNETCORE + "[]"; +#endif + ]) -module Project32 = +module internal Project32 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -4095,13 +4266,15 @@ val func : int -> int let fileNames = [sigFileName1; fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project32 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project32.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project32 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 [] @@ -4142,7 +4315,7 @@ let ``Test Project32 should be able to find impl symbols`` () = [("sig1", ((4, 4), (4, 8)), ["val"]); ("file1", ((3, 4), (3, 8)), ["val"])] -module Project33 = +module internal Project33 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -4162,12 +4335,14 @@ type System.Int32 with let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project33 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project33.options) |> Async.RunSynchronously + for e in wholeProjectResults.Errors do + printfn "Project33 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 [] @@ -4186,7 +4361,7 @@ let ``Test Project33 extension methods`` () = [("SetValue", ["member"; "extmem"]); ("GetValue", ["member"; "extmem"])] -module Project34 = +module internal Project34 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -4203,19 +4378,17 @@ module Dummy let args = [| yield! mkProjectCommandLineArgs (dllName, fileNames) - if System.Environment.OSVersion.Platform = System.PlatformID.Win32NT then // file references only valid on Windows - yield @"-r:" + sysLib "System.Data" - else // We use .NET-buit version of System.Data.dll since the tests depend on implementation details // i.e. the private type System.Data.Listeners may not be available on Mono. - yield @"-r:" + Path.Combine(__SOURCE_DIRECTORY__, "System.Data.dll") + yield @"-r:" + Path.Combine(__SOURCE_DIRECTORY__, Path.Combine("data", "System.Data.dll")) |] - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test Project34 whole project errors`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project34.options) |> Async.RunSynchronously - for e in wholeProjectResults.Errors do printfn "Error: %s" e.Message + for e in wholeProjectResults.Errors do + printfn "Project34 error: <<<%s>>>" e.Message wholeProjectResults.Errors.Length |> shouldEqual 0 [] @@ -4250,7 +4423,7 @@ let ``Test project34 should report correct accessibility for System.Data.Listene //------------------------------------------------------ -module Project35 = +module internal Project35 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -4269,7 +4442,7 @@ type Test = let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] @@ -4328,7 +4501,7 @@ let ``Test project35 CurriedParameterGroups should be available for nested funct //------------------------------------------------------ -module Project35b = +module internal Project35b = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fsx") @@ -4340,22 +4513,49 @@ module Project35b = let cleanFileName a = if a = fileName1 then "file1" else "??" let fileNames = [fileName1] - let internal options = checker.GetProjectOptionsFromScript(fileName1, fileSource1) |> Async.RunSynchronously |> fst +#if TODO_REWORK_ASSEMBLY_LOAD + let projPath = Path.ChangeExtension(fileName1, ".fsproj") + let dllPath = Path.ChangeExtension(fileName1, ".dll") + let args = mkProjectCommandLineArgs(dllPath, fileNames) + let args2 = Array.append args [| "-r:notexist.dll" |] + let options = checker.GetProjectOptionsFromCommandLineArgs (projPath, args2) +#else + let options = checker.GetProjectOptionsFromScript(fileName1, fileSource1) |> Async.RunSynchronously |> fst +#endif +[] +let ``Test project35b Dependency files for ParseAndCheckFileInProject`` () = + let checkFileResults = + checker.ParseAndCheckFileInProject(Project35b.fileName1, 0, Project35b.fileSource1, Project35b.options) |> Async.RunSynchronously + |> function + | _, FSharpCheckFileAnswer.Succeeded(res) -> res + | _ -> failwithf "Parsing aborted unexpectedly..." + for d in checkFileResults.DependencyFiles do + printfn "ParseAndCheckFileInProject dependency: %s" d + checkFileResults.DependencyFiles |> List.exists (fun s -> s.Contains "notexist.dll") |> shouldEqual true + // The file itself is not a dependency since it is never read from the file system when using ParseAndCheckFileInProject + checkFileResults.DependencyFiles |> List.exists (fun s -> s.Contains Project35b.fileName1) |> shouldEqual false [] -let ``Test project35b Dependency files`` () = - let parseFileResults = checker.ParseFileInProject(Project35b.fileName1, Project35b.fileSource1, Project35b.options) |> Async.RunSynchronously - for d in parseFileResults.DependencyFiles do - printfn "dependency: %s" d -// parseFileResults.DependencyFiles.Length |> shouldEqual 3 - parseFileResults.DependencyFiles |> List.exists (fun s -> s.Contains "notexist.dll") |> shouldEqual true - parseFileResults.DependencyFiles |> List.exists (fun s -> s.Contains Project35b.fileName1) |> shouldEqual true -/// parseFileResults.DependencyFiles |> List.exists (fun s -> s.Contains "FSharp.Compiler.Interactive.Settings.dll") |> shouldEqual true +let ``Test project35b Dependency files for GetBackgroundCheckResultsForFileInProject`` () = + let _,checkFileResults = checker.GetBackgroundCheckResultsForFileInProject(Project35b.fileName1, Project35b.options) |> Async.RunSynchronously + for d in checkFileResults.DependencyFiles do + printfn "GetBackgroundCheckResultsForFileInProject dependency: %s" d + checkFileResults.DependencyFiles |> List.exists (fun s -> s.Contains "notexist.dll") |> shouldEqual true + // The file is a dependency since it is read from the file system when using GetBackgroundCheckResultsForFileInProject + checkFileResults.DependencyFiles |> List.exists (fun s -> s.Contains Project35b.fileName1) |> shouldEqual true + +[] +let ``Test project35b Dependency files for check of project`` () = + let checkResults = checker.ParseAndCheckProject(Project35b.options) |> Async.RunSynchronously + for d in checkResults.DependencyFiles do + printfn "ParseAndCheckProject dependency: %s" d + checkResults.DependencyFiles |> List.exists (fun s -> s.Contains "notexist.dll") |> shouldEqual true + checkResults.DependencyFiles |> List.exists (fun s -> s.Contains Project35b.fileName1) |> shouldEqual true //------------------------------------------------------ -module Project36 = +module internal Project36 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -4382,13 +4582,25 @@ let callToOverload = B(5).Overload(4) let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal keepAssemblyContentsChecker = FSharpChecker.Create(keepAssemblyContents=true) - let internal options = keepAssemblyContentsChecker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let keepAssemblyContentsChecker = FSharpChecker.Create(keepAssemblyContents=true) + let options = keepAssemblyContentsChecker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let wholeProjectResults = + keepAssemblyContentsChecker.ParseAndCheckProject(options) + |> Async.RunSynchronously + let declarations = + let checkedFile = wholeProjectResults.AssemblyContents.ImplementationFiles.[0] + match checkedFile.Declarations.[0] with + | FSharpImplementationFileDeclaration.Entity (_, subDecls) -> subDecls + | _ -> failwith "unexpected declaration" + let getExpr exprIndex = + match declarations.[exprIndex] with + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(_,_,e) -> e + | FSharpImplementationFileDeclaration.InitAction e -> e + | _ -> failwith "unexpected declaration" [] let ``Test project36 FSharpMemberOrFunctionOrValue.IsBaseValue`` () = - let wholeProjectResults = Project36.keepAssemblyContentsChecker.ParseAndCheckProject(Project36.options) |> Async.RunSynchronously - wholeProjectResults.GetAllUsesOfAllSymbols() + Project36.wholeProjectResults.GetAllUsesOfAllSymbols() |> Async.RunSynchronously |> Array.pick (fun (su:FSharpSymbolUse) -> if su.Symbol.DisplayName = "base" @@ -4396,7 +4608,6 @@ let ``Test project36 FSharpMemberOrFunctionOrValue.IsBaseValue`` () = else None) |> fun baseSymbol -> shouldEqual true baseSymbol.IsBaseValue -#if FSHARP_SERVICE_GIVES_ASSEMBLY_CONTENTS [] let ``Test project36 FSharpMemberOrFunctionOrValue.IsConstructorThisValue & IsMemberThisValue`` () = let wholeProjectResults = Project36.keepAssemblyContentsChecker.ParseAndCheckProject(Project36.options) |> Async.RunSynchronously @@ -4431,7 +4642,6 @@ let ``Test project36 FSharpMemberOrFunctionOrValue.IsConstructorThisValue & IsMe not s.IsMemberThisValue && not s.IsConstructorThisValue | _ -> failwith "unexpected expression" |> shouldEqual true -#endif [] let ``Test project36 FSharpMemberOrFunctionOrValue.LiteralValue`` () = @@ -4443,7 +4653,7 @@ let ``Test project36 FSharpMemberOrFunctionOrValue.LiteralValue`` () = let notLit = project36Module.MembersFunctionsAndValues.[1] shouldEqual true notLit.LiteralValue.IsNone -module Project37 = +module internal Project37 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -4496,11 +4706,13 @@ do () File.WriteAllText(fileName2, fileSource2) let fileNames = [fileName1; fileName2] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test project37 typeof and arrays in attribute constructor arguments`` () = - let wholeProjectResults = checker.ParseAndCheckProject(Project37.options) |> Async.RunSynchronously + let wholeProjectResults = + checker.ParseAndCheckProject(Project37.options) + |> Async.RunSynchronously let allSymbolsUses = wholeProjectResults.GetAllUsesOfAllSymbols() |> Async.RunSynchronously for su in allSymbolsUses do match su.Symbol with @@ -4544,7 +4756,7 @@ let ``Test project37 typeof and arrays in attribute constructor arguments`` () = //----------------------------------------------------------- -module Project38 = +module internal Project38 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -4590,13 +4802,17 @@ type A<'XX, 'YY>() = File.WriteAllText(fileName1, fileSource1) let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] let ``Test project38 abstract slot information`` () = - let wholeProjectResults = checker.ParseAndCheckProject(Project38.options) |> Async.RunSynchronously + let wholeProjectResults = + checker.ParseAndCheckProject(Project38.options) + |> Async.RunSynchronously let printAbstractSignature (s: FSharpAbstractSignature) = - let printType (t: FSharpType) = (string t).[5 ..] + let printType (t: FSharpType) = + hash t |> ignore // smoke test to check hash code doesn't loop + (string t).[5 ..] let args = (s.AbstractArguments |> Seq.concat |> Seq.map (fun a -> (match a.Name with Some n -> n + ":" | _ -> "") + printType a.Type) |> String.concat " * ") @@ -4638,7 +4854,7 @@ let ``Test project38 abstract slot information`` () = //-------------------------------------------- -module Project39 = +module internal Project39 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -4668,7 +4884,7 @@ let uses () = File.WriteAllText(fileName1, fileSource1) let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) let cleanFileName a = if a = fileName1 then "file1" else "??" [] @@ -4719,7 +4935,7 @@ let ``Test project39 all symbols`` () = //-------------------------------------------- -module Project40 = +module internal Project40 = open System.IO let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") @@ -4744,7 +4960,7 @@ let g (x: C) = x.IsItAnA,x.IsItAnAMethod() File.WriteAllText(fileName1, fileSource1) let fileNames = [fileName1] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) let cleanFileName a = if a = fileName1 then "file1" else "??" [] @@ -4783,7 +4999,7 @@ let ``Test Project40 all symbols`` () = ("g", ((13, 4), (13, 5)), ["val"]); ("M", ((2, 7), (2, 8)), ["module"])] -module ProjectBig = +module internal ProjectBig = open System.IO let fileNamesI = [ for i in 1 .. 10 -> (i, Path.ChangeExtension(Path.GetTempFileName(), ".fs")) ] @@ -4796,7 +5012,7 @@ module ProjectBig = let fileNames = [ for (_,f) in fileNamesI -> f ] let args = mkProjectCommandLineArgs (dllName, fileNames) - let internal options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) [] @@ -4833,9 +5049,9 @@ let ``Test request for parse and check doesn't check whole project`` () = #if FCS_RETAIN_BACKGROUND_PARSE_RESULTS backgroundParseCount.Value |> shouldEqual 10 // but note, the project does not get reparsed #else - backgroundParseCount.Value |> shouldEqual 7 // but note, the project does not get reparsed + (backgroundParseCount.Value <= 8) |> shouldEqual true // but note, the project does not get reparsed #endif - backgroundCheckCount.Value |> shouldEqual 7 // only two extra typechecks of files + (backgroundCheckCount.Value <= 8) |> shouldEqual true // only two extra typechecks of files // A subsequent ParseAndCheck of identical source code doesn't do any more anything let checkResults2 = checker.ParseAndCheckFileInProject(ProjectBig.fileNames.[7], 0, ProjectBig.fileSources2.[7], ProjectBig.options) |> Async.RunSynchronously @@ -4845,9 +5061,9 @@ let ``Test request for parse and check doesn't check whole project`` () = #if FCS_RETAIN_BACKGROUND_PARSE_RESULTS backgroundParseCount.Value |> shouldEqual 10 // but note, the project does not get reparsed #else - backgroundParseCount.Value |> shouldEqual 7 // but note, the project does not get reparsed + (backgroundParseCount.Value <= 8) |> shouldEqual true // but note, the project does not get reparsed #endif - backgroundCheckCount.Value |> shouldEqual 7 // only two extra typechecks of files + (backgroundCheckCount.Value <= 8) |> shouldEqual true // only two extra typechecks of files () @@ -4868,4 +5084,51 @@ let ``add files with same name from different folders`` () = printfn "add files with same name from different folders" for err in errors do printfn "ERROR: %s" err.Message - shouldEqual 0 errors.Length \ No newline at end of file + shouldEqual 0 errors.Length + +module internal ProjectStructUnions = + open System.IO + + let fileName1 = Path.ChangeExtension(Path.GetTempFileName(), ".fs") + let base2 = Path.GetTempFileName() + let dllName = Path.ChangeExtension(base2, ".dll") + let projFileName = Path.ChangeExtension(base2, ".fsproj") + let fileSource1 = """ +module M + +// Custom struct result type as test projects still use FSharp.Core 4.0 +type [] Result<'a,'b> = Ok of ResultValue:'a | Error of ErrorValue:'b + +type Foo = + | Foo of Result + +let foo (a: Foo): bool = + match a with + | Foo(Ok(_)) -> true + | _ -> false + """ + + File.WriteAllText(fileName1, fileSource1) + let fileNames = [fileName1] + let args = mkProjectCommandLineArgs (dllName, fileNames) + let options = checker.GetProjectOptionsFromCommandLineArgs (projFileName, args) + +[] +let ``Test typed AST for struct unions`` () = // See https://github.com/fsharp/FSharp.Compiler.Service/issues/756 + let wholeProjectResults = Project36.keepAssemblyContentsChecker.ParseAndCheckProject(ProjectStructUnions.options) |> Async.RunSynchronously + let declarations = + let checkedFile = wholeProjectResults.AssemblyContents.ImplementationFiles.[0] + match checkedFile.Declarations.[0] with + | FSharpImplementationFileDeclaration.Entity (_, subDecls) -> subDecls + | _ -> failwith "unexpected declaration" + let getExpr exprIndex = + match declarations.[exprIndex] with + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(_,_,e) -> e + | FSharpImplementationFileDeclaration.InitAction e -> e + | _ -> failwith "unexpected declaration" + match getExpr (declarations.Length - 1) with + | BasicPatterns.IfThenElse(BasicPatterns.UnionCaseTest(BasicPatterns.AddressOf(BasicPatterns.UnionCaseGet _),_,uci), + BasicPatterns.Const(trueValue, _), BasicPatterns.Const(falseValue, _)) + when uci.Name = "Ok" && obj.Equals(trueValue, true) && obj.Equals(falseValue, false) -> true + | _ -> failwith "unexpected expression" + |> shouldEqual true diff --git a/tests/service/ProjectOptionsTests.fs b/tests/service/ProjectOptionsTests.fs index 702206e36b4..e641bcbc9a5 100644 --- a/tests/service/ProjectOptionsTests.fs +++ b/tests/service/ProjectOptionsTests.fs @@ -1,7 +1,7 @@ #if INTERACTIVE -#r "../../bin/v4.5/FSharp.Compiler.Service.dll" -#r "../../bin/v4.5/FSharp.Compiler.Service.ProjectCracker.dll" -#r "../../packages/NUnit/lib/nunit.framework.dll" +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../Debug/net40/bin/FSharp.Compiler.Service.ProjectCracker.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" #load "FsUnit.fs" #load "Common.fs" #else @@ -18,6 +18,7 @@ open Microsoft.FSharp.Compiler.SourceCodeServices open FSharp.Compiler.Service.Tests.Common +#if FX_ATLEAST_45 #if !NO_PROJECTCRACKER let normalizePath s = (new Uri(s)).LocalPath @@ -36,15 +37,22 @@ let checkOptionNotPresent (opts:string[]) s = let getReferencedFilenames = Array.choose (fun (o:string) -> if o.StartsWith("-r:") then o.[3..] |> (Path.GetFileName >> Some) else None) let getReferencedFilenamesAndContainingFolders = Array.choose (fun (o:string) -> if o.StartsWith("-r:") then o.[3..] |> (fun r -> ((r |> Path.GetFileName), (r |> Path.GetDirectoryName |> Path.GetFileName)) |> Some) else None) let getOutputFile = Array.pick (fun (o:string) -> if o.StartsWith("--out:") then o.[6..] |> Some else None) -let getCompiledFilenames = Array.choose (fun (o:string) -> if o.EndsWith(".fs") then o |> (Path.GetFileName >> Some) else None) + +let getCompiledFilenames = + Array.choose (fun (opt: string) -> + if opt.EndsWith ".fs" then + opt |> Path.GetFileName |> Some + else None) + >> Array.distinct [] let ``Project file parsing example 1 Default Configuration`` () = let projectFile = __SOURCE_DIRECTORY__ + @"/FSharp.Compiler.Service.Tests.fsproj" let options = ProjectCracker.GetProjectOptionsFromProjectFile(projectFile) + checkOption options.ProjectFileNames "FileSystemTests.fs" + checkOption options.OtherOptions "FSharp.Compiler.Service.dll" - checkOption options.OtherOptions "FileSystemTests.fs" checkOption options.OtherOptions "--define:TRACE" checkOption options.OtherOptions "--define:DEBUG" checkOption options.OtherOptions "--flaterrors" @@ -57,8 +65,9 @@ let ``Project file parsing example 1 Release Configuration`` () = // Check with Configuration = Release let options = ProjectCracker.GetProjectOptionsFromProjectFile(projectFile, [("Configuration", "Release")]) + checkOption options.ProjectFileNames "FileSystemTests.fs" + checkOption options.OtherOptions "FSharp.Compiler.Service.dll" - checkOption options.OtherOptions "FileSystemTests.fs" checkOption options.OtherOptions "--define:TRACE" checkOptionNotPresent options.OtherOptions "--define:DEBUG" checkOption options.OtherOptions "--debug:pdbonly" @@ -67,11 +76,11 @@ let ``Project file parsing example 1 Release Configuration`` () = let ``Project file parsing example 1 Default configuration relative path`` () = let projectFile = "FSharp.Compiler.Service.Tests.fsproj" Directory.SetCurrentDirectory(__SOURCE_DIRECTORY__) - let options = ProjectCracker.GetProjectOptionsFromProjectFile(projectFile) + checkOption options.ProjectFileNames "FileSystemTests.fs" + checkOption options.OtherOptions "FSharp.Compiler.Service.dll" - checkOption options.OtherOptions "FileSystemTests.fs" checkOption options.OtherOptions "--define:TRACE" checkOption options.OtherOptions "--define:DEBUG" checkOption options.OtherOptions "--flaterrors" @@ -80,6 +89,8 @@ let ``Project file parsing example 1 Default configuration relative path`` () = [] let ``Project file parsing VS2013_FSharp_Portable_Library_net45``() = + if not runningOnMono then // Disabled on Mono due to lack of installed PCL reference libraries - the modern way is to reference the FSHarp.Core nuget package so this is ok + let projectFile = __SOURCE_DIRECTORY__ + @"/../projects/Sample_VS2013_FSharp_Portable_Library_net45/Sample_VS2013_FSharp_Portable_Library_net45.fsproj" let options = ProjectCracker.GetProjectOptionsFromProjectFile(projectFile, []) @@ -94,6 +105,8 @@ let ``Project file parsing VS2013_FSharp_Portable_Library_net45``() = [] let ``Project file parsing Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile78``() = + if not runningOnMono then // Disabled on Mono due to lack of installed PCL reference libraries - the modern way is to reference the FSHarp.Core nuget package so this is ok + let projectFile = __SOURCE_DIRECTORY__ + @"/../projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile78/Sample_VS2013_FSharp_Portable_Library_net451.fsproj" Directory.SetCurrentDirectory(__SOURCE_DIRECTORY__ + @"/../projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile78/") let options = ProjectCracker.GetProjectOptionsFromProjectFile(projectFile, []) @@ -109,21 +122,16 @@ let ``Project file parsing Sample_VS2013_FSharp_Portable_Library_net451_adjusted [] let ``Project file parsing -- compile files 1``() = - let p = ProjectCracker.GetProjectOptionsFromProjectFile(__SOURCE_DIRECTORY__ + @"/data/Test1.fsproj") - - p.OtherOptions - |> getCompiledFilenames - |> set - |> should equal (set [ "Test1File1.fs"; "Test1File2.fs" ]) + let opts = ProjectCracker.GetProjectOptionsFromProjectFile(__SOURCE_DIRECTORY__ + @"/data/Test1.fsproj") + CollectionAssert.AreEqual (["Test1File2.fs"; "Test1File1.fs"], opts.ProjectFileNames |> Array.map Path.GetFileName) + CollectionAssert.IsEmpty (getCompiledFilenames opts.OtherOptions) [] let ``Project file parsing -- compile files 2``() = - let p = ProjectCracker.GetProjectOptionsFromProjectFile(__SOURCE_DIRECTORY__ + @"/data/Test2.fsproj") + let opts = ProjectCracker.GetProjectOptionsFromProjectFile(__SOURCE_DIRECTORY__ + @"/data/Test2.fsproj") - p.OtherOptions - |> getCompiledFilenames - |> set - |> should equal (set [ "Test2File1.fs"; "Test2File2.fs" ]) + CollectionAssert.AreEqual (["Test2File2.fs"; "Test2File1.fs"], opts.ProjectFileNames |> Array.map Path.GetFileName) + CollectionAssert.IsEmpty (getCompiledFilenames opts.OtherOptions) [] let ``Project file parsing -- bad project file``() = @@ -191,18 +199,16 @@ let ``Project file parsing -- reference project output file``() = |> Array.choose (fun (o:string) -> if o.StartsWith("-r:") then o.[3..] |> Some else None) |> should contain (normalizePath (__SOURCE_DIRECTORY__ + @"/data/DifferingOutputDir/Dir1/OutputDir1/Test1.dll")) - [] let ``Project file parsing -- Tools Version 12``() = - let p = ProjectCracker.GetProjectOptionsFromProjectFile(__SOURCE_DIRECTORY__ + @"/data/ToolsVersion12.fsproj") - - checkOption (getReferencedFilenames p.OtherOptions) "System.Core.dll" + let opts = ProjectCracker.GetProjectOptionsFromProjectFile(__SOURCE_DIRECTORY__ + @"/data/ToolsVersion12.fsproj") + checkOption (getReferencedFilenames opts.OtherOptions) "System.Core.dll" [] let ``Project file parsing -- Logging``() = - let f = normalizePath (__SOURCE_DIRECTORY__ + @"/data/ToolsVersion12.fsproj") - let p, logMap = ProjectCracker.GetProjectOptionsFromProjectFileLogged(f, enableLogging=true) - let log = logMap.[f] + let projectFileName = normalizePath (__SOURCE_DIRECTORY__ + @"/data/ToolsVersion12.fsproj") + let _, logMap = ProjectCracker.GetProjectOptionsFromProjectFileLogged(projectFileName, enableLogging=true) + let log = logMap.[projectFileName] if runningOnMono then Assert.That(log, Is.StringContaining("Reference System.Core resolved")) @@ -240,6 +246,8 @@ let ``Project file parsing -- multi language project``() = [] let ``Project file parsing -- PCL profile7 project``() = + if not runningOnMono then // Disabled on Mono due to lack of installed PCL reference libraries - the modern way is to reference the FSHarp.Core nuget package so this is ok + let f = normalizePath (__SOURCE_DIRECTORY__ + @"/../projects/Sample_VS2013_FSharp_Portable_Library_net45/Sample_VS2013_FSharp_Portable_Library_net45.fsproj") @@ -288,6 +296,8 @@ let ``Project file parsing -- PCL profile7 project``() = [] let ``Project file parsing -- PCL profile78 project``() = + if not runningOnMono then // Disabled on Mono due to lack of installed PCL reference libraries - the modern way is to reference the FSHarp.Core nuget package so this is ok + let f = normalizePath (__SOURCE_DIRECTORY__ + @"/../projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile78/Sample_VS2013_FSharp_Portable_Library_net451.fsproj") @@ -327,7 +337,7 @@ let ``Project file parsing -- PCL profile78 project``() = [] let ``Project file parsing -- PCL profile259 project``() = - + if not runningOnMono then // Disabled on Mono due to lack of installed PCL reference libraries - the modern way is to reference the FSHarp.Core nuget package so this is ok let f = normalizePath (__SOURCE_DIRECTORY__ + @"/../projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile259/Sample_VS2013_FSharp_Portable_Library_net451.fsproj") let options = ProjectCracker.GetProjectOptionsFromProjectFile(f) @@ -385,40 +395,69 @@ let ``Project file parsing -- Exe with a PCL reference``() = [] let ``Project file parsing -- project file contains project reference to out-of-solution project and is used in release mode``() = - - let f = normalizePath(__SOURCE_DIRECTORY__ + @"/data/TestProject/TestProject.fsproj") - let p = ProjectCracker.GetProjectOptionsFromProjectFile(f,[("Configuration","Release")]) - let references = getReferencedFilenamesAndContainingFolders p.OtherOptions |> set + let projectFileName = normalizePath(__SOURCE_DIRECTORY__ + @"/data/Test2.fsproj") + let opts = ProjectCracker.GetProjectOptionsFromProjectFile(projectFileName,[("Configuration","Release")]) + let references = getReferencedFilenamesAndContainingFolders opts.OtherOptions |> set // Check the reference is to a release DLL - references |> should contain ("TestTP.dll", "Release") + references |> should contain ("Test1.dll", "Release") [] let ``Project file parsing -- project file contains project reference to out-of-solution project and is used in debug mode``() = - let f = normalizePath(__SOURCE_DIRECTORY__ + @"/data/TestProject/TestProject.fsproj") - let p = ProjectCracker.GetProjectOptionsFromProjectFile(f,[("Configuration","Debug")]) - let references = getReferencedFilenamesAndContainingFolders p.OtherOptions |> set + let projectFileName = normalizePath(__SOURCE_DIRECTORY__ + @"/data/Test2.fsproj") + let opts = ProjectCracker.GetProjectOptionsFromProjectFile(projectFileName,[("Configuration","Debug")]) + let references = getReferencedFilenamesAndContainingFolders opts.OtherOptions |> set // Check the reference is to a debug DLL - references |> should contain ("TestTP.dll", "Debug") + references |> should contain ("Test1.dll", "Debug") [] let ``Project file parsing -- space in file name``() = - let p = ProjectCracker.GetProjectOptionsFromProjectFile(__SOURCE_DIRECTORY__ + @"/data/Space in name.fsproj") - - p.OtherOptions - |> getCompiledFilenames - |> set - |> should equal (set [ "Test2File1.fs"; "Test2File2.fs" ]) + let opts = ProjectCracker.GetProjectOptionsFromProjectFile(__SOURCE_DIRECTORY__ + @"/data/Space in name.fsproj") + CollectionAssert.AreEqual (["Test2File2.fs"; "Test2File1.fs"], opts.ProjectFileNames |> Array.map Path.GetFileName) + CollectionAssert.IsEmpty (getCompiledFilenames opts.OtherOptions) [] let ``Project file parsing -- report files``() = let programFilesx86Folder = System.Environment.GetEnvironmentVariable("PROGRAMFILES(X86)") if not runningOnMono then - for f in Directory.EnumerateFiles(programFilesx86Folder + @"\Reference Assemblies\Microsoft\FSharp\","*",SearchOption.AllDirectories) do + + let dirRefs = programFilesx86Folder + @"\Reference Assemblies\Microsoft\FSharp\" + printfn "Enumerating %s" dirRefs + if Directory.Exists(dirRefs) then + for f in Directory.EnumerateFiles(dirRefs,"*",SearchOption.AllDirectories) do + printfn "File: %s" f + + let dir40 = programFilesx86Folder + @"\Microsoft SDKs\F#\4.0\" + printfn "Enumerating %s" dir40 + if Directory.Exists(dir40) then + for f in Directory.EnumerateFiles(dir40,"*",SearchOption.AllDirectories) do printfn "File: %s" f - for f in Directory.EnumerateFiles(programFilesx86Folder + @"\Microsoft SDKs\F#\4.1\","*",SearchOption.AllDirectories) do + + let dir41 = programFilesx86Folder + @"\Microsoft SDKs\F#\4.1\" + printfn "Enumerating %s" dir41 + if Directory.Exists(dir41) then + for f in Directory.EnumerateFiles(dir41,"*",SearchOption.AllDirectories) do printfn "File: %s" f +[] +let ``Test OtherOptions order for GetProjectOptionsFromScript`` () = + let test scriptName expected2 = + let scriptPath = __SOURCE_DIRECTORY__ + @"/data/ScriptProject/" + scriptName + ".fsx" + let scriptSource = File.ReadAllText scriptPath + let projOpts, _diagnostics = checker.GetProjectOptionsFromScript(scriptPath, scriptSource) |> Async.RunSynchronously + + projOpts.OtherOptions + |> Array.map (fun s -> if s.StartsWith "--" then s else Path.GetFileNameWithoutExtension s) + |> Array.sort + |> shouldEqual (Array.sort expected2) + let otherArgs = [|"--noframework"; "--warn:3"; "System.Numerics"; "mscorlib"; "FSharp.Core"; "System"; "System.Xml"; "System.Runtime.Remoting"; "System.Runtime.Serialization.Formatters.Soap"; "System.Data"; "System.Drawing"; "System.Core"; "System.Runtime"; "System.Linq"; "System.Reflection"; "System.Linq.Expressions"; "System.Threading.Tasks"; "System.IO"; "System.Net.Requests"; "System.Collections"; "System.Runtime.Numerics"; "System.Threading"; "System.Web"; "System.Web.Services"; "System.Windows.Forms"; "FSharp.Compiler.Interactive.Settings"|] + test "Main1" otherArgs + test "Main2" otherArgs + test "Main3" otherArgs + test "Main4" otherArgs + test "MainBad" otherArgs + + #endif [] @@ -431,13 +470,14 @@ let ``Test ProjectFileNames order for GetProjectOptionsFromScript`` () = // See |> Async.RunSynchronously projOpts.ProjectFileNames |> Array.map Path.GetFileNameWithoutExtension - |> (=) expected - |> shouldEqual true - test "Main1" [|"BaseLib1"; "Lib1"; "Lib2"; "Main1"|] - test "Main2" [|"BaseLib1"; "Lib1"; "Lib2"; "Lib3"; "Main2"|] - test "Main3" [|"Lib3"; "Lib4"; "Main3"|] - test "Main4" [|"BaseLib2"; "Lib5"; "BaseLib1"; "Lib1"; "Lib2"; "Main4"|] + |> shouldEqual expected + test "Main1" [|"BaseLib1"; "Lib1"; "Lib2"; "Main1"|] + test "Main2" [|"BaseLib1"; "Lib1"; "Lib2"; "Lib3"; "Main2"|] + test "Main3" [|"Lib3"; "Lib4"; "Main3"|] + test "Main4" [|"BaseLib2"; "Lib5"; "BaseLib1"; "Lib1"; "Lib2"; "Main4"|] + test "MainBad" [|"MainBad"|] +#endif diff --git a/tests/service/ReshapedReflection.fs b/tests/service/ReshapedReflection.fs new file mode 100644 index 00000000000..3b1ba07ce81 --- /dev/null +++ b/tests/service/ReshapedReflection.fs @@ -0,0 +1,9 @@ +namespace FSharp.Compiler.Service.Tests + +#if FX_RESHAPED_REFLECTION +module internal ReflectionAdapters = + open System.Reflection + + type System.Type with + member this.Assembly = this.GetTypeInfo().Assembly +#endif diff --git a/tests/service/TokenizerTests.fs b/tests/service/TokenizerTests.fs new file mode 100644 index 00000000000..03b7b0c4a8d --- /dev/null +++ b/tests/service/TokenizerTests.fs @@ -0,0 +1,61 @@ + +#if INTERACTIVE +#r "../../Debug/net40/bin/FSharp.Compiler.Service.dll" +#r "../../packages/NUnit.3.5.0/lib/net45/nunit.framework.dll" +#load "FsUnit.fs" +#load "Common.fs" +#else +module FSharp.Compiler.Service.Tests.TokenizerTests +#endif + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Interactive.Shell +open Microsoft.FSharp.Compiler.SourceCodeServices + +open NUnit.Framework +open FsUnit +open System +open System.IO + + +let sourceTok = FSharpSourceTokenizer([], Some "C:\\test.fsx") + +let tokenizeLines (lines:string[]) = + [ let state = ref 0L + for n, line in lines |> Seq.zip [ 0 .. lines.Length ] do + let tokenizer = sourceTok.CreateLineTokenizer(line) + let rec parseLine() = seq { + match tokenizer.ScanToken(!state) with + | Some(tok), nstate -> + let str = line.Substring(tok.LeftColumn, tok.RightColumn - tok.LeftColumn + 1) + yield str, tok + state := nstate + yield! parseLine() + | None, nstate -> state := nstate } + yield n, parseLine() |> List.ofSeq ] + +[] +let ``Tokenizer test 1``() = + let tokenizedLines = + tokenizeLines + [| "// Sets the hello wrold variable" + "let hello = \"Hello world\" " |] + + let actual = + [ for lineNo, lineToks in tokenizedLines do + yield lineNo, [ for str, info in lineToks do yield info.TokenName, str ] ] + let expected = + [(0, + [("LINE_COMMENT", "//"); ("LINE_COMMENT", " "); ("LINE_COMMENT", "Sets"); + ("LINE_COMMENT", " "); ("LINE_COMMENT", "the"); ("LINE_COMMENT", " "); + ("LINE_COMMENT", "hello"); ("LINE_COMMENT", " "); + ("LINE_COMMENT", "wrold"); ("LINE_COMMENT", " "); + ("LINE_COMMENT", "variable")]); + (1, + [("LET", "let"); ("WHITESPACE", " "); ("IDENT", "hello"); + ("WHITESPACE", " "); ("EQUALS", "="); ("WHITESPACE", " "); + ("STRING_TEXT", "\""); ("STRING_TEXT", "Hello"); ("STRING_TEXT", " "); + ("STRING_TEXT", "world"); ("STRING", "\""); ("WHITESPACE", " ")])] + + Assert.AreEqual(actual, expected) + diff --git a/tests/service/data/CSharp_Analysis/CSharpClass.cs b/tests/service/data/CSharp_Analysis/CSharpClass.cs new file mode 100644 index 00000000000..fbef78388ad --- /dev/null +++ b/tests/service/data/CSharp_Analysis/CSharpClass.cs @@ -0,0 +1,129 @@ +using System; +using System.Collections.Generic; +using System.Linq; +using System.Runtime.InteropServices; +using System.Text; +using System.Threading.Tasks; + +namespace FSharp.Compiler.Service.Tests +{ + /// + /// Documentation + /// + public interface ICSharpInterface + { + int InterfaceMethod(string parameter); + bool InterfaceProperty { get; } + + event EventHandler InterfaceEvent; + } + + public interface ICSharpExplicitInterface + { + int ExplicitMethod(string parameter); + bool ExplicitProperty { get; } + + event EventHandler ExplicitEvent; + } + + public class CSharpClass : ICSharpInterface, ICSharpExplicitInterface + { + /// + /// Documentaton + /// + /// + public CSharpClass(int param) + { + + } + + /// + /// Documentaton + /// + /// + /// + public CSharpClass(int first, string param) + { + + } + + public int Method(string parameter) + { + throw new NotImplementedException(); + } + + public int Method2(string optParameter = "empty") + { + throw new NotImplementedException(); + } + + public int Method3(params string[] variadicParameter) + { + throw new NotImplementedException(); + } + + public void GenericMethod(T input) + { + throw new NotImplementedException(); + } + + public void GenericMethod2(T input) where T : class + { + throw new NotImplementedException(); + } + + public void GenericMethod3(T input) where T : IComparable + { + throw new NotImplementedException(); + } + + public bool Property + { + get { throw new NotImplementedException(); } + } + + public event EventHandler Event; + + public int InterfaceMethod(string parameter) + { + throw new NotImplementedException(); + } + + public bool InterfaceProperty + { + get { throw new NotImplementedException(); } + } + + public event EventHandler InterfaceEvent; + + int ICSharpExplicitInterface.ExplicitMethod(string parameter) + { + throw new NotImplementedException(); + } + + bool ICSharpExplicitInterface.ExplicitProperty + { + get { throw new NotImplementedException(); } + } + + event EventHandler ICSharpExplicitInterface.ExplicitEvent + { + add { throw new NotImplementedException(); } + remove { throw new NotImplementedException(); } + } + } + + public class CSharpOuterClass + { + public enum InnerEnum { Case1 } + + public class InnerClass + { + public static int StaticMember() + { + return 0; + } + } + } + +} diff --git a/tests/service/data/CSharp_Analysis/CSharp_Analysis.csproj b/tests/service/data/CSharp_Analysis/CSharp_Analysis.csproj new file mode 100644 index 00000000000..cfd59b04c4a --- /dev/null +++ b/tests/service/data/CSharp_Analysis/CSharp_Analysis.csproj @@ -0,0 +1,58 @@ + + + + + Debug + AnyCPU + {887630A3-4B1D-40EA-B8B3-2D842E9C40DB} + Library + Properties + CSharp_Analysis + CSharp_Analysis + v4.5 + ..\..\..\..\ + ..\..\..\..\$(Configuration)\net40\bin + 512 + + + + true + full + false + DEBUG;TRACE + prompt + 4 + + + pdbonly + true + TRACE + prompt + 4 + + + + + + + + + + + + + + + + + + + + ..\..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/CSharp_Analysis/Properties/AssemblyInfo.cs b/tests/service/data/CSharp_Analysis/Properties/AssemblyInfo.cs new file mode 100644 index 00000000000..6c36814e769 --- /dev/null +++ b/tests/service/data/CSharp_Analysis/Properties/AssemblyInfo.cs @@ -0,0 +1,36 @@ +using System.Reflection; +using System.Runtime.CompilerServices; +using System.Runtime.InteropServices; + +// Allgemeine Informationen über eine Assembly werden über die folgenden +// Attribute gesteuert. Ändern Sie diese Attributwerte, um die Informationen zu ändern, +// die mit einer Assembly verknüpft sind. +[assembly: AssemblyTitle("CSharp_Analysis")] +[assembly: AssemblyDescription("")] +[assembly: AssemblyConfiguration("")] +[assembly: AssemblyCompany("")] +[assembly: AssemblyProduct("CSharp_Analysis")] +[assembly: AssemblyCopyright("Copyright © 2015")] +[assembly: AssemblyTrademark("")] +[assembly: AssemblyCulture("")] + +// Durch Festlegen von ComVisible auf "false" werden die Typen in dieser Assembly unsichtbar +// für COM-Komponenten. Wenn Sie auf einen Typ in dieser Assembly von +// COM zugreifen müssen, legen Sie das ComVisible-Attribut für diesen Typ auf "true" fest. +[assembly: ComVisible(false)] + +// Die folgende GUID bestimmt die ID der Typbibliothek, wenn dieses Projekt für COM verfügbar gemacht wird +[assembly: Guid("e1b15939-475d-4134-a76c-20845e07be39")] + +// Versionsinformationen für eine Assembly bestehen aus den folgenden vier Werten: +// +// Hauptversion +// Nebenversion +// Buildnummer +// Revision +// +// Sie können alle Werte angeben oder die standardmäßigen Build- und Revisionsnummern +// übernehmen, indem Sie "*" eingeben: +// [assembly: AssemblyVersion("1.0.*")] +[assembly: AssemblyVersion("1.0.0.0")] +[assembly: AssemblyFileVersion("1.0.0.0")] diff --git a/tests/service/data/DifferingOutputDir/Dir1/OutputDir1/FSharp.Core.dll b/tests/service/data/DifferingOutputDir/Dir1/OutputDir1/FSharp.Core.dll new file mode 100644 index 00000000000..a8ab0782712 Binary files /dev/null and b/tests/service/data/DifferingOutputDir/Dir1/OutputDir1/FSharp.Core.dll differ diff --git a/tests/service/data/DifferingOutputDir/Dir1/Test1.fsproj b/tests/service/data/DifferingOutputDir/Dir1/Test1.fsproj new file mode 100644 index 00000000000..893cb5468c8 --- /dev/null +++ b/tests/service/data/DifferingOutputDir/Dir1/Test1.fsproj @@ -0,0 +1,62 @@ + + + + Debug + x86 + 8.0.30703 + 2.0 + {116cc2f9-f987-4b3d-915a-34cac04a73da} + Library + Test1 + Test1 + Test1 + False + 11 + + + True + full + False + False + OutputDir1 + DEBUG;TRACE + 3 + x86 + bin\Debug\Test1.xml + + + pdbonly + True + True + Test1\bin\Release\ + TRACE + 3 + x86 + bin\Release\Test1.xml + False + + + + ..\..\..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + + + + + ..\..\..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/DifferingOutputDir/Dir2/OutputDir2/FSharp.Core.dll b/tests/service/data/DifferingOutputDir/Dir2/OutputDir2/FSharp.Core.dll new file mode 100644 index 00000000000..a8ab0782712 Binary files /dev/null and b/tests/service/data/DifferingOutputDir/Dir2/OutputDir2/FSharp.Core.dll differ diff --git a/tests/service/data/DifferingOutputDir/Dir2/Test2.fsproj b/tests/service/data/DifferingOutputDir/Dir2/Test2.fsproj new file mode 100644 index 00000000000..184e10ab816 --- /dev/null +++ b/tests/service/data/DifferingOutputDir/Dir2/Test2.fsproj @@ -0,0 +1,68 @@ + + + + Debug + x86 + 8.0.30703 + 2.0 + {116cc2f9-f987-4b3d-915a-34cac04a73db} + Exe + Test2 + Test2 + Test2 + False + 11 + + + True + full + False + False + OutputDir2 + DEBUG;TRACE + 3 + x86 + bin\Debug\Test2.xml + + + pdbonly + True + True + Test2\bin\Release\ + TRACE + 3 + x86 + bin\Release\Test2.xml + False + + + + ..\..\..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + + {116cc2f9-f987-4b3d-915a-34cac04a73da} + Test1 + + + + + + + + ..\..\..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/FSharp.Data.DesignTime.dll b/tests/service/data/FSharp.Data.DesignTime.dll new file mode 100644 index 00000000000..fca7289ce56 Binary files /dev/null and b/tests/service/data/FSharp.Data.DesignTime.dll differ diff --git a/tests/service/data/FSharp.Data.dll b/tests/service/data/FSharp.Data.dll new file mode 100644 index 00000000000..39353541eed Binary files /dev/null and b/tests/service/data/FSharp.Data.dll differ diff --git a/tests/service/data/Malformed.fsproj b/tests/service/data/Malformed.fsproj new file mode 100644 index 00000000000..1079189f2d5 --- /dev/null +++ b/tests/service/data/Malformed.fsproj @@ -0,0 +1 @@ +Not even slightly like a project diff --git a/tests/service/data/MultiLanguageProject/ConsoleApplication1.fsproj b/tests/service/data/MultiLanguageProject/ConsoleApplication1.fsproj new file mode 100644 index 00000000000..be71ef6211e --- /dev/null +++ b/tests/service/data/MultiLanguageProject/ConsoleApplication1.fsproj @@ -0,0 +1,78 @@ + + + + + Debug + AnyCPU + 2.0 + 252a5848-1864-43fd-8fde-aab146410dee + Exe + ConsoleApplication1 + ConsoleApplication1 + v4.5 + true + ConsoleApplication1 + + + true + full + false + false + bin\Debug\ + DEBUG;TRACE + 3 + AnyCPU + bin\Debug\ConsoleApplication1.xml + true + + + pdbonly + true + true + bin\Release\ + TRACE + 3 + AnyCPU + bin\Release\ConsoleApplication1.xml + true + + + + + ..\..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + ConsoleApplication2 + {31b31546-8348-4be1-9890-1f17ba70fd21} + True + + + ConsoleApplication3 + {24795688-ce64-4475-a326-3175f1a40f68} + True + + + + 11 + + + + + + + ..\..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/MultiLanguageProject/ConsoleApplication2.fsproj b/tests/service/data/MultiLanguageProject/ConsoleApplication2.fsproj new file mode 100644 index 00000000000..5397e609058 --- /dev/null +++ b/tests/service/data/MultiLanguageProject/ConsoleApplication2.fsproj @@ -0,0 +1,70 @@ + + + + + Debug + AnyCPU + 2.0 + 31b31546-8348-4be1-9890-1f17ba70fd21 + Exe + ConsoleApplication2 + ConsoleApplication2 + v4.5 + true + ConsoleApplication2 + + + true + full + false + false + bin\Debug\ + DEBUG;TRACE + 3 + AnyCPU + bin\Debug\ConsoleApplication2.xml + true + + + pdbonly + true + true + bin\Release\ + TRACE + 3 + AnyCPU + bin\Release\ConsoleApplication2.xml + true + + + + + ..\..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + ConsoleApplication3 + {24795688-ce64-4475-a326-3175f1a40f68} + True + + + + + + + + ..\..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/MultiLanguageProject/ConsoleApplication3.csproj b/tests/service/data/MultiLanguageProject/ConsoleApplication3.csproj new file mode 100644 index 00000000000..b285b3505c1 --- /dev/null +++ b/tests/service/data/MultiLanguageProject/ConsoleApplication3.csproj @@ -0,0 +1,66 @@ + + + + + Debug + AnyCPU + {24795688-CE64-4475-A326-3175F1A40F68} + Exe + Properties + ConsoleApplication3 + ConsoleApplication3 + v4.5 + 512 + + + AnyCPU + true + full + false + bin\Debug\ + DEBUG;TRACE + prompt + 4 + + + AnyCPU + pdbonly + true + bin\Release\ + TRACE + prompt + 4 + + + + + + + + + + + + + + + + + + + + + ..\..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/ScriptProject/MainBad.fsx b/tests/service/data/ScriptProject/MainBad.fsx new file mode 100644 index 00000000000..5f64eefdfe1 --- /dev/null +++ b/tests/service/data/ScriptProject/MainBad.fsx @@ -0,0 +1,2 @@ +#load "NotExist1.fsx" +#r "NotExist.dll" diff --git a/tests/service/data/Space in name.fsproj b/tests/service/data/Space in name.fsproj new file mode 100644 index 00000000000..e75b13b4a2e --- /dev/null +++ b/tests/service/data/Space in name.fsproj @@ -0,0 +1,66 @@ + + + + Debug + x86 + 8.0.30703 + 2.0 + {116cc2f9-f987-4b3d-915a-34cac04a73db} + Exe + Test2 + Test2 + Test2 + False + ..\..\..\$(Configuration)\net40\bin + + + True + full + False + False + DEBUG;TRACE + 3 + x86 + bin\Debug\Test2.xml + + + pdbonly + True + True + TRACE + 3 + x86 + bin\Release\Test2.xml + False + + + + ..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + + {116cc2f9-f987-4b3d-915a-34cac04a73da} + Test1 + + + + + + + + ..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/System.Data.dll b/tests/service/data/System.Data.dll new file mode 100644 index 00000000000..6c657f1212a Binary files /dev/null and b/tests/service/data/System.Data.dll differ diff --git a/tests/service/data/Test1.fsproj b/tests/service/data/Test1.fsproj new file mode 100644 index 00000000000..b35fe316a04 --- /dev/null +++ b/tests/service/data/Test1.fsproj @@ -0,0 +1,60 @@ + + + + Debug + x86 + 8.0.30703 + 2.0 + {116cc2f9-f987-4b3d-915a-34cac04a73da} + Library + Test1 + Test1 + ..\..\..\$(Configuration)\net40\bin + False + 11 + + + True + full + False + False + DEBUG;TRACE + 3 + x86 + bin\Debug\Test1.xml + + + pdbonly + True + True + TRACE + 3 + x86 + bin\Release\Test1.xml + False + + + + ..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + + + + + ..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/Test2.fsproj b/tests/service/data/Test2.fsproj new file mode 100644 index 00000000000..bc76aa42198 --- /dev/null +++ b/tests/service/data/Test2.fsproj @@ -0,0 +1,67 @@ + + + + Debug + x86 + 8.0.30703 + 2.0 + {116cc2f9-f987-4b3d-915a-34cac04a73db} + ..\..\..\$(Configuration)\net40\bin + Exe + Test2 + Test2 + Test2 + False + 11 + + + True + full + False + False + DEBUG;TRACE + 3 + x86 + bin\Debug\Test2.xml + + + pdbonly + True + True + TRACE + 3 + x86 + bin\Release\Test2.xml + False + + + + ..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + + {116cc2f9-f987-4b3d-915a-34cac04a73da} + Test1 + + + + + + + + ..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/TestProject/AssemblyInfo.fs b/tests/service/data/TestProject/AssemblyInfo.fs new file mode 100644 index 00000000000..5c62ae5770c --- /dev/null +++ b/tests/service/data/TestProject/AssemblyInfo.fs @@ -0,0 +1,41 @@ +namespace TestProject.AssemblyInfo + +open System.Reflection +open System.Runtime.CompilerServices +open System.Runtime.InteropServices + +// General Information about an assembly is controlled through the following +// set of attributes. Change these attribute values to modify the information +// associated with an assembly. +[] +[] +[] +[] +[] +[] +[] +[] + +// Setting ComVisible to false makes the types in this assembly not visible +// to COM components. If you need to access a type in this assembly from +// COM, set the ComVisible attribute to true on that type. +[] + +// The following GUID is for the ID of the typelib if this project is exposed to COM +[] + +// Version information for an assembly consists of the following four values: +// +// Major Version +// Minor Version +// Build Number +// Revision +// +// You can specify all the values or you can default the Build and Revision Numbers +// by using the '*' as shown below: +// [] +[] +[] + +do + () \ No newline at end of file diff --git a/tests/service/data/TestProject/Library.fs b/tests/service/data/TestProject/Library.fs new file mode 100644 index 00000000000..b4d48c00f14 --- /dev/null +++ b/tests/service/data/TestProject/Library.fs @@ -0,0 +1,46 @@ +namespace TestProject + +type T = ErasedWithConstructor.Provided.MyType + +type Class1() = + member this.X1 = T().DoNothing() + member this.X2 = T().DoNothingGeneric() + member this.X3 = T().DoNothingOneArg() + member this.X4 = T().ClassDoNothing() + member this.X5 = T().ClassDoNothingGeneric() + member this.X6 = T().ClassDoNothingOneArg() + member this.X7 = T().ClassDoNothingTwoArg() + member this.X8 = T().ClassInstanceDoNothing() + member this.X9 = T().ClassInstanceDoNothingGeneric() + member this.X10 = T().ClassInstanceDoNothingOneArg() + member this.X11 = T().ClassInstanceDoNothingTwoArg() + member this.X12 = T().GenericClassDoNothing() + member this.X13 = T().GenericClassDoNothingOneArg() + member this.X14 = T().GenericClassDoNothingTwoArg() + member this.X15 = T().OptionConstructionAndMatch() + member this.X16 = T().ChoiceConstructionAndMatch() + member this.X17 = T().RecordConstructionAndFieldGetSet() + member this.X18 = T().DoNothingTwoArg() + member this.X19 = T().DoNothingTwoArgCurried() + member this.X21 = T().ClassDoNothingTwoArgCurried() + member this.X23 = T().ClassInstanceDoNothingTwoArgCurried() + member this.X24 = T().DoNothingGenericWithConstraint() + member this.X25 = T().DoNothingGenericWithTypeConstraint() + member this.X26 = T().DoNothingGenericWithTypeConstraint() + member this.X27 = T().DoNothingWithCompiledName() + member this.X28 = T().CSharpMethod() + member this.X29 = T().CSharpMethodOptionalParam() + member this.X30 = T().CSharpMethodParamArray() + member this.X31 = T().CSharpMethodGeneric() + member this.X32 = T().CSharpMethodGenericWithConstraint() + member this.X33 = T().CSharpMethodGenericWithTypeConstraint() + member this.X34 = T().ClassDoNothingWithCompiledName() + member this.X35 = T().ClassInstanceDoNothingWithCompiledName() + member this.X36 = T().CSharpExplicitImplementationMethod() + member this.X37 = T().InterfaceDoNothing() + member this.X38 = T().OverrideDoNothing() + member this.X39 = T().TupleConstructionAndGet() + member this.X40 = T().ModuleValue() + member this.X41 = T().ClassProperty() + member this.X42 = T().ClassAutoProperty() + member this.X43 = T().ClassStaticAutoProperty() diff --git a/tests/service/data/TestProject/TestProject.fsproj b/tests/service/data/TestProject/TestProject.fsproj new file mode 100644 index 00000000000..4626b188d33 --- /dev/null +++ b/tests/service/data/TestProject/TestProject.fsproj @@ -0,0 +1,72 @@ + + + + + Debug + AnyCPU + 2.0 + ed64425e-b549-439a-b105-6c921a81f31a + Library + TestProject + TestProject + v4.5 + true + TestProject + + + true + full + false + false + bin\Debug\ + DEBUG;TRACE + 3 + bin\Debug\TestProject.xml + + + pdbonly + true + true + bin\Release\ + TRACE + 3 + bin\Release\TestProject.xml + + + + + ..\..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + + CSharp_Analysis + {887630a3-4b1d-40ea-b8b3-2d842e9c40db} + True + + + TestTP + {ff76bd3c-5e0a-4752-b6c3-044f6e15719b} + True + + + + + + + + ..\..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/TestTP/Library.fs b/tests/service/data/TestTP/Library.fs new file mode 100644 index 00000000000..3d5474e50bf --- /dev/null +++ b/tests/service/data/TestTP/Library.fs @@ -0,0 +1,291 @@ +namespace TestTP + +open ProviderImplementation.ProvidedTypes +open Microsoft.FSharp.Core.CompilerServices +open System.Reflection + +module Helper = + let doNothing() = () + let doNothingOneArg(x:int) = () + let doNothingTwoArg(x:int, y: int) = () + let doNothingTwoArgCurried(x:int) (y: int) = () + [] + let doNothingWithCompiledName() = () + let doNothingGeneric(x:'T) = () + let doNothingGenericWithConstraint(x: 'T when 'T: equality) = () + let doNothingGenericWithTypeConstraint(x: 'T when 'T :> _ seq) = () + + let mutable moduleValue = 0 + + type I = + abstract DoNothing: unit -> unit + + type B() = + abstract VirtualDoNothing: unit -> unit + default this.VirtualDoNothing() = () + + type C() = + inherit B() + let mutable p = 0 + static member DoNothing() = () + static member DoNothingOneArg(x:int) = () + static member DoNothingOneArg(x:string) = () + static member DoNothingTwoArg(c:C, x:int) = () + static member DoNothingTwoArgCurried (c:C) (x:int) = () + static member DoNothingGeneric(x:'T) = () + [] + static member DoNothingWithCompiledName() = () + member __.InstanceDoNothing() = () + member __.InstanceDoNothingOneArg(x:int) = () + member __.InstanceDoNothingOneArg(x:string) = () + member __.InstanceDoNothingTwoArg(c:C, x:int) = () + member __.InstanceDoNothingTwoArgCurried(c:C) (x:int) = () + member __.InstanceDoNothingGeneric(x:'T) = () + [] + member __.InstanceDoNothingWithCompiledName() = () + override __.VirtualDoNothing() = () + + member __.Property with get() = p and set v = p <- v + member val AutoProperty = 0 with get, set + static member val StaticAutoProperty = 0 with get, set + + interface I with + member this.DoNothing() = () + + type G<'U>() = + static member DoNothing() = () + static member DoNothingOneArg(x:int) = () + static member DoNothingTwoArg(c:C, x:int) = () + static member DoNothingGeneric(x:'T) = () + member __.InstanceDoNothing() = () + member __.InstanceDoNothingOneArg(x:int) = () + member __.InstanceDoNothingTwoArg(c:C, x:int) = () + member __.InstanceDoNothingGeneric(x:'U) = () + + type R = { A : int; mutable B : int } + +open FSharp.Compiler.Service.Tests + +[] +type BasicProvider (config : TypeProviderConfig) as this = + inherit TypeProviderForNamespaces () + + // resolve CSharp_Analysis from referenced assemblies + do System.AppDomain.CurrentDomain.add_AssemblyResolve(fun _ args -> + let name = AssemblyName(args.Name).Name.ToLowerInvariant() + let an = + config.ReferencedAssemblies + |> Seq.tryFind (fun an -> + System.IO.Path.GetFileNameWithoutExtension(an).ToLowerInvariant() = name) + match an with + | Some f -> Assembly.LoadFrom f + | None -> null + ) + + let ns = "ErasedWithConstructor.Provided" + let asm = Assembly.GetExecutingAssembly() + + let createTypes () = + let myType = ProvidedTypeDefinition(asm, ns, "MyType", Some typeof) + + let ctor = ProvidedConstructor([], InvokeCode = fun args -> <@@ "My internal state" :> obj @@>) + myType.AddMember(ctor) + + let ctor2 = ProvidedConstructor( + [ProvidedParameter("InnerState", typeof)], + InvokeCode = fun args -> <@@ (%%(args.[0]):string) :> obj @@>) + myType.AddMember(ctor2) + + let innerState = ProvidedProperty("InnerState", typeof, + GetterCode = fun args -> <@@ (%%(args.[0]) :> obj) :?> string @@>) + myType.AddMember(innerState) + + let someMethod = ProvidedMethod("DoNothing", [], typeof, + InvokeCode = fun args -> <@@ Helper.doNothing() @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("DoNothingOneArg", [], typeof, + InvokeCode = fun args -> <@@ Helper.doNothingOneArg(3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("DoNothingTwoArg", [], typeof, + InvokeCode = fun args -> <@@ Helper.doNothingTwoArg(3, 4) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("DoNothingTwoArgCurried", [], typeof, + InvokeCode = fun args -> <@@ Helper.doNothingTwoArgCurried 3 4 @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("DoNothingWithCompiledName", [], typeof, + InvokeCode = fun args -> <@@ Helper.doNothingWithCompiledName() @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("DoNothingGeneric", [], typeof, + InvokeCode = fun args -> <@@ Helper.doNothingGeneric(3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("DoNothingGenericWithConstraint", [], typeof, + InvokeCode = fun args -> <@@ Helper.doNothingGenericWithConstraint(3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("DoNothingGenericWithTypeConstraint", [], typeof, + InvokeCode = fun args -> <@@ Helper.doNothingGenericWithTypeConstraint([3]) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassDoNothing", [], typeof, + InvokeCode = fun args -> <@@ Helper.C.DoNothing() @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassDoNothingGeneric", [], typeof, + InvokeCode = fun args -> <@@ Helper.C.DoNothingGeneric(3) @@>) + + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassDoNothingOneArg", [], typeof, + InvokeCode = fun args -> <@@ Helper.C.DoNothingOneArg(3) @@>) + + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassDoNothingTwoArg", [], typeof, + InvokeCode = fun args -> <@@ Helper.C.DoNothingTwoArg(Helper.C(), 3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassDoNothingTwoArgCurried", [], typeof, + InvokeCode = fun args -> <@@ Helper.C.DoNothingTwoArgCurried (Helper.C()) 3 @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassDoNothingWithCompiledName", [], typeof, + InvokeCode = fun args -> <@@ Helper.C.DoNothingWithCompiledName() @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassInstanceDoNothing", [], typeof, + InvokeCode = fun args -> <@@ Helper.C().InstanceDoNothing() @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassInstanceDoNothingGeneric", [], typeof, + InvokeCode = fun args -> <@@ Helper.C().InstanceDoNothingGeneric(3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassInstanceDoNothingOneArg", [], typeof, + InvokeCode = fun args -> <@@ Helper.C().InstanceDoNothingOneArg(3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassInstanceDoNothingTwoArg", [], typeof, + InvokeCode = fun args -> <@@ Helper.C().InstanceDoNothingTwoArg(Helper.C(), 3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassInstanceDoNothingTwoArgCurried", [], typeof, + InvokeCode = fun args -> <@@ Helper.C().InstanceDoNothingTwoArgCurried (Helper.C()) 3 @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassInstanceDoNothingWithCompiledName", [], typeof, + InvokeCode = fun args -> <@@ Helper.C().InstanceDoNothingWithCompiledName() @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("InterfaceDoNothing", [], typeof, + InvokeCode = fun args -> <@@ (Helper.C() :> Helper.I).DoNothing() @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("OverrideDoNothing", [], typeof, + InvokeCode = fun args -> <@@ Helper.C().VirtualDoNothing() @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("GenericClassDoNothing", [], typeof, + InvokeCode = fun args -> <@@ Helper.G.DoNothing() @@>) + myType.AddMember(someMethod) + + // These do not seem to compile correctly when used in provided expressions: + //Helper.G.DoNothingGeneric(3) + + // These do not seem to compile correctly when used in provided expressions: + //Helper.G().InstanceDoNothingGeneric(3) + + let someMethod = ProvidedMethod("GenericClassDoNothingOneArg", [], typeof, + InvokeCode = fun args -> <@@ Helper.G.DoNothingOneArg(3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("GenericClassDoNothingTwoArg", [], typeof, + InvokeCode = fun args -> <@@ Helper.G.DoNothingTwoArg(Helper.C(), 3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("GenericClassInstanceDoNothing", [], typeof, + InvokeCode = fun args -> <@@ Helper.G().InstanceDoNothing() @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("GenericClassInstanceDoNothingOneArg", [], typeof, + InvokeCode = fun args -> <@@ Helper.G().InstanceDoNothingOneArg(3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("GenericClassInstanceDoNothingTwoArg", [], typeof, + InvokeCode = fun args -> <@@ Helper.G().InstanceDoNothingTwoArg(Helper.C(), 3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("OptionConstructionAndMatch", [], typeof, + InvokeCode = fun args -> <@@ match Some 1 with None -> 0 | Some x -> x @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ChoiceConstructionAndMatch", [], typeof, + InvokeCode = fun args -> <@@ match Choice1Of2 1 with Choice2Of2 _ -> 0 | Choice1Of2 _ -> 1 @@>) + // TODO: fix type checker to recognize union generated subclasses coming from TPs +// InvokeCode = fun args -> <@@ match Choice1Of2 1 with Choice2Of2 _ -> 0 | Choice1Of2 x -> x @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("RecordConstructionAndFieldGetSet", [], typeof, + InvokeCode = fun args -> <@@ let r : Helper.R = { A = 1; B = 0 } in r.B <- 1; r.A @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("TupleConstructionAndGet", [], typeof, + InvokeCode = fun args -> <@@ let t = (1, 2, 3) in (let (_, i, _) = t in i) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("CSharpMethod", [], typeof, + InvokeCode = fun args -> <@@ CSharpClass(0).Method("x") @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("CSharpMethodOptionalParam", [], typeof, + InvokeCode = fun args -> <@@ CSharpClass(0).Method2("x") + CSharpClass(0).Method2() @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("CSharpMethodParamArray", [], typeof, + InvokeCode = fun args -> <@@ CSharpClass(0).Method3("x", "y") @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("CSharpMethodGeneric", [], typeof, + InvokeCode = fun args -> <@@ CSharpClass(0).GenericMethod(2) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("CSharpMethodGenericWithConstraint", [], typeof, + InvokeCode = fun args -> <@@ CSharpClass(0).GenericMethod2(obj()) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("CSharpMethodGenericWithTypeConstraint", [], typeof, + InvokeCode = fun args -> <@@ CSharpClass(0).GenericMethod3(3) @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("CSharpExplicitImplementationMethod", [], typeof, + InvokeCode = fun args -> <@@ (CSharpClass(0) :> ICSharpExplicitInterface).ExplicitMethod("x") @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ModuleValue", [], typeof, + InvokeCode = fun args -> <@@ Helper.moduleValue <- 1; Helper.moduleValue @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassProperty", [], typeof, + InvokeCode = fun args -> <@@ let x = Helper.C() in x.Property <- 1; x.Property @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassAutoProperty", [], typeof, + InvokeCode = fun args -> <@@ let x = Helper.C() in x.AutoProperty <- 1; x.AutoProperty @@>) + myType.AddMember(someMethod) + + let someMethod = ProvidedMethod("ClassStaticAutoProperty", [], typeof, + InvokeCode = fun args -> <@@ Helper.C.StaticAutoProperty <- 1; Helper.C.StaticAutoProperty @@>) + myType.AddMember(someMethod) + + [myType] + + do + this.AddNamespace(ns, createTypes()) + +[] +do () \ No newline at end of file diff --git a/tests/service/data/TestTP/ProvidedTypes.fs b/tests/service/data/TestTP/ProvidedTypes.fs new file mode 100644 index 00000000000..5cf2954749b --- /dev/null +++ b/tests/service/data/TestTP/ProvidedTypes.fs @@ -0,0 +1,2736 @@ +#nowarn "40" +#nowarn "52" +// Based on code for the F# 3.0 Developer Preview release of September 2011, +// Copyright (c) Microsoft Corporation 2005-2012. +// This sample code is provided "as is" without warranty of any kind. +// We disclaim all warranties, either express or implied, including the +// warranties of merchantability and fitness for a particular purpose. + +// This file contains a set of helper types and methods for providing types in an implementation +// of ITypeProvider. + +// This code has been modified and is appropriate for use in conjunction with the F# 3.0, F# 3.1, and F# 3.1.1 releases + +namespace ProviderImplementation.ProvidedTypes + +open System +open System.Text +open System.IO +open System.Reflection +open System.Reflection.Emit +open System.Linq.Expressions +open System.Collections.Generic +open Microsoft.FSharp.Core.CompilerServices + +type E = Quotations.Expr +module P = Quotations.Patterns +module ES = Quotations.ExprShape +module DP = Quotations.DerivedPatterns + +type internal ExpectedStackState = + | Empty = 1 + | Address = 2 + | Value = 3 + +[] +module internal Misc = + + let TypeBuilderInstantiationType = + let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e -> false + let typeName = if runningOnMono then "System.Reflection.MonoGenericClass" else "System.Reflection.Emit.TypeBuilderInstantiation" + typeof.Assembly.GetType(typeName) + + let GetTypeFromHandleMethod = typeof.GetMethod("GetTypeFromHandle") + let LanguagePrimitivesType = typedefof>.Assembly.GetType("Microsoft.FSharp.Core.LanguagePrimitives") + let ParseInt32Method = LanguagePrimitivesType.GetMethod "ParseInt32" + let DecimalConstructor = typeof.GetConstructor([| typeof; typeof; typeof; typeof; typeof |]) + let DateTimeConstructor = typeof.GetConstructor([| typeof; typeof |]) + let DateTimeOffsetConstructor = typeof.GetConstructor([| typeof; typeof |]) + let TimeSpanConstructor = typeof.GetConstructor([|typeof|]) + let isEmpty s = s = ExpectedStackState.Empty + let isAddress s = s = ExpectedStackState.Address + + let nonNull str x = if x=null then failwith ("Null in " + str) else x + + let notRequired opname item = + let msg = sprintf "The operation '%s' on item '%s' should not be called on provided type, member or parameter" opname item + System.Diagnostics.Debug.Assert (false, msg) + raise (System.NotSupportedException msg) + + let mkParamArrayCustomAttributeData() = +#if FX_NO_CUSTOMATTRIBUTEDATA + { new IProvidedCustomAttributeData with +#else + { new CustomAttributeData() with +#endif + member __.Constructor = typeof.GetConstructors().[0] + member __.ConstructorArguments = upcast [| |] + member __.NamedArguments = upcast [| |] } + +#if FX_NO_CUSTOMATTRIBUTEDATA + let CustomAttributeTypedArgument(ty,v) = + { new IProvidedCustomAttributeTypedArgument with + member x.ArgumentType = ty + member x.Value = v } + let CustomAttributeNamedArgument(memb,arg:IProvidedCustomAttributeTypedArgument) = + { new IProvidedCustomAttributeNamedArgument with + member x.MemberInfo = memb + member x.ArgumentType = arg.ArgumentType + member x.TypedValue = arg } + type CustomAttributeData = Microsoft.FSharp.Core.CompilerServices.IProvidedCustomAttributeData +#endif + + let mkEditorHideMethodsCustomAttributeData() = +#if FX_NO_CUSTOMATTRIBUTEDATA + { new IProvidedCustomAttributeData with +#else + { new CustomAttributeData() with +#endif + member __.Constructor = typeof.GetConstructors().[0] + member __.ConstructorArguments = upcast [| |] + member __.NamedArguments = upcast [| |] } + + let mkAllowNullLiteralCustomAttributeData value = +#if FX_NO_CUSTOMATTRIBUTEDATA + { new IProvidedCustomAttributeData with +#else + { new CustomAttributeData() with +#endif + member __.Constructor = typeof.GetConstructors().[0] + member __.ConstructorArguments = upcast [| CustomAttributeTypedArgument(typeof, value) |] + member __.NamedArguments = upcast [| |] } + + /// This makes an xml doc attribute w.r.t. an amortized computation of an xml doc string. + /// It is important that the text of the xml doc only get forced when poking on the ConstructorArguments + /// for the CustomAttributeData object. + let mkXmlDocCustomAttributeDataLazy(lazyText: Lazy) = +#if FX_NO_CUSTOMATTRIBUTEDATA + { new IProvidedCustomAttributeData with +#else + { new CustomAttributeData() with +#endif + member __.Constructor = typeof.GetConstructors().[0] + member __.ConstructorArguments = upcast [| CustomAttributeTypedArgument(typeof, lazyText.Force()) |] + member __.NamedArguments = upcast [| |] } + + let mkXmlDocCustomAttributeData(s:string) = mkXmlDocCustomAttributeDataLazy (lazy s) + + let mkDefinitionLocationAttributeCustomAttributeData(line:int,column:int,filePath:string) = +#if FX_NO_CUSTOMATTRIBUTEDATA + { new IProvidedCustomAttributeData with +#else + { new CustomAttributeData() with +#endif + member __.Constructor = typeof.GetConstructors().[0] + member __.ConstructorArguments = upcast [| |] + member __.NamedArguments = + upcast [| CustomAttributeNamedArgument(typeof.GetProperty("FilePath"), CustomAttributeTypedArgument(typeof, filePath)); + CustomAttributeNamedArgument(typeof.GetProperty("Line"), CustomAttributeTypedArgument(typeof, line)) ; + CustomAttributeNamedArgument(typeof.GetProperty("Column"), CustomAttributeTypedArgument(typeof, column)) + |] } + let mkObsoleteAttributeCustomAttributeData(message:string, isError: bool) = +#if FX_NO_CUSTOMATTRIBUTEDATA + { new IProvidedCustomAttributeData with +#else + { new CustomAttributeData() with +#endif + member __.Constructor = typeof.GetConstructors() |> Array.find (fun x -> x.GetParameters().Length = 1) + member __.ConstructorArguments = upcast [|CustomAttributeTypedArgument(typeof, message) ; CustomAttributeTypedArgument(typeof, isError) |] + member __.NamedArguments = upcast [| |] } + + type CustomAttributesImpl() = + let customAttributes = ResizeArray() + let mutable hideObjectMethods = false + let mutable nonNullable = false + let mutable obsoleteMessage = None + let mutable xmlDocDelayed = None + let mutable xmlDocAlwaysRecomputed = None + let mutable hasParamArray = false + + // XML doc text that we only compute once, if any. This must _not_ be forced until the ConstructorArguments + // property of the custom attribute is foced. + let xmlDocDelayedText = + lazy + (match xmlDocDelayed with None -> assert false; "" | Some f -> f()) + + // Custom atttributes that we only compute once + let customAttributesOnce = + lazy + [| if hideObjectMethods then yield mkEditorHideMethodsCustomAttributeData() + if nonNullable then yield mkAllowNullLiteralCustomAttributeData false + match xmlDocDelayed with None -> () | Some _ -> customAttributes.Add(mkXmlDocCustomAttributeDataLazy xmlDocDelayedText) + match obsoleteMessage with None -> () | Some s -> customAttributes.Add(mkObsoleteAttributeCustomAttributeData s) + if hasParamArray then yield mkParamArrayCustomAttributeData() + yield! customAttributes |] + + member __.AddDefinitionLocation(line:int,column:int,filePath:string) = customAttributes.Add(mkDefinitionLocationAttributeCustomAttributeData(line, column, filePath)) + member __.AddObsolete(message : string, isError) = obsoleteMessage <- Some (message,isError) + member __.HasParamArray with get() = hasParamArray and set(v) = hasParamArray <- v + member __.AddXmlDocComputed xmlDocFunction = xmlDocAlwaysRecomputed <- Some xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = xmlDocDelayed <- Some xmlDocFunction + member __.AddXmlDoc xmlDoc = xmlDocDelayed <- Some (fun () -> xmlDoc) + member __.HideObjectMethods with set v = hideObjectMethods <- v + member __.NonNullable with set v = nonNullable <- v + member __.AddCustomAttribute(attribute) = customAttributes.Add(attribute) + member __.GetCustomAttributesData() = + [| yield! customAttributesOnce.Force() + match xmlDocAlwaysRecomputed with None -> () | Some f -> customAttributes.Add(mkXmlDocCustomAttributeData (f())) |] + :> IList<_> + + let transExpr isGenerated q = + let rec trans q = + match q with + // convert NewTuple to the call to the constructor of the Tuple type (only for generated types) + | Quotations.Patterns.NewTuple(items) when isGenerated -> + let rec mkCtor args ty = + let ctor, restTyOpt = Reflection.FSharpValue.PreComputeTupleConstructorInfo ty + match restTyOpt with + | None -> Quotations.Expr.NewObject(ctor, List.map trans args) + | Some restTy -> + let curr = [for a in Seq.take 7 args -> trans a] + let rest = List.ofSeq (Seq.skip 7 args) + Quotations.Expr.NewObject(ctor, curr @ [mkCtor rest restTy]) + let tys = [| for e in items -> e.Type |] + let tupleTy = Reflection.FSharpType.MakeTupleType tys + trans (mkCtor items tupleTy) + // convert TupleGet to the chain of PropertyGet calls (only for generated types) + | Quotations.Patterns.TupleGet(e, i) when isGenerated -> + let rec mkGet ty i (e : Quotations.Expr) = + let pi, restOpt = Reflection.FSharpValue.PreComputeTuplePropertyInfo(ty, i) + let propGet = Quotations.Expr.PropertyGet(e, pi) + match restOpt with + | None -> propGet + | Some (restTy, restI) -> mkGet restTy restI propGet + trans (mkGet e.Type i (trans e)) + | Quotations.Patterns.Value(value, ty) -> + if value <> null then + let tyOfValue = value.GetType() + transValue(value, tyOfValue, ty) + else q + // Eliminate F# property gets to method calls + | Quotations.Patterns.PropertyGet(obj,propInfo,args) -> + match obj with + | None -> trans (Quotations.Expr.Call(propInfo.GetGetMethod(),args)) + | Some o -> trans (Quotations.Expr.Call(trans o,propInfo.GetGetMethod(),args)) + // Eliminate F# property sets to method calls + | Quotations.Patterns.PropertySet(obj,propInfo,args,v) -> + match obj with + | None -> trans (Quotations.Expr.Call(propInfo.GetSetMethod(),args@[v])) + | Some o -> trans (Quotations.Expr.Call(trans o,propInfo.GetSetMethod(),args@[v])) + // Eliminate F# function applications to FSharpFunc<_,_>.Invoke calls + | Quotations.Patterns.Application(f,e) -> + trans (Quotations.Expr.Call(trans f, f.Type.GetMethod "Invoke", [ e ]) ) + | Quotations.Patterns.NewUnionCase(ci, es) -> + trans (Quotations.Expr.Call(Reflection.FSharpValue.PreComputeUnionConstructorInfo ci, es) ) + | Quotations.Patterns.NewRecord(ci, es) -> + trans (Quotations.Expr.NewObject(Reflection.FSharpValue.PreComputeRecordConstructorInfo ci, es) ) + | Quotations.Patterns.UnionCaseTest(e,uc) -> + let tagInfo = Reflection.FSharpValue.PreComputeUnionTagMemberInfo uc.DeclaringType + let tagExpr = + match tagInfo with + | :? PropertyInfo as tagProp -> + trans (Quotations.Expr.PropertyGet(e,tagProp) ) + | :? MethodInfo as tagMeth -> + if tagMeth.IsStatic then trans (Quotations.Expr.Call(tagMeth, [e])) + else trans (Quotations.Expr.Call(e,tagMeth,[])) + | _ -> failwith "unreachable: unexpected result from PreComputeUnionTagMemberInfo" + let tagNumber = uc.Tag + trans <@@ (%%(tagExpr) : int) = tagNumber @@> + + // Explicitly handle weird byref variables in lets (used to populate out parameters), since the generic handlers can't deal with byrefs + | Quotations.Patterns.Let(v,vexpr,bexpr) when v.Type.IsByRef -> + + // the binding must have leaves that are themselves variables (due to the limited support for byrefs in expressions) + // therefore, we can perform inlining to translate this to a form that can be compiled + inlineByref v vexpr bexpr + + // Eliminate recursive let bindings (which are unsupported by the type provider API) to regular let bindings + | Quotations.Patterns.LetRecursive(bindings, expr) -> + // This uses a "lets and sets" approach, converting something like + // let rec even = function + // | 0 -> true + // | n -> odd (n-1) + // and odd = function + // | 0 -> false + // | n -> even (n-1) + // X + // to something like + // let even = ref Unchecked.defaultof<_> + // let odd = ref Unchecked.defaultof<_> + // even := function + // | 0 -> true + // | n -> !odd (n-1) + // odd := function + // | 0 -> false + // | n -> !even (n-1) + // X' + // where X' is X but with occurrences of even/odd substituted by !even and !odd (since now even and odd are references) + // Translation relies on typedefof<_ ref> - does this affect ability to target different runtime and design time environments? + let vars = List.map fst bindings + let vars' = vars |> List.map (fun v -> Quotations.Var(v.Name, typedefof<_ ref>.MakeGenericType(v.Type))) + + // init t generates the equivalent of <@ ref Unchecked.defaultof @> + let init (t:Type) = + let r = match <@ ref 1 @> with Quotations.Patterns.Call(None, r, [_]) -> r | _ -> failwith "Extracting MethodInfo from <@ 1 @> failed" + let d = match <@ Unchecked.defaultof<_> @> with Quotations.Patterns.Call(None, d, []) -> d | _ -> failwith "Extracting MethodInfo from <@ Unchecked.defaultof<_> @> failed" + Quotations.Expr.Call(r.GetGenericMethodDefinition().MakeGenericMethod(t), [Quotations.Expr.Call(d.GetGenericMethodDefinition().MakeGenericMethod(t),[])]) + + // deref v generates the equivalent of <@ !v @> + // (so v's type must be ref) + let deref (v:Quotations.Var) = + let m = match <@ !(ref 1) @> with Quotations.Patterns.Call(None, m, [_]) -> m | _ -> failwith "Extracting MethodInfo from <@ !(ref 1) @> failed" + let tyArgs = v.Type.GetGenericArguments() + Quotations.Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(tyArgs), [Quotations.Expr.Var v]) + + // substitution mapping a variable v to the expression <@ !v' @> using the corresponding new variable v' of ref type + let subst = + let map = + vars' + |> List.map deref + |> List.zip vars + |> Map.ofList + fun v -> Map.tryFind v map + + let expr' = expr.Substitute(subst) + + // maps variables to new variables + let varDict = List.zip vars vars' |> dict + + // given an old variable v and an expression e, returns a quotation like <@ v' := e @> using the corresponding new variable v' of ref type + let setRef (v:Quotations.Var) e = + let m = match <@ (ref 1) := 2 @> with Quotations.Patterns.Call(None, m, [_;_]) -> m | _ -> failwith "Extracting MethodInfo from <@ (ref 1) := 2 @> failed" + Quotations.Expr.Call(m.GetGenericMethodDefinition().MakeGenericMethod(v.Type), [Quotations.Expr.Var varDict.[v]; e]) + + // Something like + // <@ + // v1 := e1' + // v2 := e2' + // ... + // expr' + // @> + // Note that we must substitute our new variable dereferences into the bound expressions + let body = + bindings + |> List.fold (fun b (v,e) -> Quotations.Expr.Sequential(setRef v (e.Substitute subst), b)) expr' + + // Something like + // let v1 = ref Unchecked.defaultof + // let v2 = ref Unchecked.defaultof + // ... + // body + vars + |> List.fold (fun b v -> Quotations.Expr.Let(varDict.[v], init v.Type, b)) body + |> trans + + // Handle the generic cases + | Quotations.ExprShape.ShapeLambda(v,body) -> + Quotations.Expr.Lambda(v, trans body) + | Quotations.ExprShape.ShapeCombination(comb,args) -> + Quotations.ExprShape.RebuildShapeCombination(comb,List.map trans args) + | Quotations.ExprShape.ShapeVar _ -> q + and inlineByref v vexpr bexpr = + match vexpr with + | Quotations.Patterns.Sequential(e',vexpr') -> + (* let v = (e'; vexpr') in bexpr => e'; let v = vexpr' in bexpr *) + Quotations.Expr.Sequential(e', inlineByref v vexpr' bexpr) + |> trans + | Quotations.Patterns.IfThenElse(c,b1,b2) -> + (* let v = if c then b1 else b2 in bexpr => if c then let v = b1 in bexpr else let v = b2 in bexpr *) + Quotations.Expr.IfThenElse(c, inlineByref v b1 bexpr, inlineByref v b2 bexpr) + |> trans + | Quotations.Patterns.Var _ -> + (* let v = v1 in bexpr => bexpr[v/v1] *) + bexpr.Substitute(fun v' -> if v = v' then Some vexpr else None) + |> trans + | _ -> + failwith (sprintf "Unexpected byref binding: %A = %A" v vexpr) + and transValue (v : obj, tyOfValue : Type, expectedTy : Type) = + let rec transArray (o : Array, ty : Type) = + let elemTy = ty.GetElementType() + let converter = getConverterForType elemTy + let elements = + [ + for el in o do + yield converter el + ] + Quotations.Expr.NewArray(elemTy, elements) + and transList(o, ty : Type, nil, cons) = + let converter = getConverterForType (ty.GetGenericArguments().[0]) + o + |> Seq.cast + |> List.ofSeq + |> fun l -> List.foldBack(fun o s -> Quotations.Expr.NewUnionCase(cons, [ converter(o); s ])) l (Quotations.Expr.NewUnionCase(nil, [])) + |> trans + and getConverterForType (ty : Type) = + if ty.IsArray then + fun (v : obj) -> transArray(v :?> Array, ty) + elif ty.IsGenericType && ty.GetGenericTypeDefinition() = typedefof<_ list> then + let nil, cons = + let cases = Reflection.FSharpType.GetUnionCases(ty) + let a = cases.[0] + let b = cases.[1] + if a.Name = "Empty" then a,b + else b,a + + fun v -> transList (v :?> System.Collections.IEnumerable, ty, nil, cons) + else + fun v -> Quotations.Expr.Value(v, ty) + let converter = getConverterForType tyOfValue + let r = converter v + if tyOfValue <> expectedTy then Quotations.Expr.Coerce(r, expectedTy) + else r + trans q + + let getFastFuncType (args : list) resultType = + let types = + [| + for arg in args -> arg.Type + yield resultType + |] + let fastFuncTy = + match List.length args with + | 2 -> typedefof>.MakeGenericType(types) + | 3 -> typedefof>.MakeGenericType(types) + | 4 -> typedefof>.MakeGenericType(types) + | 5 -> typedefof>.MakeGenericType(types) + | _ -> invalidArg "args" "incorrect number of arguments" + fastFuncTy.GetMethod("Adapt") + + let inline (===) a b = LanguagePrimitives.PhysicalEquality a b + + let traverse f = + let rec fallback e = + match e with + | P.Let(v, value, body) -> + let fixedValue = f fallback value + let fixedBody = f fallback body + if fixedValue === value && fixedBody === body then + e + else + E.Let(v, fixedValue, fixedBody) + | ES.ShapeVar _ -> e + | ES.ShapeLambda(v, body) -> + let fixedBody = f fallback body + if fixedBody === body then + e + else + E.Lambda(v, fixedBody) + | ES.ShapeCombination(shape, exprs) -> + let exprs1 = List.map (f fallback) exprs + if List.forall2 (===) exprs exprs1 then + e + else + ES.RebuildShapeCombination(shape, exprs1) + fun e -> f fallback e + + let RightPipe = <@@ (|>) @@> + let inlineRightPipe expr = + let rec loop expr = traverse loopCore expr + and loopCore fallback orig = + match orig with + | DP.SpecificCall RightPipe (None, _, [operand; applicable]) -> + let fixedOperand = loop operand + match loop applicable with + | P.Lambda(arg, body) -> + let v = Quotations.Var("__temp", operand.Type) + let ev = E.Var v + + let fixedBody = loop body + E.Let(v, fixedOperand, fixedBody.Substitute(fun v1 -> if v1 = arg then Some ev else None)) + | fixedApplicable -> E.Application(fixedApplicable, fixedOperand) + | x -> fallback x + loop expr + + let inlineValueBindings e = + let map = Dictionary(HashIdentity.Reference) + let rec loop expr = traverse loopCore expr + and loopCore fallback orig = + match orig with + | P.Let(id, (P.Value(_) as v), body) when not id.IsMutable -> + map.[id] <- v + let fixedBody = loop body + map.Remove(id) |> ignore + fixedBody + | ES.ShapeVar v -> + match map.TryGetValue v with + | true, e -> e + | _ -> orig + | x -> fallback x + loop e + + + let optimizeCurriedApplications expr = + let rec loop expr = traverse loopCore expr + and loopCore fallback orig = + match orig with + | P.Application(e, arg) -> + let e1 = tryPeelApplications e [loop arg] + if e1 === e then + orig + else + e1 + | x -> fallback x + and tryPeelApplications orig args = + let n = List.length args + match orig with + | P.Application(e, arg) -> + let e1 = tryPeelApplications e ((loop arg)::args) + if e1 === e then + orig + else + e1 + | P.Let(id, applicable, (P.Lambda(_) as body)) when n > 0 -> + let numberOfApplication = countPeelableApplications body id 0 + if numberOfApplication = 0 then orig + elif n = 1 then E.Application(applicable, List.head args) + elif n <= 5 then + let resultType = + applicable.Type + |> Seq.unfold (fun t -> + if not t.IsGenericType then None + else + let args = t.GetGenericArguments() + if args.Length <> 2 then None + else + Some (args.[1], args.[1]) + ) + |> Seq.nth (n - 1) + + let adaptMethod = getFastFuncType args resultType + let adapted = E.Call(adaptMethod, [loop applicable]) + let invoke = adapted.Type.GetMethod("Invoke", [| for arg in args -> arg.Type |]) + E.Call(adapted, invoke, args) + else + (applicable, args) ||> List.fold (fun e a -> E.Application(e, a)) + | _ -> + orig + and countPeelableApplications expr v n = + match expr with + // v - applicable entity obtained on the prev step + // \arg -> let v1 = (f arg) in rest ==> f + | P.Lambda(arg, P.Let(v1, P.Application(P.Var f, P.Var arg1), rest)) when v = f && arg = arg1 -> countPeelableApplications rest v1 (n + 1) + // \arg -> (f arg) ==> f + | P.Lambda(arg, P.Application(P.Var f, P.Var arg1)) when v = f && arg = arg1 -> n + | _ -> n + loop expr + + // FSharp.Data change: use the real variable names instead of indices, to improve output of Debug.fs + let transQuotationToCode isGenerated qexprf (paramNames: string[]) (argExprs: Quotations.Expr[]) = + // add let bindings for arguments to ensure that arguments will be evaluated + let vars = argExprs |> Array.mapi (fun i e -> Quotations.Var(paramNames.[i], e.Type)) + let expr = qexprf ([for v in vars -> Quotations.Expr.Var v]) + + let pairs = Array.zip argExprs vars + let expr = Array.foldBack (fun (arg, var) e -> Quotations.Expr.Let(var, arg, e)) pairs expr + let expr = + if isGenerated then + let e1 = inlineRightPipe expr + let e2 = optimizeCurriedApplications e1 + let e3 = inlineValueBindings e2 + e3 + else + expr + + transExpr isGenerated expr + + let adjustTypeAttributes attributes isNested = + let visibilityAttributes = + match attributes &&& TypeAttributes.VisibilityMask with + | TypeAttributes.Public when isNested -> TypeAttributes.NestedPublic + | TypeAttributes.NotPublic when isNested -> TypeAttributes.NestedAssembly + | TypeAttributes.NestedPublic when not isNested -> TypeAttributes.Public + | TypeAttributes.NestedAssembly + | TypeAttributes.NestedPrivate + | TypeAttributes.NestedFamORAssem + | TypeAttributes.NestedFamily + | TypeAttributes.NestedFamANDAssem when not isNested -> TypeAttributes.NotPublic + | a -> a + (attributes &&& ~~~TypeAttributes.VisibilityMask) ||| visibilityAttributes + +type ProvidedStaticParameter(parameterName:string,parameterType:Type,?parameterDefaultValue:obj) = + inherit System.Reflection.ParameterInfo() + + let customAttributesImpl = CustomAttributesImpl() + + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + + override __.RawDefaultValue = defaultArg parameterDefaultValue null + override __.Attributes = if parameterDefaultValue.IsNone then enum 0 else ParameterAttributes.Optional + override __.Position = 0 + override __.ParameterType = parameterType + override __.Name = parameterName + + override __.GetCustomAttributes(_inherit) = ignore(_inherit); notRequired "GetCustomAttributes" parameterName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" parameterName + +type ProvidedParameter(name:string,parameterType:Type,?isOut:bool,?optionalValue:obj) = + inherit System.Reflection.ParameterInfo() + let customAttributesImpl = CustomAttributesImpl() + let isOut = defaultArg isOut false + member __.IsParamArray with get() = customAttributesImpl.HasParamArray and set(v) = customAttributesImpl.HasParamArray <- v + override __.Name = name + override __.ParameterType = parameterType + override __.Attributes = (base.Attributes ||| (if isOut then ParameterAttributes.Out else enum 0) + ||| (match optionalValue with None -> enum 0 | Some _ -> ParameterAttributes.Optional ||| ParameterAttributes.HasDefault)) + override __.RawDefaultValue = defaultArg optionalValue null + member __.HasDefaultParameterValue = Option.isSome optionalValue + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + +type ProvidedConstructor(parameters : ProvidedParameter list) = + inherit ConstructorInfo() + let parameters = parameters |> List.map (fun p -> p :> ParameterInfo) + let mutable baseCall = None + + let mutable declaringType = null : System.Type + let mutable invokeCode = None : option Quotations.Expr> + let mutable isImplicitCtor = false + let mutable ctorAttributes = MethodAttributes.Public ||| MethodAttributes.RTSpecialName + let nameText () = sprintf "constructor for %s" (if declaringType=null then "" else declaringType.FullName) + let isStatic() = ctorAttributes.HasFlag(MethodAttributes.Static) + + let customAttributesImpl = CustomAttributesImpl() + member __.IsTypeInitializer + with get() = isStatic() && ctorAttributes.HasFlag(MethodAttributes.Private) + and set(v) = + let typeInitializerAttributes = MethodAttributes.Static ||| MethodAttributes.Private + ctorAttributes <- if v then ctorAttributes ||| typeInitializerAttributes else ctorAttributes &&& ~~~typeInitializerAttributes + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl + with set x = + if declaringType<>null then failwith (sprintf "ProvidedConstructor: declaringType already set on '%s'" (nameText())); + declaringType <- x + + member __.InvokeCode + with set (q:Quotations.Expr list -> Quotations.Expr) = + match invokeCode with + | None -> invokeCode <- Some q + | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for '%s'" (nameText())) + + member __.BaseConstructorCall + with set (d:Quotations.Expr list -> (ConstructorInfo * Quotations.Expr list)) = + match baseCall with + | None -> baseCall <- Some d + | Some _ -> failwith (sprintf "ProvidedConstructor: base call already given for '%s'" (nameText())) + + member __.GetInvokeCodeInternal isGenerated = + match invokeCode with + | Some f -> + // FSharp.Data change: use the real variable names instead of indices, to improve output of Debug.fs + let paramNames = + parameters + |> List.map (fun p -> p.Name) + |> List.append (if not isGenerated || isStatic() then [] else ["this"]) + |> Array.ofList + transQuotationToCode isGenerated f paramNames + | None -> failwith (sprintf "ProvidedConstructor: no invoker for '%s'" (nameText())) + + member __.GetBaseConstructorCallInternal isGenerated = + match baseCall with + | Some f -> Some(fun ctorArgs -> let c,baseCtorArgExprs = f ctorArgs in c, List.map (transExpr isGenerated) baseCtorArgExprs) + | None -> None + member __.IsImplicitCtor with get() = isImplicitCtor and set v = isImplicitCtor <- v + + // Implement overloads + override __.GetParameters() = parameters |> List.toArray + override __.Attributes = ctorAttributes + override __.Name = if isStatic() then ".cctor" else ".ctor" + override __.DeclaringType = declaringType |> nonNull "ProvidedConstructor.DeclaringType" + override __.IsDefined(_attributeType, _inherit) = true + + override __.Invoke(_invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" (nameText()) + override __.ReflectedType = notRequired "ReflectedType" (nameText()) + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" (nameText()) + override __.MethodHandle = notRequired "MethodHandle" (nameText()) + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" (nameText()) + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" (nameText()) + +type ProvidedMethod(methodName: string, parameters: ProvidedParameter list, returnType: Type) = + inherit System.Reflection.MethodInfo() + let argParams = parameters |> List.map (fun p -> p :> ParameterInfo) + + // State + let mutable declaringType : Type = null + let mutable methodAttrs = MethodAttributes.Public + let mutable invokeCode = None : option Quotations.Expr> + let mutable staticParams = [ ] + let mutable staticParamsApply = None + let isStatic() = methodAttrs.HasFlag(MethodAttributes.Static) + let customAttributesImpl = CustomAttributesImpl() + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.AddCustomAttribute(attribute) = customAttributesImpl.AddCustomAttribute(attribute) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.SetMethodAttrs m = methodAttrs <- m + member __.AddMethodAttrs m = methodAttrs <- methodAttrs ||| m + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + member __.IsStaticMethod + with get() = isStatic() + and set x = if x then methodAttrs <- methodAttrs ||| MethodAttributes.Static + else methodAttrs <- methodAttrs &&& (~~~ MethodAttributes.Static) + + member __.InvokeCode + with set (q:Quotations.Expr list -> Quotations.Expr) = + match invokeCode with + | None -> invokeCode <- Some q + | Some _ -> failwith (sprintf "ProvidedConstructor: code already given for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) + + + /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". + member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedMethod)) = + staticParams <- staticParameters + staticParamsApply <- Some apply + + /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) + member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] + + /// Instantiate parametrics type + member __.ApplyStaticArguments(mangledName:string, args:obj[]) = + if staticParams.Length>0 then + if staticParams.Length <> args.Length then + failwith (sprintf "ProvidedTypeDefinition: expecting %d static parameters but given %d for method %s" staticParams.Length args.Length methodName) + match staticParamsApply with + | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" + | Some f -> f mangledName args + else + failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for method %s" methodName) + + member __.GetInvokeCodeInternal isGenerated = + match invokeCode with + | Some f -> + // FSharp.Data change: use the real variable names instead of indices, to improve output of Debug.fs + let paramNames = + parameters + |> List.map (fun p -> p.Name) + |> List.append (if isStatic() then [] else ["this"]) + |> Array.ofList + transQuotationToCode isGenerated f paramNames + | None -> failwith (sprintf "ProvidedMethod: no invoker for %s on type %s" methodName (if declaringType=null then "" else declaringType.FullName)) + + // Implement overloads + override __.GetParameters() = argParams |> Array.ofList + override __.Attributes = methodAttrs + override __.Name = methodName + override __.DeclaringType = declaringType |> nonNull "ProvidedMethod.DeclaringType" + override __.IsDefined(_attributeType, _inherit) : bool = true + override __.MemberType = MemberTypes.Method + override __.CallingConvention = + let cc = CallingConventions.Standard + let cc = if not (isStatic()) then cc ||| CallingConventions.HasThis else cc + cc + override __.ReturnType = returnType + override __.ReturnParameter = null // REVIEW: Give it a name and type? + override __.ToString() = "Method " + methodName + + // These don't have to return fully accurate results - they are used + // by the F# Quotations library function SpecificCall as a pre-optimization + // when comparing methods + override __.MetadataToken = hash declaringType + hash methodName + override __.MethodHandle = RuntimeMethodHandle() + + override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" methodName + override __.GetBaseDefinition() = notRequired "GetBaseDefinition" methodName + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" methodName + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" methodName + override __.ReflectedType = notRequired "ReflectedType" methodName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" methodName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" methodName + + +type ProvidedProperty(propertyName: string, propertyType: Type, ?parameters: ProvidedParameter list) = + inherit System.Reflection.PropertyInfo() + // State + + let parameters = defaultArg parameters [] + let mutable declaringType = null + let mutable isStatic = false + let mutable getterCode = None : option Quotations.Expr> + let mutable setterCode = None : option Quotations.Expr> + + let hasGetter() = getterCode.IsSome + let hasSetter() = setterCode.IsSome + + // Delay construction - to pick up the latest isStatic + let markSpecialName (m:ProvidedMethod) = m.AddMethodAttrs(MethodAttributes.SpecialName); m + let getter = lazy (ProvidedMethod("get_" + propertyName,parameters,propertyType,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=getterCode.Value) |> markSpecialName) + let setter = lazy (ProvidedMethod("set_" + propertyName,parameters @ [ProvidedParameter("value",propertyType)],typeof,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=setterCode.Value) |> markSpecialName) + + let customAttributesImpl = CustomAttributesImpl() + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() + member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + member __.IsStatic + with get() = isStatic + and set x = isStatic <- x + + member __.GetterCode + with set (q:Quotations.Expr list -> Quotations.Expr) = + if not getter.IsValueCreated then getterCode <- Some q else failwith "ProvidedProperty: getter MethodInfo has already been created" + + member __.SetterCode + with set (q:Quotations.Expr list -> Quotations.Expr) = + if not (setter.IsValueCreated) then setterCode <- Some q else failwith "ProvidedProperty: setter MethodInfo has already been created" + + // Implement overloads + override __.PropertyType = propertyType + override __.SetValue(_obj, _value, _invokeAttr, _binder, _index, _culture) = notRequired "SetValue" propertyName + override __.GetAccessors _nonPublic = notRequired "nonPublic" propertyName + override __.GetGetMethod _nonPublic = if hasGetter() then getter.Force() :> MethodInfo else null + override __.GetSetMethod _nonPublic = if hasSetter() then setter.Force() :> MethodInfo else null + override __.GetIndexParameters() = [| for p in parameters -> upcast p |] + override __.Attributes = PropertyAttributes.None + override __.CanRead = hasGetter() + override __.CanWrite = hasSetter() + override __.GetValue(_obj, _invokeAttr, _binder, _index, _culture) : obj = notRequired "GetValue" propertyName + override __.Name = propertyName + override __.DeclaringType = declaringType |> nonNull "ProvidedProperty.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Property + + override __.ReflectedType = notRequired "ReflectedType" propertyName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" propertyName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" propertyName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" propertyName + +type ProvidedEvent(eventName:string,eventHandlerType:Type) = + inherit System.Reflection.EventInfo() + // State + + let mutable declaringType = null + let mutable isStatic = false + let mutable adderCode = None : option Quotations.Expr> + let mutable removerCode = None : option Quotations.Expr> + + // Delay construction - to pick up the latest isStatic + let markSpecialName (m:ProvidedMethod) = m.AddMethodAttrs(MethodAttributes.SpecialName); m + let adder = lazy (ProvidedMethod("add_" + eventName, [ProvidedParameter("handler", eventHandlerType)],typeof,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=adderCode.Value) |> markSpecialName) + let remover = lazy (ProvidedMethod("remove_" + eventName, [ProvidedParameter("handler", eventHandlerType)],typeof,IsStaticMethod=isStatic,DeclaringTypeImpl=declaringType,InvokeCode=removerCode.Value) |> markSpecialName) + + let customAttributesImpl = CustomAttributesImpl() + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + member __.IsStatic + with get() = isStatic + and set x = isStatic <- x + + member __.AdderCode + with get() = adderCode.Value + and set f = + if not adder.IsValueCreated then adderCode <- Some f else failwith "ProvidedEvent: Add MethodInfo has already been created" + + member __.RemoverCode + with get() = removerCode.Value + and set f = + if not (remover.IsValueCreated) then removerCode <- Some f else failwith "ProvidedEvent: Remove MethodInfo has already been created" + + // Implement overloads + override __.EventHandlerType = eventHandlerType + override __.GetAddMethod _nonPublic = adder.Force() :> MethodInfo + override __.GetRemoveMethod _nonPublic = remover.Force() :> MethodInfo + override __.Attributes = EventAttributes.None + override __.Name = eventName + override __.DeclaringType = declaringType |> nonNull "ProvidedEvent.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Event + + override __.GetRaiseMethod _nonPublic = notRequired "GetRaiseMethod" eventName + override __.ReflectedType = notRequired "ReflectedType" eventName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" eventName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" eventName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" eventName + +type ProvidedLiteralField(fieldName:string,fieldType:Type,literalValue:obj) = + inherit System.Reflection.FieldInfo() + // State + + let mutable declaringType = null + + let customAttributesImpl = CustomAttributesImpl() + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + + // Implement overloads + override __.FieldType = fieldType + override __.GetRawConstantValue() = literalValue + override __.Attributes = FieldAttributes.Static ||| FieldAttributes.Literal ||| FieldAttributes.Public + override __.Name = fieldName + override __.DeclaringType = declaringType |> nonNull "ProvidedLiteralField.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Field + + override __.ReflectedType = notRequired "ReflectedType" fieldName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName + + override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName + override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName + override __.FieldHandle = notRequired "FieldHandle" fieldName + +type ProvidedField(fieldName:string,fieldType:Type) = + inherit System.Reflection.FieldInfo() + // State + + let mutable declaringType = null + + let customAttributesImpl = CustomAttributesImpl() + let mutable fieldAttrs = FieldAttributes.Private + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.DeclaringTypeImpl with set x = declaringType <- x // check: not set twice + + member __.SetFieldAttributes attrs = fieldAttrs <- attrs + // Implement overloads + override __.FieldType = fieldType + override __.GetRawConstantValue() = null + override __.Attributes = fieldAttrs + override __.Name = fieldName + override __.DeclaringType = declaringType |> nonNull "ProvidedField.DeclaringType" + override __.MemberType : MemberTypes = MemberTypes.Field + + override __.ReflectedType = notRequired "ReflectedType" fieldName + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" fieldName + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" fieldName + override __.IsDefined(_attributeType, _inherit) = notRequired "IsDefined" fieldName + + override __.SetValue(_obj, _value, _invokeAttr, _binder, _culture) = notRequired "SetValue" fieldName + override __.GetValue(_obj) : obj = notRequired "GetValue" fieldName + override __.FieldHandle = notRequired "FieldHandle" fieldName + +/// Represents the type constructor in a provided symbol type. +[] +type SymbolKind = + | SDArray + | Array of int + | Pointer + | ByRef + | Generic of System.Type + | FSharpTypeAbbreviation of (System.Reflection.Assembly * string * string[]) + + +/// Represents an array or other symbolic type involving a provided type as the argument. +/// See the type provider spec for the methods that must be implemented. +/// Note that the type provider specification does not require us to implement pointer-equality for provided types. +type ProvidedSymbolType(kind: SymbolKind, args: Type list) = + inherit Type() + + let rec isEquivalentTo (thisTy: Type) (otherTy: Type) = + match thisTy, otherTy with + | (:? ProvidedSymbolType as thisTy), (:? ProvidedSymbolType as thatTy) -> (thisTy.Kind,thisTy.Args) = (thatTy.Kind, thatTy.Args) + | (:? ProvidedSymbolType as thisTy), otherTy | otherTy, (:? ProvidedSymbolType as thisTy) -> + match thisTy.Kind, thisTy.Args with + | SymbolKind.SDArray, [ty] | SymbolKind.Array _, [ty] when otherTy.IsArray-> ty.Equals(otherTy.GetElementType()) + | SymbolKind.ByRef, [ty] when otherTy.IsByRef -> ty.Equals(otherTy.GetElementType()) + | SymbolKind.Pointer, [ty] when otherTy.IsPointer -> ty.Equals(otherTy.GetElementType()) + | SymbolKind.Generic baseTy, args -> otherTy.IsGenericType && isEquivalentTo baseTy (otherTy.GetGenericTypeDefinition()) && Seq.forall2 isEquivalentTo args (otherTy.GetGenericArguments()) + | _ -> false + | a, b -> a.Equals b + + let nameText() = + match kind,args with + | SymbolKind.SDArray,[arg] -> arg.Name + "[]" + | SymbolKind.Array _,[arg] -> arg.Name + "[*]" + | SymbolKind.Pointer,[arg] -> arg.Name + "*" + | SymbolKind.ByRef,[arg] -> arg.Name + "&" + | SymbolKind.Generic gty, args -> gty.Name + (sprintf "%A" args) + | SymbolKind.FSharpTypeAbbreviation (_,_,path),_ -> path.[path.Length-1] + | _ -> failwith "unreachable" + + static member convType (parameters: Type list) (ty:Type) = + if ty = null then null + elif ty.IsGenericType then + let args = Array.map (ProvidedSymbolType.convType parameters) (ty.GetGenericArguments()) + ProvidedSymbolType(Generic (ty.GetGenericTypeDefinition()), Array.toList args) :> Type + elif ty.HasElementType then + let ety = ProvidedSymbolType.convType parameters (ty.GetElementType()) + if ty.IsArray then + let rank = ty.GetArrayRank() + if rank = 1 then ProvidedSymbolType(SDArray,[ety]) :> Type + else ProvidedSymbolType(Array rank,[ety]) :> Type + elif ty.IsPointer then ProvidedSymbolType(Pointer,[ety]) :> Type + elif ty.IsByRef then ProvidedSymbolType(ByRef,[ety]) :> Type + else ty + elif ty.IsGenericParameter then + if ty.GenericParameterPosition <= parameters.Length - 1 then + parameters.[ty.GenericParameterPosition] + else + ty + else ty + + override __.FullName = + match kind,args with + | SymbolKind.SDArray,[arg] -> arg.FullName + "[]" + | SymbolKind.Array _,[arg] -> arg.FullName + "[*]" + | SymbolKind.Pointer,[arg] -> arg.FullName + "*" + | SymbolKind.ByRef,[arg] -> arg.FullName + "&" + | SymbolKind.Generic gty, args -> gty.FullName + "[" + (args |> List.map (fun arg -> arg.ToString()) |> String.concat ",") + "]" + | SymbolKind.FSharpTypeAbbreviation (_,nsp,path),args -> String.concat "." (Array.append [| nsp |] path) + args.ToString() + | _ -> failwith "unreachable" + + /// Although not strictly required by the type provider specification, this is required when doing basic operations like FullName on + /// .NET symbolic types made from this type, e.g. when building Nullable.FullName + override __.DeclaringType = + match kind,args with + | SymbolKind.SDArray,[arg] -> arg + | SymbolKind.Array _,[arg] -> arg + | SymbolKind.Pointer,[arg] -> arg + | SymbolKind.ByRef,[arg] -> arg + | SymbolKind.Generic gty,_ -> gty + | SymbolKind.FSharpTypeAbbreviation _,_ -> null + | _ -> failwith "unreachable" + + override __.IsAssignableFrom(otherTy) = + match kind with + | Generic gtd -> + if otherTy.IsGenericType then + let otherGtd = otherTy.GetGenericTypeDefinition() + let otherArgs = otherTy.GetGenericArguments() + let yes = gtd.Equals(otherGtd) && Seq.forall2 isEquivalentTo args otherArgs + yes + else + base.IsAssignableFrom(otherTy) + | _ -> base.IsAssignableFrom(otherTy) + + override __.Name = nameText() + + override __.BaseType = + match kind with + | SymbolKind.SDArray -> typeof + | SymbolKind.Array _ -> typeof + | SymbolKind.Pointer -> typeof + | SymbolKind.ByRef -> typeof + | SymbolKind.Generic gty -> + if gty.BaseType = null then null else + ProvidedSymbolType.convType args gty.BaseType + | SymbolKind.FSharpTypeAbbreviation _ -> typeof + + override __.GetArrayRank() = (match kind with SymbolKind.Array n -> n | SymbolKind.SDArray -> 1 | _ -> invalidOp "non-array type") + override __.IsArrayImpl() = (match kind with SymbolKind.Array _ | SymbolKind.SDArray -> true | _ -> false) + override __.IsByRefImpl() = (match kind with SymbolKind.ByRef _ -> true | _ -> false) + override __.IsPointerImpl() = (match kind with SymbolKind.Pointer _ -> true | _ -> false) + override __.IsPrimitiveImpl() = false + override __.IsGenericType = (match kind with SymbolKind.Generic _ -> true | _ -> false) + override __.GetGenericArguments() = (match kind with SymbolKind.Generic _ -> args |> List.toArray | _ -> invalidOp "non-generic type") + override __.GetGenericTypeDefinition() = (match kind with SymbolKind.Generic e -> e | _ -> invalidOp "non-generic type") + override __.IsCOMObjectImpl() = false + override __.HasElementTypeImpl() = (match kind with SymbolKind.Generic _ -> false | _ -> true) + override __.GetElementType() = (match kind,args with (SymbolKind.Array _ | SymbolKind.SDArray | SymbolKind.ByRef | SymbolKind.Pointer),[e] -> e | _ -> invalidOp "not an array, pointer or byref type") + override this.ToString() = this.FullName + + override __.Assembly = + match kind with + | SymbolKind.FSharpTypeAbbreviation (assembly,_nsp,_path) -> assembly + | SymbolKind.Generic gty -> gty.Assembly + | _ -> notRequired "Assembly" (nameText()) + + override __.Namespace = + match kind with + | SymbolKind.FSharpTypeAbbreviation (_assembly,nsp,_path) -> nsp + | _ -> notRequired "Namespace" (nameText()) + + override __.GetHashCode() = + match kind,args with + | SymbolKind.SDArray,[arg] -> 10 + hash arg + | SymbolKind.Array _,[arg] -> 163 + hash arg + | SymbolKind.Pointer,[arg] -> 283 + hash arg + | SymbolKind.ByRef,[arg] -> 43904 + hash arg + | SymbolKind.Generic gty,_ -> 9797 + hash gty + List.sumBy hash args + | SymbolKind.FSharpTypeAbbreviation _,_ -> 3092 + | _ -> failwith "unreachable" + + override __.Equals(other: obj) = + match other with + | :? ProvidedSymbolType as otherTy -> (kind, args) = (otherTy.Kind, otherTy.Args) + | _ -> false + + member __.Kind = kind + member __.Args = args + + override __.Module : Module = notRequired "Module" (nameText()) + override __.GetConstructors _bindingAttr = notRequired "GetConstructors" (nameText()) + override __.GetMethodImpl(_name, _bindingAttr, _binderBinder, _callConvention, _types, _modifiers) = + match kind with + | Generic gtd -> + let ty = gtd.GetGenericTypeDefinition().MakeGenericType(Array.ofList args) + ty.GetMethod(_name, _bindingAttr) + | _ -> notRequired "GetMethodImpl" (nameText()) + override __.GetMembers _bindingAttr = notRequired "GetMembers" (nameText()) + override __.GetMethods _bindingAttr = notRequired "GetMethods" (nameText()) + override __.GetField(_name, _bindingAttr) = notRequired "GetField" (nameText()) + override __.GetFields _bindingAttr = notRequired "GetFields" (nameText()) + override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" (nameText()) + override __.GetInterfaces() = notRequired "GetInterfaces" (nameText()) + override __.GetEvent(_name, _bindingAttr) = notRequired "GetEvent" (nameText()) + override __.GetEvents _bindingAttr = notRequired "GetEvents" (nameText()) + override __.GetProperties _bindingAttr = notRequired "GetProperties" (nameText()) + override __.GetPropertyImpl(_name, _bindingAttr, _binder, _returnType, _types, _modifiers) = notRequired "GetPropertyImpl" (nameText()) + override __.GetNestedTypes _bindingAttr = notRequired "GetNestedTypes" (nameText()) + override __.GetNestedType(_name, _bindingAttr) = notRequired "GetNestedType" (nameText()) + override __.GetAttributeFlagsImpl() = notRequired "GetAttributeFlagsImpl" (nameText()) + override this.UnderlyingSystemType = + match kind with + | SymbolKind.SDArray + | SymbolKind.Array _ + | SymbolKind.Pointer + | SymbolKind.FSharpTypeAbbreviation _ + | SymbolKind.ByRef -> upcast this + | SymbolKind.Generic gty -> gty.UnderlyingSystemType +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = ([| |] :> IList<_>) +#endif + override __.MemberType = notRequired "MemberType" (nameText()) + override __.GetMember(_name,_mt,_bindingAttr) = notRequired "GetMember" (nameText()) + override __.GUID = notRequired "GUID" (nameText()) + override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "InvokeMember" (nameText()) + override __.AssemblyQualifiedName = notRequired "AssemblyQualifiedName" (nameText()) + override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = notRequired "GetConstructorImpl" (nameText()) + override __.GetCustomAttributes(_inherit) = [| |] + override __.GetCustomAttributes(_attributeType, _inherit) = [| |] + override __.IsDefined(_attributeType, _inherit) = false + // FSharp.Data addition: this was added to support arrays of arrays + override this.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type + override this.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type + +type ProvidedSymbolMethod(genericMethodDefinition: MethodInfo, parameters: Type list) = + inherit System.Reflection.MethodInfo() + + let convParam (p:ParameterInfo) = + { new System.Reflection.ParameterInfo() with + override __.Name = p.Name + override __.ParameterType = ProvidedSymbolType.convType parameters p.ParameterType + override __.Attributes = p.Attributes + override __.RawDefaultValue = p.RawDefaultValue +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = p.GetCustomAttributesData() +#endif + } + + override this.IsGenericMethod = + (if this.DeclaringType.IsGenericType then this.DeclaringType.GetGenericArguments().Length else 0) < parameters.Length + + override this.GetGenericArguments() = + Seq.skip (if this.DeclaringType.IsGenericType then this.DeclaringType.GetGenericArguments().Length else 0) parameters |> Seq.toArray + + override __.GetGenericMethodDefinition() = genericMethodDefinition + + override __.DeclaringType = ProvidedSymbolType.convType parameters genericMethodDefinition.DeclaringType + override __.ToString() = "Method " + genericMethodDefinition.Name + override __.Name = genericMethodDefinition.Name + override __.MetadataToken = genericMethodDefinition.MetadataToken + override __.Attributes = genericMethodDefinition.Attributes + override __.CallingConvention = genericMethodDefinition.CallingConvention + override __.MemberType = genericMethodDefinition.MemberType + + override __.IsDefined(_attributeType, _inherit) : bool = notRequired "IsDefined" genericMethodDefinition.Name + override __.ReturnType = ProvidedSymbolType.convType parameters genericMethodDefinition.ReturnType + override __.GetParameters() = genericMethodDefinition.GetParameters() |> Array.map convParam + override __.ReturnParameter = genericMethodDefinition.ReturnParameter |> convParam + override __.ReturnTypeCustomAttributes = notRequired "ReturnTypeCustomAttributes" genericMethodDefinition.Name + override __.GetBaseDefinition() = notRequired "GetBaseDefinition" genericMethodDefinition.Name + override __.GetMethodImplementationFlags() = notRequired "GetMethodImplementationFlags" genericMethodDefinition.Name + override __.MethodHandle = notRequired "MethodHandle" genericMethodDefinition.Name + override __.Invoke(_obj, _invokeAttr, _binder, _parameters, _culture) = notRequired "Invoke" genericMethodDefinition.Name + override __.ReflectedType = notRequired "ReflectedType" genericMethodDefinition.Name + override __.GetCustomAttributes(_inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name + override __.GetCustomAttributes(_attributeType, _inherit) = notRequired "GetCustomAttributes" genericMethodDefinition.Name + + + +type ProvidedTypeBuilder() = + static member MakeGenericType(genericTypeDefinition, genericArguments) = ProvidedSymbolType(Generic genericTypeDefinition, genericArguments) :> Type + static member MakeGenericMethod(genericMethodDefinition, genericArguments) = ProvidedSymbolMethod(genericMethodDefinition, genericArguments) :> MethodInfo + +[] +type ProvidedMeasureBuilder() = + + // TODO: this shouldn't be hardcoded, but without creating a dependency on FSharp.Compiler.Service + // there seems to be no way to check if a type abbreviation exists + let unitNamesTypeAbbreviations = + [ "meter"; "hertz"; "newton"; "pascal"; "joule"; "watt"; "coulomb"; + "volt"; "farad"; "ohm"; "siemens"; "weber"; "tesla"; "henry" + "lumen"; "lux"; "becquerel"; "gray"; "sievert"; "katal" ] + |> Set.ofList + + let unitSymbolsTypeAbbreviations = + [ "m"; "kg"; "s"; "A"; "K"; "mol"; "cd"; "Hz"; "N"; "Pa"; "J"; "W"; "C" + "V"; "F"; "S"; "Wb"; "T"; "lm"; "lx"; "Bq"; "Gy"; "Sv"; "kat"; "H" ] + |> Set.ofList + + static let theBuilder = ProvidedMeasureBuilder() + static member Default = theBuilder + member __.One = typeof + member __.Product (m1,m2) = typedefof>.MakeGenericType [| m1;m2 |] + member __.Inverse m = typedefof>.MakeGenericType [| m |] + member b.Ratio (m1, m2) = b.Product(m1, b.Inverse m2) + member b.Square m = b.Product(m, m) + + // FSharp.Data change: if the unit is not a valid type, instead + // of assuming it's a type abbreviation, which may not be the case and cause a + // problem later on, check the list of valid abbreviations + member __.SI (m:string) = + let mLowerCase = m.ToLowerInvariant() + let abbreviation = + if unitNamesTypeAbbreviations.Contains mLowerCase then + Some ("Microsoft.FSharp.Data.UnitSystems.SI.UnitNames", mLowerCase) + elif unitSymbolsTypeAbbreviations.Contains m then + Some ("Microsoft.FSharp.Data.UnitSystems.SI.UnitSymbols", m) + else + None + match abbreviation with + | Some (ns, unitName) -> + ProvidedSymbolType + (SymbolKind.FSharpTypeAbbreviation + (typeof.Assembly, + ns, + [| unitName |]), + []) :> Type + | None -> + typedefof>.Assembly.GetType("Microsoft.FSharp.Data.UnitSystems.SI.UnitNames." + mLowerCase) + + member __.AnnotateType (basicType, annotation) = ProvidedSymbolType(Generic basicType, annotation) :> Type + + + +[] +type TypeContainer = + | Namespace of Assembly * string // namespace + | Type of System.Type + | TypeToBeDecided + +module GlobalProvidedAssemblyElementsTable = + let theTable = Dictionary>() + +type ProvidedTypeDefinition(container:TypeContainer,className : string, baseType : Type option) as this = + inherit Type() + + do match container, !ProvidedTypeDefinition.Logger with + | TypeContainer.Namespace _, Some logger -> logger (sprintf "Creating ProvidedTypeDefinition %s [%d]" className (System.Runtime.CompilerServices.RuntimeHelpers.GetHashCode this)) + | _ -> () + + // state + let mutable attributes = + TypeAttributes.Public ||| + TypeAttributes.Class ||| + TypeAttributes.Sealed ||| + enum (int32 TypeProviderTypeAttributes.IsErased) + + + let mutable enumUnderlyingType = typeof + let mutable baseType = lazy baseType + let mutable membersKnown = ResizeArray() + let mutable membersQueue = ResizeArray<(unit -> list)>() + let mutable staticParams = [ ] + let mutable staticParamsApply = None + let mutable container = container + let mutable interfaceImpls = ResizeArray() + let mutable interfaceImplsDelayed = ResizeArray list>() + let mutable methodOverrides = ResizeArray() + + // members API + let getMembers() = + if membersQueue.Count > 0 then + let elems = membersQueue |> Seq.toArray // take a copy in case more elements get added + membersQueue.Clear() + for f in elems do + for i in f() do + membersKnown.Add i + match i with + | :? ProvidedProperty as p -> + if p.CanRead then membersKnown.Add (p.GetGetMethod true) + if p.CanWrite then membersKnown.Add (p.GetSetMethod true) + | :? ProvidedEvent as e -> + membersKnown.Add (e.GetAddMethod true) + membersKnown.Add (e.GetRemoveMethod true) + | _ -> () + + membersKnown.ToArray() + + // members API + let getInterfaces() = + if interfaceImplsDelayed.Count > 0 then + let elems = interfaceImplsDelayed |> Seq.toArray // take a copy in case more elements get added + interfaceImplsDelayed.Clear() + for f in elems do + for i in f() do + interfaceImpls.Add i + + interfaceImpls.ToArray() + + let mutable theAssembly = + lazy + match container with + | TypeContainer.Namespace (theAssembly, rootNamespace) -> + if theAssembly = null then failwith "Null assemblies not allowed" + if rootNamespace<>null && rootNamespace.Length=0 then failwith "Use 'null' for global namespace" + theAssembly + | TypeContainer.Type superTy -> superTy.Assembly + | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" className) + + let rootNamespace = + lazy + match container with + | TypeContainer.Namespace (_,rootNamespace) -> rootNamespace + | TypeContainer.Type enclosingTyp -> enclosingTyp.Namespace + | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" className) + + let declaringType = + lazy + match container with + | TypeContainer.Namespace _ -> null + | TypeContainer.Type enclosingTyp -> enclosingTyp + | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" className) + + let fullName = + lazy + match container with + | TypeContainer.Type declaringType -> declaringType.FullName + "+" + className + | TypeContainer.Namespace (_,namespaceName) -> + if namespaceName="" then failwith "use null for global namespace" + match namespaceName with + | null -> className + | _ -> namespaceName + "." + className + | TypeContainer.TypeToBeDecided -> failwith (sprintf "type '%s' was not added as a member to a declaring type" className) + + let patchUpAddedMemberInfo (this:Type) (m:MemberInfo) = + match m with + | :? ProvidedConstructor as c -> c.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo + | :? ProvidedMethod as m -> m.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo + | :? ProvidedProperty as p -> p.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo + | :? ProvidedEvent as e -> e.DeclaringTypeImpl <- this // patch up "declaring type" on provided MethodInfo + | :? ProvidedTypeDefinition as t -> t.DeclaringTypeImpl <- this + | :? ProvidedLiteralField as l -> l.DeclaringTypeImpl <- this + | :? ProvidedField as l -> l.DeclaringTypeImpl <- this + | _ -> () + + let customAttributesImpl = CustomAttributesImpl() + + member __.AddXmlDocComputed xmlDocFunction = customAttributesImpl.AddXmlDocComputed xmlDocFunction + member __.AddXmlDocDelayed xmlDocFunction = customAttributesImpl.AddXmlDocDelayed xmlDocFunction + member __.AddXmlDoc xmlDoc = customAttributesImpl.AddXmlDoc xmlDoc + member __.AddObsoleteAttribute (message,?isError) = customAttributesImpl.AddObsolete (message,defaultArg isError false) + member __.AddDefinitionLocation(line,column,filePath) = customAttributesImpl.AddDefinitionLocation(line, column, filePath) + member __.HideObjectMethods with set v = customAttributesImpl.HideObjectMethods <- v + member __.NonNullable with set v = customAttributesImpl.NonNullable <- v + member __.GetCustomAttributesDataImpl() = customAttributesImpl.GetCustomAttributesData() + member __.AddCustomAttribute attribute = customAttributesImpl.AddCustomAttribute attribute +#if FX_NO_CUSTOMATTRIBUTEDATA +#else + override __.GetCustomAttributesData() = customAttributesImpl.GetCustomAttributesData() +#endif + + member __.ResetEnclosingType (ty) = + container <- TypeContainer.Type ty + new (assembly:Assembly,namespaceName,className,baseType) = new ProvidedTypeDefinition(TypeContainer.Namespace (assembly,namespaceName), className, baseType) + new (className,baseType) = new ProvidedTypeDefinition(TypeContainer.TypeToBeDecided, className, baseType) + // state ops + + override __.UnderlyingSystemType = typeof + + member __.SetEnumUnderlyingType(ty) = enumUnderlyingType <- ty + + override __.GetEnumUnderlyingType() = if this.IsEnum then enumUnderlyingType else invalidOp "not enum type" + + member __.SetBaseType t = baseType <- lazy Some t + + member __.SetBaseTypeDelayed baseTypeFunction = baseType <- lazy (Some (baseTypeFunction())) + + member __.SetAttributes x = attributes <- x + + // Add MemberInfos + member __.AddMembersDelayed(membersFunction : unit -> list<#MemberInfo>) = + membersQueue.Add (fun () -> membersFunction() |> List.map (fun x -> patchUpAddedMemberInfo this x; x :> MemberInfo )) + + member __.AddMembers(memberInfos:list<#MemberInfo>) = (* strict *) + memberInfos |> List.iter (patchUpAddedMemberInfo this) // strict: patch up now + membersQueue.Add (fun () -> memberInfos |> List.map (fun x -> x :> MemberInfo)) + + member __.AddMember(memberInfo:MemberInfo) = + this.AddMembers [memberInfo] + + member __.AddMemberDelayed(memberFunction : unit -> #MemberInfo) = + this.AddMembersDelayed(fun () -> [memberFunction()]) + + member __.AddAssemblyTypesAsNestedTypesDelayed (assemblyf : unit -> System.Reflection.Assembly) = + let bucketByPath nodef tipf (items: (string list * 'Value) list) = + // Find all the items with an empty key list and call 'tipf' + let tips = + [ for (keylist,v) in items do + match keylist with + | [] -> yield tipf v + | _ -> () ] + + // Find all the items with a non-empty key list. Bucket them together by + // the first key. For each bucket, call 'nodef' on that head key and the bucket. + let nodes = + let buckets = new Dictionary<_,_>(10) + for (keylist,v) in items do + match keylist with + | [] -> () + | key::rest -> + buckets.[key] <- (rest,v) :: (if buckets.ContainsKey key then buckets.[key] else []); + + [ for (KeyValue(key,items)) in buckets -> nodef key items ] + + tips @ nodes + this.AddMembersDelayed (fun _ -> + let topTypes = [ for ty in assemblyf().GetTypes() do + if not ty.IsNested then + let namespaceParts = match ty.Namespace with null -> [] | s -> s.Split '.' |> Array.toList + yield namespaceParts, ty ] + let rec loop types = + types + |> bucketByPath + (fun namespaceComponent typesUnderNamespaceComponent -> + let t = ProvidedTypeDefinition(namespaceComponent, baseType = Some typeof) + t.AddMembers (loop typesUnderNamespaceComponent) + (t :> Type)) + (fun ty -> ty) + loop topTypes) + + /// Abstract a type to a parametric-type. Requires "formal parameters" and "instantiation function". + member __.DefineStaticParameters(staticParameters : list, apply : (string -> obj[] -> ProvidedTypeDefinition)) = + staticParams <- staticParameters + staticParamsApply <- Some apply + + /// Get ParameterInfo[] for the parametric type parameters (//s GetGenericParameters) + member __.GetStaticParameters() = [| for p in staticParams -> p :> ParameterInfo |] + + /// Instantiate parametrics type + member __.MakeParametricType(name:string,args:obj[]) = + if staticParams.Length>0 then + if staticParams.Length <> args.Length then + failwith (sprintf "ProvidedTypeDefinition: expecting %d static parameters but given %d for type %s" staticParams.Length args.Length (fullName.Force())) + match staticParamsApply with + | None -> failwith "ProvidedTypeDefinition: DefineStaticParameters was not called" + | Some f -> f name args + + else + failwith (sprintf "ProvidedTypeDefinition: static parameters supplied but not expected for %s" (fullName.Force())) + + member __.DeclaringTypeImpl + with set x = + match container with TypeContainer.TypeToBeDecided -> () | _ -> failwith (sprintf "container type for '%s' was already set to '%s'" this.FullName x.FullName); + container <- TypeContainer.Type x + + // Implement overloads + override __.Assembly = theAssembly.Force() + + member __.SetAssembly assembly = theAssembly <- lazy assembly + + member __.SetAssemblyLazy assembly = theAssembly <- assembly + + override __.FullName = fullName.Force() + + override __.Namespace = rootNamespace.Force() + + override __.BaseType = match baseType.Value with Some ty -> ty | None -> null + + // Constructors + override __.GetConstructors bindingAttr = + [| for m in this.GetMembers bindingAttr do + if m.MemberType = MemberTypes.Constructor then + yield (m :?> ConstructorInfo) |] + // Methods + override __.GetMethodImpl(name, bindingAttr, _binderBinder, _callConvention, _types, _modifiers) : MethodInfo = + let membersWithName = + [ for m in this.GetMembers(bindingAttr) do + if m.MemberType.HasFlag(MemberTypes.Method) && m.Name = name then + yield m ] + match membersWithName with + | [] -> null + | [meth] -> meth :?> MethodInfo + | _several -> failwith "GetMethodImpl. not support overloads" + + override __.GetMethods bindingAttr = + this.GetMembers bindingAttr + |> Array.filter (fun m -> m.MemberType.HasFlag(MemberTypes.Method)) + |> Array.map (fun m -> m :?> MethodInfo) + + // Fields + override __.GetField(name, bindingAttr) = + let fields = [| for m in this.GetMembers bindingAttr do + if m.MemberType.HasFlag(MemberTypes.Field) && (name = null || m.Name = name) then // REVIEW: name = null. Is that a valid query?! + yield m |] + if fields.Length > 0 then fields.[0] :?> FieldInfo else null + + override __.GetFields bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Field) then yield m :?> FieldInfo |] + + override __.GetInterface(_name, _ignoreCase) = notRequired "GetInterface" this.Name + + override __.GetInterfaces() = + [| yield! getInterfaces() |] + + member __.GetInterfaceImplementations() = + [| yield! getInterfaces() |] + + member __.AddInterfaceImplementation ityp = interfaceImpls.Add ityp + + member __.AddInterfaceImplementationsDelayed itypf = interfaceImplsDelayed.Add itypf + + member __.GetMethodOverrides() = + [| yield! methodOverrides |] + + member __.DefineMethodOverride (bodyMethInfo,declMethInfo) = methodOverrides.Add (bodyMethInfo, declMethInfo) + + // Events + override __.GetEvent(name, bindingAttr) = + let events = this.GetMembers bindingAttr + |> Array.filter(fun m -> m.MemberType.HasFlag(MemberTypes.Event) && (name = null || m.Name = name)) + if events.Length > 0 then events.[0] :?> EventInfo else null + + override __.GetEvents bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Event) then yield downcast m |] + + // Properties + override __.GetProperties bindingAttr = + [| for m in this.GetMembers bindingAttr do if m.MemberType.HasFlag(MemberTypes.Property) then yield downcast m |] + + override __.GetPropertyImpl(name, bindingAttr, binder, returnType, types, modifiers) = + if returnType <> null then failwith "Need to handle specified return type in GetPropertyImpl" + if types <> null then failwith "Need to handle specified parameter types in GetPropertyImpl" + if modifiers <> null then failwith "Need to handle specified modifiers in GetPropertyImpl" + if binder <> null then failwith "Need to handle binder in GetPropertyImpl" + let props = this.GetMembers bindingAttr |> Array.filter(fun m -> m.MemberType.HasFlag(MemberTypes.Property) && (name = null || m.Name = name)) // Review: nam = null, valid query!? + if props.Length > 0 then + props.[0] :?> PropertyInfo + else + null + // Nested Types + override __.MakeArrayType() = ProvidedSymbolType(SymbolKind.SDArray, [this]) :> Type + override __.MakeArrayType arg = ProvidedSymbolType(SymbolKind.Array arg, [this]) :> Type + override __.MakePointerType() = ProvidedSymbolType(SymbolKind.Pointer, [this]) :> Type + override __.MakeByRefType() = ProvidedSymbolType(SymbolKind.ByRef, [this]) :> Type + + // FSharp.Data addition: this method is used by Debug.fs and QuotationBuilder.fs + // Emulate the F# type provider type erasure mechanism to get the + // actual (erased) type. We erase ProvidedTypes to their base type + // and we erase array of provided type to array of base type. In the + // case of generics all the generic type arguments are also recursively + // replaced with the erased-to types + static member EraseType(t:Type) = + match t with + | :? ProvidedTypeDefinition -> ProvidedTypeDefinition.EraseType t.BaseType + | :? ProvidedSymbolType as sym -> + match sym.Kind, sym.Args with + | SymbolKind.SDArray, [typ] -> + let (t:Type) = ProvidedTypeDefinition.EraseType typ + t.MakeArrayType() + | SymbolKind.Generic genericTypeDefinition, _ when not genericTypeDefinition.IsGenericTypeDefinition -> + // Unit of measure parameters can match here, but not really generic types. + genericTypeDefinition.UnderlyingSystemType + | SymbolKind.Generic genericTypeDefinition, typeArgs -> + let genericArguments = + typeArgs + |> List.toArray + |> Array.map ProvidedTypeDefinition.EraseType + genericTypeDefinition.MakeGenericType(genericArguments) + | _ -> failwith "getTypeErasedTo: Unsupported ProvidedSymbolType" + | t when t.IsGenericType && not t.IsGenericTypeDefinition -> + let genericTypeDefinition = t.GetGenericTypeDefinition() + let genericArguments = + t.GetGenericArguments() + |> Array.map ProvidedTypeDefinition.EraseType + genericTypeDefinition.MakeGenericType(genericArguments) + | t -> t + + static member Logger : (string -> unit) option ref = ref None + + // The binding attributes are always set to DeclaredOnly ||| Static ||| Instance ||| Public when GetMembers is called directly by the F# compiler + // However, it's possible for the framework to generate other sets of flags in some corner cases (e.g. via use of `enum` with a provided type as the target) + override __.GetMembers bindingAttr = + let mems = + getMembers() + |> Array.filter (fun mem -> + let isStatic, isPublic = + match mem with + | :? FieldInfo as f -> f.IsStatic, f.IsPublic + | :? MethodInfo as m -> m.IsStatic, m.IsPublic + | :? ConstructorInfo as c -> c.IsStatic, c.IsPublic + | :? PropertyInfo as p -> + let m = if p.CanRead then p.GetGetMethod() else p.GetSetMethod() + m.IsStatic, m.IsPublic + | :? EventInfo as e -> + let m = e.GetAddMethod() + m.IsStatic, m.IsPublic + | :? Type as ty -> + true, ty.IsNestedPublic + | _ -> failwith (sprintf "Member %O is of unexpected type" mem) + bindingAttr.HasFlag(if isStatic then BindingFlags.Static else BindingFlags.Instance) && + ( + (bindingAttr.HasFlag(BindingFlags.Public) && isPublic) || (bindingAttr.HasFlag(BindingFlags.NonPublic) && not isPublic) + )) + + if bindingAttr.HasFlag(BindingFlags.DeclaredOnly) || this.BaseType = null then mems + else + // FSharp.Data change: just using this.BaseType is not enough in the case of CsvProvider, + // because the base type is CsvRow, so we have to erase recursively to CsvRow + let baseMems = (ProvidedTypeDefinition.EraseType this.BaseType).GetMembers bindingAttr + Array.append mems baseMems + + override __.GetNestedTypes bindingAttr = + this.GetMembers bindingAttr + |> Array.filter(fun m -> + m.MemberType.HasFlag(MemberTypes.NestedType) || + // Allow 'fake' nested types that are actually real .NET types + m.MemberType.HasFlag(MemberTypes.TypeInfo)) |> Array.map(fun m -> m :?> Type) + + override __.GetMember(name,mt,_bindingAttr) = + let mt = + if mt &&& MemberTypes.NestedType = MemberTypes.NestedType then + mt ||| MemberTypes.TypeInfo + else + mt + getMembers() |> Array.filter(fun m->0<>(int(m.MemberType &&& mt)) && m.Name = name) + + override __.GetNestedType(name, bindingAttr) = + let nt = this.GetMember(name, MemberTypes.NestedType ||| MemberTypes.TypeInfo, bindingAttr) + match nt.Length with + | 0 -> null + | 1 -> downcast nt.[0] + | _ -> failwith (sprintf "There is more than one nested type called '%s' in type '%s'" name this.FullName) + + // Attributes, etc.. + override __.GetAttributeFlagsImpl() = adjustTypeAttributes attributes this.IsNested + override __.IsArrayImpl() = false + override __.IsByRefImpl() = false + override __.IsPointerImpl() = false + override __.IsPrimitiveImpl() = false + override __.IsCOMObjectImpl() = false + override __.HasElementTypeImpl() = false + override __.Name = className + override __.DeclaringType = declaringType.Force() + override __.MemberType = if this.IsNested then MemberTypes.NestedType else MemberTypes.TypeInfo + override __.GetHashCode() = rootNamespace.GetHashCode() ^^^ className.GetHashCode() + override __.Equals(that:obj) = + match that with + | null -> false + | :? ProvidedTypeDefinition as ti -> System.Object.ReferenceEquals(this,ti) + | _ -> false + + override __.GetGenericArguments() = [||] + override __.ToString() = this.Name + + + override __.Module : Module = notRequired "Module" this.Name + override __.GUID = Guid.Empty + override __.GetConstructorImpl(_bindingAttr, _binder, _callConvention, _types, _modifiers) = null + override __.GetCustomAttributes(_inherit) = [| |] + override __.GetCustomAttributes(_attributeType, _inherit) = [| |] + override __.IsDefined(_attributeType: Type, _inherit) = false + + override __.GetElementType() = notRequired "Module" this.Name + override __.InvokeMember(_name, _invokeAttr, _binder, _target, _args, _modifiers, _culture, _namedParameters) = notRequired "Module" this.Name + override __.AssemblyQualifiedName = notRequired "Module" this.Name + member __.IsErased + with get() = (attributes &&& enum (int32 TypeProviderTypeAttributes.IsErased)) <> enum 0 + and set v = + if v then attributes <- attributes ||| enum (int32 TypeProviderTypeAttributes.IsErased) + else attributes <- attributes &&& ~~~(enum (int32 TypeProviderTypeAttributes.IsErased)) + + member __.SuppressRelocation + with get() = (attributes &&& enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) <> enum 0 + and set v = + if v then attributes <- attributes ||| enum (int32 TypeProviderTypeAttributes.SuppressRelocate) + else attributes <- attributes &&& ~~~(enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) + +type AssemblyGenerator(assemblyFileName) = + let assemblyShortName = Path.GetFileNameWithoutExtension assemblyFileName + let assemblyName = AssemblyName assemblyShortName +#if FX_NO_LOCAL_FILESYSTEM + let assembly = + System.AppDomain.CurrentDomain.DefineDynamicAssembly(name=assemblyName,access=AssemblyBuilderAccess.Run) + let assemblyMainModule = + assembly.DefineDynamicModule("MainModule") +#else + let assembly = + System.AppDomain.CurrentDomain.DefineDynamicAssembly(name=assemblyName,access=(AssemblyBuilderAccess.Save ||| AssemblyBuilderAccess.Run),dir=Path.GetDirectoryName assemblyFileName) + let assemblyMainModule = + assembly.DefineDynamicModule("MainModule", Path.GetFileName assemblyFileName) +#endif + let typeMap = Dictionary(HashIdentity.Reference) + let typeMapExtra = Dictionary(HashIdentity.Structural) + let uniqueLambdaTypeName() = + // lambda name should be unique across all types that all type provider might contribute in result assembly + sprintf "Lambda%O" (Guid.NewGuid()) + + member __.Assembly = assembly :> Assembly + + /// Emit the given provided type definitions into an assembly and adjust 'Assembly' property of all type definitions to return that + /// assembly. + member __.Generate(providedTypeDefinitions:(ProvidedTypeDefinition * string list option) list) = + let ALL = BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static ||| BindingFlags.Instance + // phase 1 - set assembly fields and emit type definitions + begin + let rec typeMembers (tb:TypeBuilder) (td : ProvidedTypeDefinition) = + for ntd in td.GetNestedTypes(ALL) do + nestedType tb ntd + + and nestedType (tb:TypeBuilder) (ntd : Type) = + match ntd with + | :? ProvidedTypeDefinition as pntd -> + if pntd.IsErased then invalidOp ("The nested provided type "+pntd.Name+"is marked as erased and cannot be converted to a generated type. Set 'IsErased' to false on the ProvidedTypeDefinition") + // Adjust the attributes - we're codegen'ing this type as nested + let attributes = adjustTypeAttributes ntd.Attributes true + let ntb = tb.DefineNestedType(pntd.Name,attr=attributes) + pntd.SetAssembly null + typeMap.[pntd] <- ntb + typeMembers ntb pntd + | _ -> () + + for (pt,enclosingGeneratedTypeNames) in providedTypeDefinitions do + match enclosingGeneratedTypeNames with + | None -> + // Filter out the additional TypeProviderTypeAttributes flags + let attributes = pt.Attributes &&& ~~~(enum (int32 TypeProviderTypeAttributes.SuppressRelocate)) + &&& ~~~(enum (int32 TypeProviderTypeAttributes.IsErased)) + // Adjust the attributes - we're codegen'ing as non-nested + let attributes = adjustTypeAttributes attributes false + let tb = assemblyMainModule.DefineType(name=pt.FullName,attr=attributes) + pt.SetAssembly null + typeMap.[pt] <- tb + typeMembers tb pt + | Some ns -> + let otb,_ = + ((None,""),ns) ||> List.fold (fun (otb:TypeBuilder option,fullName) n -> + let fullName = if fullName = "" then n else fullName + "." + n + let priorType = if typeMapExtra.ContainsKey(fullName) then Some typeMapExtra.[fullName] else None + let tb = + match priorType with + | Some tbb -> tbb + | None -> + // OK, the implied nested type is not defined, define it now + let attributes = + TypeAttributes.Public ||| + TypeAttributes.Class ||| + TypeAttributes.Sealed + // Filter out the additional TypeProviderTypeAttributes flags + let attributes = adjustTypeAttributes attributes otb.IsSome + let tb = + match otb with + | None -> assemblyMainModule.DefineType(name=n,attr=attributes) + | Some (otb:TypeBuilder) -> otb.DefineNestedType(name=n,attr=attributes) + typeMapExtra.[fullName] <- tb + tb + (Some tb, fullName)) + nestedType otb.Value pt + end + let rec convType (ty:Type) = + match ty with + | :? ProvidedTypeDefinition as ptd -> + if typeMap.ContainsKey ptd then typeMap.[ptd] :> Type else ty + | _ -> + if ty.IsGenericType then ty.GetGenericTypeDefinition().MakeGenericType (Array.map convType (ty.GetGenericArguments())) + elif ty.HasElementType then + let ety = convType (ty.GetElementType()) + if ty.IsArray then + let rank = ty.GetArrayRank() + if rank = 1 then ety.MakeArrayType() + else ety.MakeArrayType rank + elif ty.IsPointer then ety.MakePointerType() + elif ty.IsByRef then ety.MakeByRefType() + else ty + else ty + + let ctorMap = Dictionary(HashIdentity.Reference) + let methMap = Dictionary(HashIdentity.Reference) + let fieldMap = Dictionary(HashIdentity.Reference) + + let iterateTypes f = + let rec typeMembers (ptd : ProvidedTypeDefinition) = + let tb = typeMap.[ptd] + f tb (Some ptd) + for ntd in ptd.GetNestedTypes(ALL) do + nestedType ntd + + and nestedType (ntd : Type) = + match ntd with + | :? ProvidedTypeDefinition as pntd -> typeMembers pntd + | _ -> () + + for (pt,enclosingGeneratedTypeNames) in providedTypeDefinitions do + match enclosingGeneratedTypeNames with + | None -> + typeMembers pt + | Some ns -> + let _fullName = + ("",ns) ||> List.fold (fun fullName n -> + let fullName = if fullName = "" then n else fullName + "." + n + f typeMapExtra.[fullName] None + fullName) + nestedType pt + + + // phase 1b - emit base types + iterateTypes (fun tb ptd -> + match ptd with + | None -> () + | Some ptd -> + match ptd.BaseType with null -> () | bt -> tb.SetParent(convType bt)) + + let defineCustomAttrs f (cattrs: IList) = + for attr in cattrs do + let constructorArgs = [ for x in attr.ConstructorArguments -> x.Value ] + let namedProps,namedPropVals = [ for x in attr.NamedArguments do match x.MemberInfo with :? PropertyInfo as pi -> yield (pi, x.TypedValue.Value) | _ -> () ] |> List.unzip + let namedFields,namedFieldVals = [ for x in attr.NamedArguments do match x.MemberInfo with :? FieldInfo as pi -> yield (pi, x.TypedValue.Value) | _ -> () ] |> List.unzip + let cab = CustomAttributeBuilder(attr.Constructor, Array.ofList constructorArgs, Array.ofList namedProps, Array.ofList namedPropVals, Array.ofList namedFields, Array.ofList namedFieldVals) + f cab + + // phase 2 - emit member definitions + iterateTypes (fun tb ptd -> + match ptd with + | None -> () + | Some ptd -> + for cinfo in ptd.GetConstructors(ALL) do + match cinfo with + | :? ProvidedConstructor as pcinfo when not (ctorMap.ContainsKey pcinfo) -> + let cb = + if pcinfo.IsTypeInitializer then + if (cinfo.GetParameters()).Length <> 0 then failwith "Type initializer should not have parameters" + tb.DefineTypeInitializer() + else + let cb = tb.DefineConstructor(cinfo.Attributes, CallingConventions.Standard, [| for p in cinfo.GetParameters() -> convType p.ParameterType |]) + for (i,p) in cinfo.GetParameters() |> Seq.mapi (fun i x -> (i,x)) do + cb.DefineParameter(i+1, ParameterAttributes.None, p.Name) |> ignore + cb + ctorMap.[pcinfo] <- cb + | _ -> () + + if ptd.IsEnum then + tb.DefineField("value__", ptd.GetEnumUnderlyingType(), FieldAttributes.Public ||| FieldAttributes.SpecialName ||| FieldAttributes.RTSpecialName) + |> ignore + + for finfo in ptd.GetFields(ALL) do + let fieldInfo = + match finfo with + | :? ProvidedField as pinfo -> + Some (pinfo.Name, convType finfo.FieldType, finfo.Attributes, pinfo.GetCustomAttributesDataImpl(), None) + | :? ProvidedLiteralField as pinfo -> + Some (pinfo.Name, convType finfo.FieldType, finfo.Attributes, pinfo.GetCustomAttributesDataImpl(), Some (pinfo.GetRawConstantValue())) + | _ -> None + match fieldInfo with + | Some (name, ty, attr, cattr, constantVal) when not (fieldMap.ContainsKey finfo) -> + let fb = tb.DefineField(name, ty, attr) + if constantVal.IsSome then + fb.SetConstant constantVal.Value + defineCustomAttrs fb.SetCustomAttribute cattr + fieldMap.[finfo] <- fb + | _ -> () + for minfo in ptd.GetMethods(ALL) do + match minfo with + | :? ProvidedMethod as pminfo when not (methMap.ContainsKey pminfo) -> + let mb = tb.DefineMethod(minfo.Name, minfo.Attributes, convType minfo.ReturnType, [| for p in minfo.GetParameters() -> convType p.ParameterType |]) + for (i, p) in minfo.GetParameters() |> Seq.mapi (fun i x -> (i,x :?> ProvidedParameter)) do + // TODO: check why F# compiler doesn't emit default value when just p.Attributes is used (thus bad metadata is emitted) +// let mutable attrs = ParameterAttributes.None +// +// if p.IsOut then attrs <- attrs ||| ParameterAttributes.Out +// if p.HasDefaultParameterValue then attrs <- attrs ||| ParameterAttributes.Optional + + let pb = mb.DefineParameter(i+1, p.Attributes, p.Name) + if p.HasDefaultParameterValue then + do + let ctor = typeof.GetConstructor([|typeof|]) + let builder = new CustomAttributeBuilder(ctor, [|p.RawDefaultValue|]) + pb.SetCustomAttribute builder + do + let ctor = typeof.GetConstructor([||]) + let builder = new CustomAttributeBuilder(ctor, [||]) + pb.SetCustomAttribute builder + pb.SetConstant p.RawDefaultValue + methMap.[pminfo] <- mb + | _ -> () + + for ityp in ptd.GetInterfaceImplementations() do + tb.AddInterfaceImplementation ityp) + + // phase 3 - emit member code + iterateTypes (fun tb ptd -> + match ptd with + | None -> () + | Some ptd -> + let cattr = ptd.GetCustomAttributesDataImpl() + defineCustomAttrs tb.SetCustomAttribute cattr + // Allow at most one constructor, and use its arguments as the fields of the type + let ctors = + ptd.GetConstructors(ALL) // exclude type initializer + |> Seq.choose (function :? ProvidedConstructor as pcinfo when not pcinfo.IsTypeInitializer -> Some pcinfo | _ -> None) + |> Seq.toList + let implictCtorArgs = + match ctors |> List.filter (fun x -> x.IsImplicitCtor) with + | [] -> [] + | [ pcinfo ] -> [ for p in pcinfo.GetParameters() -> p ] + | _ -> failwith "at most one implicit constructor allowed" + + let implicitCtorArgsAsFields = + [ for ctorArg in implictCtorArgs -> + tb.DefineField(ctorArg.Name, convType ctorArg.ParameterType, FieldAttributes.Private) ] + + let rec emitLambda(callSiteIlg : ILGenerator, v : Quotations.Var, body : Quotations.Expr, freeVars : seq, locals : Dictionary<_, LocalBuilder>, parameters) = + let lambda = assemblyMainModule.DefineType(uniqueLambdaTypeName(), TypeAttributes.Class) + let baseType = typedefof>.MakeGenericType(v.Type, body.Type) + lambda.SetParent(baseType) + let ctor = lambda.DefineDefaultConstructor(MethodAttributes.Public) + let decl = baseType.GetMethod "Invoke" + let paramTypes = [| for p in decl.GetParameters() -> p.ParameterType |] + let invoke = lambda.DefineMethod("Invoke", MethodAttributes.Virtual ||| MethodAttributes.Final ||| MethodAttributes.Public, decl.ReturnType, paramTypes) + lambda.DefineMethodOverride(invoke, decl) + + // promote free vars to fields + let fields = ResizeArray() + for v in freeVars do + let f = lambda.DefineField(v.Name, v.Type, FieldAttributes.Assembly) + fields.Add(v, f) + + let copyOfLocals = Dictionary() + + let ilg = invoke.GetILGenerator() + for (v, f) in fields do + let l = ilg.DeclareLocal(v.Type) + ilg.Emit(OpCodes.Ldarg_0) + ilg.Emit(OpCodes.Ldfld, f) + ilg.Emit(OpCodes.Stloc, l) + copyOfLocals.[v] <- l + + let expectedState = if (invoke.ReturnType = typeof) then ExpectedStackState.Empty else ExpectedStackState.Value + emitExpr (ilg, copyOfLocals, [| Quotations.Var("this", lambda); v|]) expectedState body + ilg.Emit(OpCodes.Ret) + + lambda.CreateType() |> ignore + + callSiteIlg.Emit(OpCodes.Newobj, ctor) + for (v, f) in fields do + callSiteIlg.Emit(OpCodes.Dup) + match locals.TryGetValue v with + | true, loc -> + callSiteIlg.Emit(OpCodes.Ldloc, loc) + | false, _ -> + let index = parameters |> Array.findIndex ((=) v) + callSiteIlg.Emit(OpCodes.Ldarg, index) + callSiteIlg.Emit(OpCodes.Stfld, f) + + and emitExpr (ilg: ILGenerator, locals:Dictionary, parameterVars) expectedState expr = + let pop () = ilg.Emit(OpCodes.Pop) + let popIfEmptyExpected s = if isEmpty s then pop() + let emitConvIfNecessary t1 = + if t1 = typeof then + ilg.Emit(OpCodes.Conv_I2) + elif t1 = typeof then + ilg.Emit(OpCodes.Conv_U2) + elif t1 = typeof then + ilg.Emit(OpCodes.Conv_I1) + elif t1 = typeof then + ilg.Emit(OpCodes.Conv_U1) + /// emits given expression to corresponding IL + let rec emit (expectedState : ExpectedStackState) (expr: Quotations.Expr) = + match expr with + | Quotations.Patterns.ForIntegerRangeLoop(loopVar, first, last, body) -> + // for(loopVar = first..last) body + let lb = + match locals.TryGetValue loopVar with + | true, lb -> lb + | false, _ -> + let lb = ilg.DeclareLocal(convType loopVar.Type) + locals.Add(loopVar, lb) + lb + + // loopVar = first + emit ExpectedStackState.Value first + ilg.Emit(OpCodes.Stloc, lb) + + let before = ilg.DefineLabel() + let after = ilg.DefineLabel() + + ilg.MarkLabel before + ilg.Emit(OpCodes.Ldloc, lb) + + emit ExpectedStackState.Value last + ilg.Emit(OpCodes.Bgt, after) + + emit ExpectedStackState.Empty body + + // loopVar++ + ilg.Emit(OpCodes.Ldloc, lb) + ilg.Emit(OpCodes.Ldc_I4_1) + ilg.Emit(OpCodes.Add) + ilg.Emit(OpCodes.Stloc, lb) + + ilg.Emit(OpCodes.Br, before) + ilg.MarkLabel(after) + + | Quotations.Patterns.NewArray(elementTy, elements) -> + ilg.Emit(OpCodes.Ldc_I4, List.length elements) + ilg.Emit(OpCodes.Newarr, convType elementTy) + + elements + |> List.iteri (fun i el -> + ilg.Emit(OpCodes.Dup) + ilg.Emit(OpCodes.Ldc_I4, i) + emit ExpectedStackState.Value el + ilg.Emit(OpCodes.Stelem, convType elementTy) + ) + + popIfEmptyExpected expectedState + + | Quotations.Patterns.WhileLoop(cond, body) -> + let before = ilg.DefineLabel() + let after = ilg.DefineLabel() + + ilg.MarkLabel before + emit ExpectedStackState.Value cond + ilg.Emit(OpCodes.Brfalse, after) + emit ExpectedStackState.Empty body + ilg.Emit(OpCodes.Br, before) + + ilg.MarkLabel after + + | Quotations.Patterns.Var v -> + if isEmpty expectedState then () else + let methIdx = parameterVars |> Array.tryFindIndex (fun p -> p = v) + match methIdx with + | Some idx -> + ilg.Emit((if isAddress expectedState then OpCodes.Ldarga else OpCodes.Ldarg), idx) + | None -> + let implicitCtorArgFieldOpt = implicitCtorArgsAsFields |> List.tryFind (fun f -> f.Name = v.Name) + match implicitCtorArgFieldOpt with + | Some ctorArgField -> + ilg.Emit(OpCodes.Ldarg_0) + ilg.Emit(OpCodes.Ldfld, ctorArgField) + | None -> + match locals.TryGetValue v with + | true, localBuilder -> + ilg.Emit((if isAddress expectedState then OpCodes.Ldloca else OpCodes.Ldloc), localBuilder.LocalIndex) + | false, _ -> + failwith "unknown parameter/field" + + | Quotations.Patterns.Coerce (arg,ty) -> + // castClass may lead to observable side-effects - InvalidCastException + emit ExpectedStackState.Value arg + let argTy = convType arg.Type + let targetTy = convType ty + if argTy.IsValueType && not targetTy.IsValueType then + ilg.Emit(OpCodes.Box, argTy) + elif not argTy.IsValueType && targetTy.IsValueType then + ilg.Emit(OpCodes.Unbox_Any, targetTy) + // emit castclass if + // - targettype is not obj (assume this is always possible for ref types) + // AND + // - HACK: targettype is TypeBuilderInstantiationType + // (its implementation of IsAssignableFrom raises NotSupportedException so it will be safer to always emit castclass) + // OR + // - not (argTy :> targetTy) + elif targetTy <> typeof && (Misc.TypeBuilderInstantiationType.Equals(targetTy.GetType()) || not (targetTy.IsAssignableFrom(argTy))) then + ilg.Emit(OpCodes.Castclass, targetTy) + + popIfEmptyExpected expectedState + | Quotations.DerivedPatterns.SpecificCall <@ (-) @>(None, [t1; t2; _], [a1; a2]) -> + assert(t1 = t2) + emit ExpectedStackState.Value a1 + emit ExpectedStackState.Value a2 + if t1 = typeof then + ilg.Emit(OpCodes.Call, typeof.GetMethod "op_Subtraction") + else + ilg.Emit(OpCodes.Sub) + emitConvIfNecessary t1 + + popIfEmptyExpected expectedState + + | Quotations.DerivedPatterns.SpecificCall <@ (/) @> (None, [t1; t2; _], [a1; a2]) -> + assert (t1 = t2) + emit ExpectedStackState.Value a1 + emit ExpectedStackState.Value a2 + if t1 = typeof then + ilg.Emit(OpCodes.Call, typeof.GetMethod "op_Division") + else + match Type.GetTypeCode t1 with + | TypeCode.UInt32 + | TypeCode.UInt64 + | TypeCode.UInt16 + | TypeCode.Byte + | _ when t1 = typeof -> ilg.Emit (OpCodes.Div_Un) + | _ -> ilg.Emit(OpCodes.Div) + + emitConvIfNecessary t1 + + popIfEmptyExpected expectedState + + | Quotations.DerivedPatterns.SpecificCall <@ int @>(None, [sourceTy], [v]) -> + emit ExpectedStackState.Value v + match Type.GetTypeCode(sourceTy) with + | TypeCode.String -> + ilg.Emit(OpCodes.Call, Misc.ParseInt32Method) + | TypeCode.Single + | TypeCode.Double + | TypeCode.Int64 + | TypeCode.UInt64 + | TypeCode.UInt16 + | TypeCode.Char + | TypeCode.Byte + | _ when sourceTy = typeof || sourceTy = typeof -> + ilg.Emit(OpCodes.Conv_I4) + | TypeCode.Int32 + | TypeCode.UInt32 + | TypeCode.Int16 + | TypeCode.SByte -> () // no op + | _ -> failwith "TODO: search for op_Explicit on sourceTy" + + | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray @> (None, [ty], [arr; index]) -> + // observable side-effect - IndexOutOfRangeException + emit ExpectedStackState.Value arr + emit ExpectedStackState.Value index + if isAddress expectedState then + ilg.Emit(OpCodes.Readonly) + ilg.Emit(OpCodes.Ldelema, convType ty) + else + ilg.Emit(OpCodes.Ldelem, convType ty) + + popIfEmptyExpected expectedState + + | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray2D @> (None, _ty, arr::indices) + | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray3D @> (None, _ty, arr::indices) + | Quotations.DerivedPatterns.SpecificCall <@ LanguagePrimitives.IntrinsicFunctions.GetArray4D @> (None, _ty, arr::indices) -> + + let meth = + let name = if isAddress expectedState then "Address" else "Get" + arr.Type.GetMethod(name) + + // observable side-effect - IndexOutOfRangeException + emit ExpectedStackState.Value arr + for index in indices do + emit ExpectedStackState.Value index + + if isAddress expectedState then + ilg.Emit(OpCodes.Readonly) + + ilg.Emit(OpCodes.Call, meth) + + popIfEmptyExpected expectedState + + | Quotations.Patterns.FieldGet (objOpt,field) -> + match field with + | :? ProvidedLiteralField as plf when plf.DeclaringType.IsEnum -> + if expectedState <> ExpectedStackState.Empty then + emit expectedState (Quotations.Expr.Value(field.GetRawConstantValue(), field.FieldType.GetEnumUnderlyingType())) + | _ -> + match objOpt with + | None -> () + | Some e -> + let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value + emit s e + let field = + match field with + | :? ProvidedField as pf when fieldMap.ContainsKey pf -> fieldMap.[pf] :> FieldInfo + | m -> m + if field.IsStatic then + ilg.Emit(OpCodes.Ldsfld, field) + else + ilg.Emit(OpCodes.Ldfld, field) + + | Quotations.Patterns.FieldSet (objOpt,field,v) -> + match objOpt with + | None -> () + | Some e -> + let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value + emit s e + emit ExpectedStackState.Value v + let field = match field with :? ProvidedField as pf when fieldMap.ContainsKey pf -> fieldMap.[pf] :> FieldInfo | m -> m + if field.IsStatic then + ilg.Emit(OpCodes.Stsfld, field) + else + ilg.Emit(OpCodes.Stfld, field) + | Quotations.Patterns.Call (objOpt,meth,args) -> + match objOpt with + | None -> () + | Some e -> + let s = if e.Type.IsValueType then ExpectedStackState.Address else ExpectedStackState.Value + emit s e + for pe in args do + emit ExpectedStackState.Value pe + let getMeth (m:MethodInfo) = match m with :? ProvidedMethod as pm when methMap.ContainsKey pm -> methMap.[pm] :> MethodInfo | m -> m + // Handle the case where this is a generic method instantiated at a type being compiled + let mappedMeth = + if meth.IsGenericMethod then + let args = meth.GetGenericArguments() |> Array.map convType + let gmd = meth.GetGenericMethodDefinition() |> getMeth + gmd.GetGenericMethodDefinition().MakeGenericMethod args + elif meth.DeclaringType.IsGenericType then + let gdty = convType (meth.DeclaringType.GetGenericTypeDefinition()) + let gdtym = gdty.GetMethods() |> Seq.find (fun x -> x.Name = meth.Name) + assert (gdtym <> null) // ?? will never happen - if method is not found - KeyNotFoundException will be raised + let dtym = + match convType meth.DeclaringType with + | :? TypeBuilder as dty -> TypeBuilder.GetMethod(dty, gdtym) + | dty -> MethodBase.GetMethodFromHandle(meth.MethodHandle, dty.TypeHandle) :?> _ + + assert (dtym <> null) + dtym + else + getMeth meth + match objOpt with + | Some obj when mappedMeth.IsAbstract || mappedMeth.IsVirtual -> + if obj.Type.IsValueType then ilg.Emit(OpCodes.Constrained, convType obj.Type) + ilg.Emit(OpCodes.Callvirt, mappedMeth) + | _ -> + ilg.Emit(OpCodes.Call, mappedMeth) + + let returnTypeIsVoid = mappedMeth.ReturnType = typeof + match returnTypeIsVoid, (isEmpty expectedState) with + | false, true -> + // method produced something, but we don't need it + pop() + | true, false when expr.Type = typeof -> + // if we need result and method produce void and result should be unit - push null as unit value on stack + ilg.Emit(OpCodes.Ldnull) + | _ -> () + + | Quotations.Patterns.NewObject (ctor,args) -> + for pe in args do + emit ExpectedStackState.Value pe + let meth = match ctor with :? ProvidedConstructor as pc when ctorMap.ContainsKey pc -> ctorMap.[pc] :> ConstructorInfo | c -> c + ilg.Emit(OpCodes.Newobj, meth) + + popIfEmptyExpected expectedState + + | Quotations.Patterns.Value (obj, _ty) -> + let rec emitC (v:obj) = + match v with + | :? string as x -> ilg.Emit(OpCodes.Ldstr, x) + | :? int8 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) + | :? uint8 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 (int8 x)) + | :? int16 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) + | :? uint16 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 (int16 x)) + | :? int32 as x -> ilg.Emit(OpCodes.Ldc_I4, x) + | :? uint32 as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) + | :? int64 as x -> ilg.Emit(OpCodes.Ldc_I8, x) + | :? uint64 as x -> ilg.Emit(OpCodes.Ldc_I8, int64 x) + | :? char as x -> ilg.Emit(OpCodes.Ldc_I4, int32 x) + | :? bool as x -> ilg.Emit(OpCodes.Ldc_I4, if x then 1 else 0) + | :? float32 as x -> ilg.Emit(OpCodes.Ldc_R4, x) + | :? float as x -> ilg.Emit(OpCodes.Ldc_R8, x) +#if FX_NO_GET_ENUM_UNDERLYING_TYPE +#else + | :? System.Enum as x when x.GetType().GetEnumUnderlyingType() = typeof -> ilg.Emit(OpCodes.Ldc_I4, unbox v) +#endif + | :? Type as ty -> + ilg.Emit(OpCodes.Ldtoken, convType ty) + ilg.Emit(OpCodes.Call, Misc.GetTypeFromHandleMethod) + | :? decimal as x -> + let bits = System.Decimal.GetBits x + ilg.Emit(OpCodes.Ldc_I4, bits.[0]) + ilg.Emit(OpCodes.Ldc_I4, bits.[1]) + ilg.Emit(OpCodes.Ldc_I4, bits.[2]) + do + let sign = (bits.[3] &&& 0x80000000) <> 0 + ilg.Emit(if sign then OpCodes.Ldc_I4_1 else OpCodes.Ldc_I4_0) + do + let scale = byte ((bits.[3] >>> 16) &&& 0x7F) + ilg.Emit(OpCodes.Ldc_I4_S, scale) + ilg.Emit(OpCodes.Newobj, Misc.DecimalConstructor) + | :? DateTime as x -> + ilg.Emit(OpCodes.Ldc_I8, x.Ticks) + ilg.Emit(OpCodes.Ldc_I4, int x.Kind) + ilg.Emit(OpCodes.Newobj, Misc.DateTimeConstructor) + | :? DateTimeOffset as x -> + ilg.Emit(OpCodes.Ldc_I8, x.Ticks) + ilg.Emit(OpCodes.Ldc_I8, x.Offset.Ticks) + ilg.Emit(OpCodes.Newobj, Misc.TimeSpanConstructor) + ilg.Emit(OpCodes.Newobj, Misc.DateTimeOffsetConstructor) + | null -> ilg.Emit(OpCodes.Ldnull) + | _ -> failwithf "unknown constant '%A' in generated method" v + if isEmpty expectedState then () + else emitC obj + + | Quotations.Patterns.Let(v,e,b) -> + let lb = ilg.DeclareLocal (convType v.Type) + locals.Add (v, lb) + emit ExpectedStackState.Value e + ilg.Emit(OpCodes.Stloc, lb.LocalIndex) + emit expectedState b + + | Quotations.Patterns.Sequential(e1, e2) -> + emit ExpectedStackState.Empty e1 + emit expectedState e2 + + | Quotations.Patterns.IfThenElse(cond, ifTrue, ifFalse) -> + let ifFalseLabel = ilg.DefineLabel() + let endLabel = ilg.DefineLabel() + + emit ExpectedStackState.Value cond + + ilg.Emit(OpCodes.Brfalse, ifFalseLabel) + + emit expectedState ifTrue + ilg.Emit(OpCodes.Br, endLabel) + + ilg.MarkLabel(ifFalseLabel) + emit expectedState ifFalse + + ilg.Emit(OpCodes.Nop) + ilg.MarkLabel(endLabel) + + | Quotations.Patterns.TryWith(body, _filterVar, _filterBody, catchVar, catchBody) -> + + let stres, ldres = + if isEmpty expectedState then ignore, ignore + else + let local = ilg.DeclareLocal (convType body.Type) + let stres = fun () -> ilg.Emit(OpCodes.Stloc, local) + let ldres = fun () -> ilg.Emit(OpCodes.Ldloc, local) + stres, ldres + + let exceptionVar = ilg.DeclareLocal(convType catchVar.Type) + locals.Add(catchVar, exceptionVar) + + let _exnBlock = ilg.BeginExceptionBlock() + + emit expectedState body + stres() + + ilg.BeginCatchBlock(convType catchVar.Type) + ilg.Emit(OpCodes.Stloc, exceptionVar) + emit expectedState catchBody + stres() + ilg.EndExceptionBlock() + + ldres() + + | Quotations.Patterns.VarSet(v,e) -> + emit ExpectedStackState.Value e + match locals.TryGetValue v with + | true, localBuilder -> + ilg.Emit(OpCodes.Stloc, localBuilder.LocalIndex) + | false, _ -> + failwith "unknown parameter/field in assignment. Only assignments to locals are currently supported by TypeProviderEmit" + | Quotations.Patterns.Lambda(v, body) -> + emitLambda(ilg, v, body, expr.GetFreeVars(), locals, parameterVars) + popIfEmptyExpected expectedState + | n -> + failwith (sprintf "unknown expression '%A' in generated method" n) + emit expectedState expr + + + // Emit the constructor (if any) + for pcinfo in ctors do + assert ctorMap.ContainsKey pcinfo + let cb = ctorMap.[pcinfo] + let cattr = pcinfo.GetCustomAttributesDataImpl() + defineCustomAttrs cb.SetCustomAttribute cattr + let ilg = cb.GetILGenerator() + let locals = Dictionary() + let parameterVars = + [| yield Quotations.Var("this", pcinfo.DeclaringType) + for p in pcinfo.GetParameters() do + yield Quotations.Var(p.Name, p.ParameterType) |] + let parameters = + [| for v in parameterVars -> Quotations.Expr.Var v |] + match pcinfo.GetBaseConstructorCallInternal true with + | None -> + ilg.Emit(OpCodes.Ldarg_0) + let cinfo = ptd.BaseType.GetConstructor(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance, null, [| |], null) + ilg.Emit(OpCodes.Call,cinfo) + | Some f -> + // argExprs should always include 'this' + let (cinfo,argExprs) = f (Array.toList parameters) + for argExpr in argExprs do + emitExpr (ilg, locals, parameterVars) ExpectedStackState.Value argExpr + ilg.Emit(OpCodes.Call,cinfo) + + if pcinfo.IsImplicitCtor then + for ctorArgsAsFieldIdx,ctorArgsAsField in List.mapi (fun i x -> (i,x)) implicitCtorArgsAsFields do + ilg.Emit(OpCodes.Ldarg_0) + ilg.Emit(OpCodes.Ldarg, ctorArgsAsFieldIdx+1) + ilg.Emit(OpCodes.Stfld, ctorArgsAsField) + else + let code = pcinfo.GetInvokeCodeInternal true + let code = code parameters + emitExpr (ilg, locals, parameterVars) ExpectedStackState.Empty code + ilg.Emit(OpCodes.Ret) + + match ptd.GetConstructors(ALL) |> Seq.tryPick (function :? ProvidedConstructor as pc when pc.IsTypeInitializer -> Some pc | _ -> None) with + | None -> () + | Some pc -> + let cb = ctorMap.[pc] + let ilg = cb.GetILGenerator() + let cattr = pc.GetCustomAttributesDataImpl() + defineCustomAttrs cb.SetCustomAttribute cattr + let expr = pc.GetInvokeCodeInternal true [||] + emitExpr(ilg, new Dictionary<_, _>(), [||]) ExpectedStackState.Empty expr + ilg.Emit OpCodes.Ret + + // Emit the methods + for minfo in ptd.GetMethods(ALL) do + match minfo with + | :? ProvidedMethod as pminfo -> + let mb = methMap.[pminfo] + let ilg = mb.GetILGenerator() + let cattr = pminfo.GetCustomAttributesDataImpl() + defineCustomAttrs mb.SetCustomAttribute cattr + + let parameterVars = + [| if not pminfo.IsStatic then + yield Quotations.Var("this", pminfo.DeclaringType) + for p in pminfo.GetParameters() do + yield Quotations.Var(p.Name, p.ParameterType) |] + let parameters = + [| for v in parameterVars -> Quotations.Expr.Var v |] + + let expr = pminfo.GetInvokeCodeInternal true parameters + + let locals = Dictionary() + //printfn "Emitting linqCode for %s::%s, code = %s" pminfo.DeclaringType.FullName pminfo.Name (try linqCode.ToString() with _ -> "") + + + let expectedState = if (minfo.ReturnType = typeof) then ExpectedStackState.Empty else ExpectedStackState.Value + emitExpr (ilg, locals, parameterVars) expectedState expr + ilg.Emit OpCodes.Ret + | _ -> () + + for (bodyMethInfo,declMethInfo) in ptd.GetMethodOverrides() do + let bodyMethBuilder = methMap.[bodyMethInfo] + tb.DefineMethodOverride(bodyMethBuilder,declMethInfo) + + for evt in ptd.GetEvents(ALL) |> Seq.choose (function :? ProvidedEvent as pe -> Some pe | _ -> None) do + let eb = tb.DefineEvent(evt.Name, evt.Attributes, evt.EventHandlerType) + defineCustomAttrs eb.SetCustomAttribute (evt.GetCustomAttributesDataImpl()) + eb.SetAddOnMethod(methMap.[evt.GetAddMethod(true) :?> _]) + eb.SetRemoveOnMethod(methMap.[evt.GetRemoveMethod(true) :?> _]) + // TODO: add raiser + + for pinfo in ptd.GetProperties(ALL) |> Seq.choose (function :? ProvidedProperty as pe -> Some pe | _ -> None) do + let pb = tb.DefineProperty(pinfo.Name, pinfo.Attributes, convType pinfo.PropertyType, [| for p in pinfo.GetIndexParameters() -> convType p.ParameterType |]) + let cattr = pinfo.GetCustomAttributesDataImpl() + defineCustomAttrs pb.SetCustomAttribute cattr + if pinfo.CanRead then + let minfo = pinfo.GetGetMethod(true) + pb.SetGetMethod (methMap.[minfo :?> ProvidedMethod ]) + if pinfo.CanWrite then + let minfo = pinfo.GetSetMethod(true) + pb.SetSetMethod (methMap.[minfo :?> ProvidedMethod ])) + + + // phase 4 - complete types + iterateTypes (fun tb _ptd -> tb.CreateType() |> ignore) + +#if FX_NO_LOCAL_FILESYSTEM +#else + assembly.Save (Path.GetFileName assemblyFileName) +#endif + + let assemblyLoadedInMemory = assemblyMainModule.Assembly + + iterateTypes (fun _tb ptd -> + match ptd with + | None -> () + | Some ptd -> ptd.SetAssembly assemblyLoadedInMemory) + +#if FX_NO_LOCAL_FILESYSTEM +#else + member __.GetFinalBytes() = + let assemblyBytes = File.ReadAllBytes assemblyFileName + let _assemblyLoadedInMemory = System.Reflection.Assembly.Load(assemblyBytes,null,System.Security.SecurityContextSource.CurrentAppDomain) + //printfn "final bytes in '%s'" assemblyFileName + //File.Delete assemblyFileName + assemblyBytes +#endif + +type ProvidedAssembly(assemblyFileName: string) = + let theTypes = ResizeArray<_>() + let assemblyGenerator = AssemblyGenerator(assemblyFileName) + let assemblyLazy = + lazy + assemblyGenerator.Generate(theTypes |> Seq.toList) + assemblyGenerator.Assembly +#if FX_NO_LOCAL_FILESYSTEM +#else + let theAssemblyBytesLazy = + lazy + assemblyGenerator.GetFinalBytes() + + do + GlobalProvidedAssemblyElementsTable.theTable.Add(assemblyGenerator.Assembly, theAssemblyBytesLazy) + +#endif + + let add (providedTypeDefinitions:ProvidedTypeDefinition list, enclosingTypeNames: string list option) = + for pt in providedTypeDefinitions do + if pt.IsErased then invalidOp ("The provided type "+pt.Name+"is marked as erased and cannot be converted to a generated type. Set 'IsErased' to false on the ProvidedTypeDefinition") + theTypes.Add(pt,enclosingTypeNames) + pt.SetAssemblyLazy assemblyLazy + + member x.AddNestedTypes (providedTypeDefinitions, enclosingTypeNames) = add (providedTypeDefinitions, Some enclosingTypeNames) + member x.AddTypes (providedTypeDefinitions) = add (providedTypeDefinitions, None) +#if FX_NO_LOCAL_FILESYSTEM +#else + static member RegisterGenerated (fileName:string) = + //printfn "registered assembly in '%s'" fileName + let assemblyBytes = System.IO.File.ReadAllBytes fileName + let assembly = Assembly.Load(assemblyBytes,null,System.Security.SecurityContextSource.CurrentAppDomain) + GlobalProvidedAssemblyElementsTable.theTable.Add(assembly, Lazy<_>.CreateFromValue assemblyBytes) + assembly +#endif + + +module Local = + + let makeProvidedNamespace (namespaceName:string) (types:ProvidedTypeDefinition list) = + let types = [| for ty in types -> ty :> Type |] + {new IProvidedNamespace with + member __.GetNestedNamespaces() = [| |] + member __.NamespaceName = namespaceName + member __.GetTypes() = types |> Array.copy + member __.ResolveTypeName typeName : System.Type = + match types |> Array.tryFind (fun ty -> ty.Name = typeName) with + | Some ty -> ty + | None -> null + } + + +#if FX_NO_LOCAL_FILESYSTEM +type TypeProviderForNamespaces(namespacesAndTypes : list<(string * list)>) = +#else +type TypeProviderForNamespaces(namespacesAndTypes : list<(string * list)>) as this = +#endif + let otherNamespaces = ResizeArray>() + + let providedNamespaces = + lazy [| for (namespaceName,types) in namespacesAndTypes do + yield Local.makeProvidedNamespace namespaceName types + for (namespaceName,types) in otherNamespaces do + yield Local.makeProvidedNamespace namespaceName types |] + + let invalidateE = new Event() + + let disposing = Event() + +#if FX_NO_LOCAL_FILESYSTEM +#else + let probingFolders = ResizeArray() + let handler = ResolveEventHandler(fun _ args -> this.ResolveAssembly(args)) + do AppDomain.CurrentDomain.add_AssemblyResolve handler +#endif + + new (namespaceName:string,types:list) = new TypeProviderForNamespaces([(namespaceName,types)]) + new () = new TypeProviderForNamespaces([]) + + [] + member __.Disposing = disposing.Publish + +#if FX_NO_LOCAL_FILESYSTEM + interface System.IDisposable with + member x.Dispose() = + disposing.Trigger(x, EventArgs.Empty) +#else + abstract member ResolveAssembly : args : System.ResolveEventArgs -> Assembly + + default __.ResolveAssembly(args) = + let expectedName = (AssemblyName(args.Name)).Name + ".dll" + let expectedLocationOpt = + probingFolders + |> Seq.map (fun f -> IO.Path.Combine(f, expectedName)) + |> Seq.tryFind IO.File.Exists + match expectedLocationOpt with + | Some f -> Assembly.LoadFrom f + | None -> null + + member __.RegisterProbingFolder (folder) = + // use GetFullPath to ensure that folder is valid + ignore(IO.Path.GetFullPath folder) + probingFolders.Add folder + + member __.RegisterRuntimeAssemblyLocationAsProbingFolder (config : TypeProviderConfig) = + config.RuntimeAssembly + |> IO.Path.GetDirectoryName + |> this.RegisterProbingFolder + + interface System.IDisposable with + member x.Dispose() = + disposing.Trigger(x, EventArgs.Empty) + AppDomain.CurrentDomain.remove_AssemblyResolve handler +#endif + + member __.AddNamespace (namespaceName,types:list<_>) = otherNamespaces.Add (namespaceName,types) + + // FSharp.Data addition: this method is used by Debug.fs + member __.Namespaces = Seq.readonly otherNamespaces + + member this.Invalidate() = invalidateE.Trigger(this,EventArgs()) + + member __.GetStaticParametersForMethod(mb: MethodBase) = + printfn "In GetStaticParametersForMethod" + match mb with + | :? ProvidedMethod as t -> t.GetStaticParameters() + | _ -> [| |] + + member __.ApplyStaticArgumentsForMethod(mb: MethodBase, mangledName, objs) = + printfn "In ApplyStaticArgumentsForMethod" + match mb with + | :? ProvidedMethod as t -> t.ApplyStaticArguments(mangledName, objs) :> MethodBase + | _ -> failwith (sprintf "ApplyStaticArguments: static parameters for method %s are unexpected" mb.Name) + + interface ITypeProvider with + + [] + override __.Invalidate = invalidateE.Publish + + override __.GetNamespaces() = Array.copy providedNamespaces.Value + + member __.GetInvokerExpression(methodBase, parameters) = + let rec getInvokerExpression (methodBase : MethodBase) parameters = + match methodBase with + | :? ProvidedMethod as m when (match methodBase.DeclaringType with :? ProvidedTypeDefinition as pt -> pt.IsErased | _ -> true) -> + m.GetInvokeCodeInternal false parameters + |> expand + | :? ProvidedConstructor as m when (match methodBase.DeclaringType with :? ProvidedTypeDefinition as pt -> pt.IsErased | _ -> true) -> + m.GetInvokeCodeInternal false parameters + |> expand + // Otherwise, assume this is a generative assembly and just emit a call to the constructor or method + | :? ConstructorInfo as cinfo -> + Quotations.Expr.NewObject(cinfo, Array.toList parameters) + | :? System.Reflection.MethodInfo as minfo -> + if minfo.IsStatic then + Quotations.Expr.Call(minfo, Array.toList parameters) + else + Quotations.Expr.Call(parameters.[0], minfo, Array.toList parameters.[1..]) + | _ -> failwith ("TypeProviderForNamespaces.GetInvokerExpression: not a ProvidedMethod/ProvidedConstructor/ConstructorInfo/MethodInfo, name=" + methodBase.Name + " class=" + methodBase.GetType().FullName) + and expand expr = + match expr with + | Quotations.Patterns.NewObject(ctor, args) -> getInvokerExpression ctor [| for arg in args -> expand arg|] + | Quotations.Patterns.Call(inst, mi, args) -> + let args = + [| + match inst with + | Some inst -> yield expand inst + | _ -> () + yield! List.map expand args + |] + getInvokerExpression mi args + | Quotations.ExprShape.ShapeVar v -> Quotations.Expr.Var v + | Quotations.ExprShape.ShapeLambda(v, body) -> Quotations.Expr.Lambda(v, expand body) + | Quotations.ExprShape.ShapeCombination(shape, args) -> Quotations.ExprShape.RebuildShapeCombination(shape, List.map expand args) + getInvokerExpression methodBase parameters +#if FX_NO_CUSTOMATTRIBUTEDATA + + member __.GetMemberCustomAttributesData(methodBase) = + match methodBase with + | :? ProvidedTypeDefinition as m -> m.GetCustomAttributesDataImpl() + | :? ProvidedMethod as m -> m.GetCustomAttributesDataImpl() + | :? ProvidedProperty as m -> m.GetCustomAttributesDataImpl() + | :? ProvidedConstructor as m -> m.GetCustomAttributesDataImpl() + | :? ProvidedEvent as m -> m.GetCustomAttributesDataImpl() + | :? ProvidedLiteralField as m -> m.GetCustomAttributesDataImpl() + | :? ProvidedField as m -> m.GetCustomAttributesDataImpl() + | _ -> [| |] :> IList<_> + + member __.GetParameterCustomAttributesData(methodBase) = + match methodBase with + | :? ProvidedParameter as m -> m.GetCustomAttributesDataImpl() + | _ -> [| |] :> IList<_> + + +#endif + override __.GetStaticParameters(ty) = + match ty with + | :? ProvidedTypeDefinition as t -> + if ty.Name = t.Name (* REVIEW: use equality? *) then + t.GetStaticParameters() + else + [| |] + | _ -> [| |] + + override __.ApplyStaticArguments(ty,typePathAfterArguments:string[],objs) = + let typePathAfterArguments = typePathAfterArguments.[typePathAfterArguments.Length-1] + match ty with + | :? ProvidedTypeDefinition as t -> (t.MakeParametricType(typePathAfterArguments,objs) :> Type) + | _ -> failwith (sprintf "ApplyStaticArguments: static params for type %s are unexpected" ty.FullName) + +#if FX_NO_LOCAL_FILESYSTEM + override __.GetGeneratedAssemblyContents(_assembly) = + // TODO: this is very fake, we rely on the fact it is never needed + match System.Windows.Application.GetResourceStream(System.Uri("FSharp.Core.dll",System.UriKind.Relative)) with + | null -> failwith "FSharp.Core.dll not found as Manifest Resource, we're just trying to read some random .NET assembly, ok?" + | resStream -> + use stream = resStream.Stream + let len = stream.Length + let buf = Array.zeroCreate (int len) + let rec loop where rem = + let n = stream.Read(buf, 0, int rem) + if n < rem then loop (where + n) (rem - n) + loop 0 (int len) + buf + + //failwith "no file system" +#else + override __.GetGeneratedAssemblyContents(assembly:Assembly) = + //printfn "looking up assembly '%s'" assembly.FullName + match GlobalProvidedAssemblyElementsTable.theTable.TryGetValue assembly with + | true,bytes -> bytes.Force() + | _ -> + let bytes = System.IO.File.ReadAllBytes assembly.ManifestModule.FullyQualifiedName + GlobalProvidedAssemblyElementsTable.theTable.[assembly] <- Lazy<_>.CreateFromValue bytes + bytes +#endif diff --git a/tests/service/data/TestTP/ProvidedTypes.fsi b/tests/service/data/TestTP/ProvidedTypes.fsi new file mode 100644 index 00000000000..3eb5025f6d4 --- /dev/null +++ b/tests/service/data/TestTP/ProvidedTypes.fsi @@ -0,0 +1,467 @@ +// Copyright (c) Microsoft Corporation 2005-2014 and other contributors. +// This sample code is provided "as is" without warranty of any kind. +// We disclaim all warranties, either express or implied, including the +// warranties of merchantability and fitness for a particular purpose. +// +// This file contains a set of helper types and methods for providing types in an implementation +// of ITypeProvider. +// +// This code has been modified and is appropriate for use in conjunction with the F# 3.0-4.0 releases + + +namespace ProviderImplementation.ProvidedTypes + +open System +open System.Reflection +open System.Linq.Expressions +open Microsoft.FSharp.Core.CompilerServices + +/// Represents an erased provided parameter +type ProvidedParameter = + inherit ParameterInfo + new : parameterName: string * parameterType: Type * ?isOut:bool * ?optionalValue:obj -> ProvidedParameter + member IsParamArray : bool with get,set + +/// Represents a provided static parameter. +type ProvidedStaticParameter = + inherit ParameterInfo + new : parameterName: string * parameterType:Type * ?parameterDefaultValue:obj -> ProvidedStaticParameter + + /// Add XML documentation information to this provided constructor + member AddXmlDoc : xmlDoc: string -> unit + + /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary + member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit + +/// Represents an erased provided constructor. +type ProvidedConstructor = + inherit ConstructorInfo + + /// Create a new provided constructor. It is not initially associated with any specific provided type definition. + new : parameters: ProvidedParameter list -> ProvidedConstructor + + /// Add a 'System.Obsolete' attribute to this provided constructor + member AddObsoleteAttribute : message: string * ?isError: bool -> unit + + /// Add XML documentation information to this provided constructor + member AddXmlDoc : xmlDoc: string -> unit + + /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary + member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit + + /// Add XML documentation information to this provided constructor, where the documentation is re-computed every time it is required. + member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit + + /// Set the quotation used to compute the implementation of invocations of this constructor. + member InvokeCode : (Quotations.Expr list -> Quotations.Expr) with set + + /// FSharp.Data addition: this method is used by Debug.fs + member internal GetInvokeCodeInternal : bool -> (Quotations.Expr [] -> Quotations.Expr) + + /// Set the target and arguments of the base constructor call. Only used for generated types. + member BaseConstructorCall : (Quotations.Expr list -> ConstructorInfo * Quotations.Expr list) with set + + /// Set a flag indicating that the constructor acts like an F# implicit constructor, so the + /// parameters of the constructor become fields and can be accessed using Expr.GlobalVar with the + /// same name. + member IsImplicitCtor : bool with get,set + + /// Add definition location information to the provided constructor. + member AddDefinitionLocation : line:int * column:int * filePath:string -> unit + + member IsTypeInitializer : bool with get,set + +type ProvidedMethod = + inherit MethodInfo + + /// Create a new provided method. It is not initially associated with any specific provided type definition. + new : methodName:string * parameters: ProvidedParameter list * returnType: Type -> ProvidedMethod + + /// Add XML documentation information to this provided method + member AddObsoleteAttribute : message: string * ?isError: bool -> unit + + /// Add XML documentation information to this provided constructor + member AddXmlDoc : xmlDoc: string -> unit + + /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary + member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit + + /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary + /// The documentation is re-computed every time it is required. + member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit + + member AddMethodAttrs : attributes:MethodAttributes -> unit + + /// Set the method attributes of the method. By default these are simple 'MethodAttributes.Public' + member SetMethodAttrs : attributes:MethodAttributes -> unit + + /// Get or set a flag indicating if the property is static. + member IsStaticMethod : bool with get, set + + /// Set the quotation used to compute the implementation of invocations of this method. + member InvokeCode : (Quotations.Expr list -> Quotations.Expr) with set + + /// FSharp.Data addition: this method is used by Debug.fs + member internal GetInvokeCodeInternal : bool -> (Quotations.Expr [] -> Quotations.Expr) + + /// Add definition location information to the provided type definition. + member AddDefinitionLocation : line:int * column:int * filePath:string -> unit + + /// Add a custom attribute to the provided method definition. + member AddCustomAttribute : CustomAttributeData -> unit + + /// Define the static parameters available on a statically parameterized method + member DefineStaticParameters : parameters: ProvidedStaticParameter list * instantiationFunction: (string -> obj[] -> ProvidedMethod) -> unit + +/// Represents an erased provided property. +type ProvidedProperty = + inherit PropertyInfo + + /// Create a new provided type. It is not initially associated with any specific provided type definition. + new : propertyName: string * propertyType: Type * ?parameters:ProvidedParameter list -> ProvidedProperty + + /// Add a 'System.Obsolete' attribute to this provided property + member AddObsoleteAttribute : message: string * ?isError: bool -> unit + + /// Add XML documentation information to this provided constructor + member AddXmlDoc : xmlDoc: string -> unit + + /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary + member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit + + /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary + /// The documentation is re-computed every time it is required. + member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit + + /// Get or set a flag indicating if the property is static. + /// FSharp.Data addition: the getter is used by Debug.fs + member IsStatic : bool with get,set + + /// Set the quotation used to compute the implementation of gets of this property. + member GetterCode : (Quotations.Expr list -> Quotations.Expr) with set + + /// Set the function used to compute the implementation of sets of this property. + member SetterCode : (Quotations.Expr list -> Quotations.Expr) with set + + /// Add definition location information to the provided type definition. + member AddDefinitionLocation : line:int * column:int * filePath:string -> unit + + /// Add a custom attribute to the provided property definition. + member AddCustomAttribute : CustomAttributeData -> unit + +/// Represents an erased provided property. +type ProvidedEvent = + inherit EventInfo + + /// Create a new provided type. It is not initially associated with any specific provided type definition. + new : propertyName: string * eventHandlerType: Type -> ProvidedEvent + + /// Add XML documentation information to this provided constructor + member AddXmlDoc : xmlDoc: string -> unit + + /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary + member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit + + /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary + /// The documentation is re-computed every time it is required. + member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit + + /// Get or set a flag indicating if the property is static. + member IsStatic : bool with set + + /// Set the quotation used to compute the implementation of gets of this property. + member AdderCode : (Quotations.Expr list -> Quotations.Expr) with set + + /// Set the function used to compute the implementation of sets of this property. + member RemoverCode : (Quotations.Expr list -> Quotations.Expr) with set + + /// Add definition location information to the provided type definition. + member AddDefinitionLocation : line:int * column:int * filePath:string -> unit + +/// Represents an erased provided field. +type ProvidedLiteralField = + inherit FieldInfo + + /// Create a new provided field. It is not initially associated with any specific provided type definition. + new : fieldName: string * fieldType: Type * literalValue: obj -> ProvidedLiteralField + + /// Add a 'System.Obsolete' attribute to this provided field + member AddObsoleteAttribute : message: string * ?isError: bool -> unit + + /// Add XML documentation information to this provided field + member AddXmlDoc : xmlDoc: string -> unit + + /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary + member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit + + /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary + /// The documentation is re-computed every time it is required. + member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit + + /// Add definition location information to the provided field. + member AddDefinitionLocation : line:int * column:int * filePath:string -> unit + +/// Represents an erased provided field. +type ProvidedField = + inherit FieldInfo + + /// Create a new provided field. It is not initially associated with any specific provided type definition. + new : fieldName: string * fieldType: Type -> ProvidedField + + /// Add a 'System.Obsolete' attribute to this provided field + member AddObsoleteAttribute : message: string * ?isError: bool -> unit + + /// Add XML documentation information to this provided field + member AddXmlDoc : xmlDoc: string -> unit + + /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary + member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit + + /// Add XML documentation information to this provided field, where the computation of the documentation is delayed until necessary + /// The documentation is re-computed every time it is required. + member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit + + /// Add definition location information to the provided field definition. + member AddDefinitionLocation : line:int * column:int * filePath:string -> unit + + member SetFieldAttributes : attributes : FieldAttributes -> unit + +/// Represents the type constructor in a provided symbol type. +[] +type SymbolKind = + /// Indicates that the type constructor is for a single-dimensional array + | SDArray + /// Indicates that the type constructor is for a multi-dimensional array + | Array of int + /// Indicates that the type constructor is for pointer types + | Pointer + /// Indicates that the type constructor is for byref types + | ByRef + /// Indicates that the type constructor is for named generic types + | Generic of Type + /// Indicates that the type constructor is for abbreviated types + | FSharpTypeAbbreviation of (Assembly * string * string[]) + +/// Represents an array or other symbolic type involving a provided type as the argument. +/// See the type provider spec for the methods that must be implemented. +/// Note that the type provider specification does not require us to implement pointer-equality for provided types. +[] +type ProvidedSymbolType = + inherit Type + + /// Returns the kind of this symbolic type + member Kind : SymbolKind + + /// Return the provided types used as arguments of this symbolic type + member Args : list + + +/// Helpers to build symbolic provided types +[] +type ProvidedTypeBuilder = + + /// Like typ.MakeGenericType, but will also work with unit-annotated types + static member MakeGenericType: genericTypeDefinition: Type * genericArguments: Type list -> Type + + /// Like methodInfo.MakeGenericMethod, but will also work with unit-annotated types and provided types + static member MakeGenericMethod: genericMethodDefinition: MethodInfo * genericArguments: Type list -> MethodInfo + +/// Helps create erased provided unit-of-measure annotations. +[] +type ProvidedMeasureBuilder = + + /// The ProvidedMeasureBuilder for building measures. + static member Default : ProvidedMeasureBuilder + + /// Gets the measure indicating the "1" unit of measure, that is the unitless measure. + member One : Type + + /// Returns the measure indicating the product of two units of measure, e.g. kg * m + member Product : measure1: Type * measure1: Type -> Type + + /// Returns the measure indicating the inverse of two units of measure, e.g. 1 / s + member Inverse : denominator: Type -> Type + + /// Returns the measure indicating the ratio of two units of measure, e.g. kg / m + member Ratio : numerator: Type * denominator: Type -> Type + + /// Returns the measure indicating the square of a unit of measure, e.g. m * m + member Square : ``measure``: Type -> Type + + /// Returns the measure for an SI unit from the F# core library, where the string is in capitals and US spelling, e.g. Meter + member SI : unitName:string -> Type + + /// Returns a type where the type has been annotated with the given types and/or units-of-measure. + /// e.g. float, Vector + member AnnotateType : basic: Type * argument: Type list -> Type + + +/// Represents a provided type definition. +type ProvidedTypeDefinition = + inherit Type + + /// Create a new provided type definition in a namespace. + new : assembly: Assembly * namespaceName: string * className: string * baseType: Type option -> ProvidedTypeDefinition + + /// Create a new provided type definition, to be located as a nested type in some type definition. + new : className : string * baseType: Type option -> ProvidedTypeDefinition + + /// Add the given type as an implemented interface. + member AddInterfaceImplementation : interfaceType: Type -> unit + + /// Add the given function as a set of on-demand computed interfaces. + member AddInterfaceImplementationsDelayed : interfacesFunction:(unit -> Type list)-> unit + + /// Specifies that the given method body implements the given method declaration. + member DefineMethodOverride : methodInfoBody: ProvidedMethod * methodInfoDeclaration: MethodInfo -> unit + + /// Add a 'System.Obsolete' attribute to this provided type definition + member AddObsoleteAttribute : message: string * ?isError: bool -> unit + + /// Add XML documentation information to this provided constructor + member AddXmlDoc : xmlDoc: string -> unit + + /// Set the base type + member SetBaseType : Type -> unit + + /// Set the base type to a lazily evaluated value. Use this to delay realization of the base type as late as possible. + member SetBaseTypeDelayed : baseTypeFunction:(unit -> Type) -> unit + + /// Set underlying type for generated enums + member SetEnumUnderlyingType : Type -> unit + + /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary. + /// The documentation is only computed once. + member AddXmlDocDelayed : xmlDocFunction: (unit -> string) -> unit + + /// Add XML documentation information to this provided constructor, where the computation of the documentation is delayed until necessary + /// The documentation is re-computed every time it is required. + member AddXmlDocComputed : xmlDocFunction: (unit -> string) -> unit + + /// Set the attributes on the provided type. This fully replaces the default TypeAttributes. + member SetAttributes : TypeAttributes -> unit + + /// Reset the enclosing type (for generated nested types) + member ResetEnclosingType: enclosingType:Type -> unit + + /// Add a method, property, nested type or other member to a ProvidedTypeDefinition + member AddMember : memberInfo:MemberInfo -> unit + + /// Add a set of members to a ProvidedTypeDefinition + member AddMembers : memberInfos:list<#MemberInfo> -> unit + + /// Add a member to a ProvidedTypeDefinition, delaying computation of the members until required by the compilation context. + member AddMemberDelayed : memberFunction:(unit -> #MemberInfo) -> unit + + /// Add a set of members to a ProvidedTypeDefinition, delaying computation of the members until required by the compilation context. + member AddMembersDelayed : membersFunction:(unit -> list<#MemberInfo>) -> unit + + /// Add the types of the generated assembly as generative types, where types in namespaces get hierarchically positioned as nested types. + member AddAssemblyTypesAsNestedTypesDelayed : assemblyFunction:(unit -> Assembly) -> unit + + /// Define the static parameters available on a statically parameterized type + member DefineStaticParameters : parameters: ProvidedStaticParameter list * instantiationFunction: (string -> obj[] -> ProvidedTypeDefinition) -> unit + + /// Add definition location information to the provided type definition. + member AddDefinitionLocation : line:int * column:int * filePath:string -> unit + + /// Suppress System.Object entries in intellisense menus in instances of this provided type + member HideObjectMethods : bool with set + + /// Disallows the use of the null literal. + member NonNullable : bool with set + + /// Get or set a flag indicating if the ProvidedTypeDefinition is erased + member IsErased : bool with get,set + + /// Get or set a flag indicating if the ProvidedTypeDefinition has type-relocation suppressed + [] + member SuppressRelocation : bool with get,set + + /// FSharp.Data addition: this method is used by Debug.fs + member MakeParametricType : name:string * args:obj[] -> ProvidedTypeDefinition + + /// Add a custom attribute to the provided type definition. + member AddCustomAttribute : CustomAttributeData -> unit + + /// Emulate the F# type provider type erasure mechanism to get the + /// actual (erased) type. We erase ProvidedTypes to their base type + /// and we erase array of provided type to array of base type. In the + /// case of generics all the generic type arguments are also recursively + /// replaced with the erased-to types + static member EraseType : typ:Type -> Type + + /// Get or set a utility function to log the creation of root Provided Type. Used to debug caching/invalidation. + static member Logger : (string -> unit) option ref + +/// A provided generated assembly +type ProvidedAssembly = + /// Create a provided generated assembly + new : assemblyFileName:string -> ProvidedAssembly + + /// Emit the given provided type definitions as part of the assembly + /// and adjust the 'Assembly' property of all provided type definitions to return that + /// assembly. + /// + /// The assembly is only emitted when the Assembly property on the root type is accessed for the first time. + /// The host F# compiler does this when processing a generative type declaration for the type. + member AddTypes : types : ProvidedTypeDefinition list -> unit + + /// + /// Emit the given nested provided type definitions as part of the assembly. + /// and adjust the 'Assembly' property of all provided type definitions to return that + /// assembly. + /// + /// A path of type names to wrap the generated types. The generated types are then generated as nested types. + member AddNestedTypes : types : ProvidedTypeDefinition list * enclosingGeneratedTypeNames: string list -> unit + +#if FX_NO_LOCAL_FILESYSTEM +#else + /// Register that a given file is a provided generated assembly + static member RegisterGenerated : fileName:string -> Assembly +#endif + + +/// A base type providing default implementations of type provider functionality when all provided +/// types are of type ProvidedTypeDefinition. +type TypeProviderForNamespaces = + + /// Initializes a type provider to provide the types in the given namespace. + new : namespaceName:string * types: ProvidedTypeDefinition list -> TypeProviderForNamespaces + + /// Initializes a type provider + new : unit -> TypeProviderForNamespaces + + /// Invoked by the type provider to add a namespace of provided types in the specification of the type provider. + member AddNamespace : namespaceName:string * types: ProvidedTypeDefinition list -> unit + + /// Invoked by the type provider to get all provided namespaces with their provided types. + member Namespaces : seq + + /// Invoked by the type provider to invalidate the information provided by the provider + member Invalidate : unit -> unit + + /// Invoked by the host of the type provider to get the static parameters for a method. + member GetStaticParametersForMethod : MethodBase -> ParameterInfo[] + + /// Invoked by the host of the type provider to apply the static argumetns for a method. + member ApplyStaticArgumentsForMethod : MethodBase * string * obj[] -> MethodBase + +#if FX_NO_LOCAL_FILESYSTEM +#else + /// AssemblyResolve handler. Default implementation searches .dll file in registered folders + abstract ResolveAssembly : System.ResolveEventArgs -> Assembly + default ResolveAssembly : System.ResolveEventArgs -> Assembly + + /// Registers custom probing path that can be used for probing assemblies + member RegisterProbingFolder : folder: string -> unit + + /// Registers location of RuntimeAssembly (from TypeProviderConfig) as probing folder + member RegisterRuntimeAssemblyLocationAsProbingFolder : config: TypeProviderConfig -> unit + +#endif + + [] + member Disposing : IEvent + + interface ITypeProvider diff --git a/tests/service/data/TestTP/TestTP.fsproj b/tests/service/data/TestTP/TestTP.fsproj new file mode 100644 index 00000000000..8ab4839481c --- /dev/null +++ b/tests/service/data/TestTP/TestTP.fsproj @@ -0,0 +1,72 @@ + + + + + Debug + AnyCPU + 2.0 + ff76bd3c-5e0a-4752-b6c3-044f6e15719b + Library + TestTP + TestTP + v4.5 + true + TestTP + ..\..\..\..\$(Configuration)\net40\bin + + + + true + full + false + false + DEBUG;TRACE + 3 + AnyCPU + bin\Debug\TestTP.xml + true + + + pdbonly + true + true + TRACE + 3 + AnyCPU + bin\Release\TestTP.xml + true + + + + + + + + + + + ..\..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + CSharp_Analysis + {887630a3-4b1d-40ea-b8b3-2d842e9c40db} + True + + + + + + + ..\..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/ToolsVersion12.fsproj b/tests/service/data/ToolsVersion12.fsproj new file mode 100644 index 00000000000..d10a0e5daa2 --- /dev/null +++ b/tests/service/data/ToolsVersion12.fsproj @@ -0,0 +1,58 @@ + + + + + Debug + AnyCPU + 2.0 + 00000000-0000-0000-0000-000000000002 + Exe + Main + Main + v4.5.1 + Main + + + true + full + false + false + bin + DEBUG;TRACE + 3 + AnyCPU + false + + + pdbonly + true + true + bin + TRACE + 3 + AnyCPU + false + + + + + + + + + + 11 + + + + + + + ..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/TypeProviderConsole/Program.fs b/tests/service/data/TypeProviderConsole/Program.fs new file mode 100644 index 00000000000..450b736fd6d --- /dev/null +++ b/tests/service/data/TypeProviderConsole/Program.fs @@ -0,0 +1,6 @@ +module Program + +[] +let main argv = + printfn "%A" argv + 0 // return an integer exit code diff --git a/tests/service/data/TypeProviderConsole/TypeProviderConsole.fsproj b/tests/service/data/TypeProviderConsole/TypeProviderConsole.fsproj new file mode 100644 index 00000000000..66475c20e0c --- /dev/null +++ b/tests/service/data/TypeProviderConsole/TypeProviderConsole.fsproj @@ -0,0 +1,70 @@ + + + + + Debug + AnyCPU + 2.0 + 39100933-24e2-4c64-9465-4996d3de52b2 + Exe + TypeProviderConsole + TypeProviderConsole + v4.5 + true + TypeProviderConsole + + + true + full + false + false + bin\Debug\ + DEBUG;TRACE + 3 + AnyCPU + bin\Debug\TypeProviderConsole.xml + true + + + pdbonly + true + true + bin\Release\ + TRACE + 3 + AnyCPU + bin\Release\TypeProviderConsole.xml + true + + + + + ..\..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + TypeProviderLibrary + {1da23607-c5ef-42b7-b9a7-692572ad1b7b} + True + + + + + + + + ..\..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/TypeProviderLibrary/FSharp.Core.dll b/tests/service/data/TypeProviderLibrary/FSharp.Core.dll new file mode 100644 index 00000000000..86b505d20c1 Binary files /dev/null and b/tests/service/data/TypeProviderLibrary/FSharp.Core.dll differ diff --git a/tests/service/data/TypeProviderLibrary/FSharp.Data.TypeProviders.dll b/tests/service/data/TypeProviderLibrary/FSharp.Data.TypeProviders.dll new file mode 100644 index 00000000000..bcec4d84167 Binary files /dev/null and b/tests/service/data/TypeProviderLibrary/FSharp.Data.TypeProviders.dll differ diff --git a/tests/service/data/TypeProviderLibrary/Library1.fs b/tests/service/data/TypeProviderLibrary/Library1.fs new file mode 100644 index 00000000000..e6fb2da6a6e --- /dev/null +++ b/tests/service/data/TypeProviderLibrary/Library1.fs @@ -0,0 +1,10 @@ +namespace TypeProviderLibrary + +open Microsoft.FSharp.Core.CompilerServices +open System + +[] +type FakeTypeProvider() = class end + +[] +do() diff --git a/tests/service/data/TypeProviderLibrary/TypeProviderLibrary.fsproj b/tests/service/data/TypeProviderLibrary/TypeProviderLibrary.fsproj new file mode 100644 index 00000000000..1176ffe801d --- /dev/null +++ b/tests/service/data/TypeProviderLibrary/TypeProviderLibrary.fsproj @@ -0,0 +1,59 @@ + + + + + Debug + AnyCPU + 2.0 + 1da23607-c5ef-42b7-b9a7-692572ad1b7b + Library + TypeProviderLibrary + TypeProviderLibrary + v4.5 + TypeProviderLibrary + + + true + full + false + false + .\ + DEBUG;TRACE + 3 + bin\Debug\TypeProviderLibrary.xml + + + pdbonly + true + true + .\ + TRACE + 3 + bin\Release\TypeProviderLibrary.xml + + + + + + ..\..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + + + + ..\..\..\..\packages\NUnit\lib\nunit.framework.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/sqlite-net-spike/Program.fs b/tests/service/data/sqlite-net-spike/Program.fs new file mode 100644 index 00000000000..7b92f756dd3 --- /dev/null +++ b/tests/service/data/sqlite-net-spike/Program.fs @@ -0,0 +1,49 @@ +open System + +open SQLite.Net +open SQLite.Net.Attributes +open SQLite.Net.Platform.Generic + +type Site (url:string) = + let mutable id = new int() + let mutable BD = "" + let mutable site = url + let mutable shown = false + let mutable exemplarcontributor = false + [] [] + member x.ID with get() = id + and set v = id <- v + member x.ExemplarContributor with get() = exemplarcontributor + and set v = exemplarcontributor <- v + member x.Shown with get() = shown + and set v = shown <- v + member x.BreakDown with get() = BD + and set v = BD <- v + [] + member x.Site with get() = site + and set v = site <- v + member x.Url = url + new() = Site "www.google.com" + +[] +type Site2 = + { id : int + visited : string + comment : string } + +type Database (path) = + inherit SQLiteConnection(new SQLitePlatformGeneric(), path) + member x.Setup() = + base.CreateTable() |> ignore + base.CreateTable() |> ignore + +[] +let main argv = + let D = new Database("test.sqlitedb") + D.Setup() |> ignore + + let s = new Site "www.google.com" + D.Insert(s) |> ignore + D.Commit|>ignore + 0 + diff --git a/tests/service/data/sqlite-net-spike/packages.config b/tests/service/data/sqlite-net-spike/packages.config new file mode 100644 index 00000000000..666cb7f0e7b --- /dev/null +++ b/tests/service/data/sqlite-net-spike/packages.config @@ -0,0 +1,5 @@ + + + + + \ No newline at end of file diff --git a/tests/service/data/sqlite-net-spike/paket.references b/tests/service/data/sqlite-net-spike/paket.references new file mode 100644 index 00000000000..4b717d31d2a --- /dev/null +++ b/tests/service/data/sqlite-net-spike/paket.references @@ -0,0 +1,2 @@ +SQLite.Net.Platform.Generic +SQLite.Net-PCL \ No newline at end of file diff --git a/tests/service/data/sqlite-net-spike/sqlite-net-spike.fsproj b/tests/service/data/sqlite-net-spike/sqlite-net-spike.fsproj new file mode 100644 index 00000000000..b49fa376391 --- /dev/null +++ b/tests/service/data/sqlite-net-spike/sqlite-net-spike.fsproj @@ -0,0 +1,94 @@ + + + + Debug + x86 + {BE87D723-5EAB-4B69-8F65-5EC072EF9E46} + Exe + sqlitenetspike + sqlite-net-spike + True + v4.5 + 8.0.30703 + 2.0 + + + true + false + bin\Debug + DEBUG + prompt + true + false + x86 + + + false + none + true + bin\Release + prompt + x86 + true + true + + + + + + + ..\..\..\..\$(Configuration)\net40\bin\FSharp.Core.dll + + + + + + + + + + + + + + + + + ..\..\..\..\packages\SQLite.Net-PCL\lib\net4\SQLite.Net.dll + True + True + + + ..\..\..\..\packages\SQLite.Net-PCL\lib\net4\SQLite.Net.Platform.Win32.dll + True + True + + + + + + + ..\..\..\..\packages\SQLite.Net-PCL\lib\portable-win81+wpa81\SQLite.Net.dll + True + True + + + ..\..\..\..\packages\SQLite.Net-PCL\lib\portable-win81+wpa81\SQLite.Net.Platform.WinRT.dll + True + True + + + + + + + + + ..\..\..\..\packages\SQLite.Net.Platform.Generic\lib\net40\SQLite.Net.Platform.Generic.dll + True + True + + + + + \ No newline at end of file diff --git a/tests/service/data/testscript.fsx b/tests/service/data/testscript.fsx new file mode 100644 index 00000000000..3b0c82647f2 --- /dev/null +++ b/tests/service/data/testscript.fsx @@ -0,0 +1 @@ +let x = 1 \ No newline at end of file diff --git a/vsintegration/Utils/LanguageServiceProfiling/AssemblyInfo.fs b/vsintegration/Utils/LanguageServiceProfiling/AssemblyInfo.fs index 0e1ae791278..f67c0c9e9b4 100644 --- a/vsintegration/Utils/LanguageServiceProfiling/AssemblyInfo.fs +++ b/vsintegration/Utils/LanguageServiceProfiling/AssemblyInfo.fs @@ -24,18 +24,5 @@ open System.Runtime.InteropServices // The following GUID is for the ID of the typelib if this project is exposed to COM [] -// Version information for an assembly consists of the following four values: -// -// Major Version -// Minor Version -// Build Number -// Revision -// -// You can specify all the values or you can default the Build and Revision Numbers -// by using the '*' as shown below: -// [] -[] -[] -[] do () \ No newline at end of file diff --git a/vsintegration/Utils/LanguageServiceProfiling/Options.fs b/vsintegration/Utils/LanguageServiceProfiling/Options.fs index c7289902d46..28664f0d0d3 100644 --- a/vsintegration/Utils/LanguageServiceProfiling/Options.fs +++ b/vsintegration/Utils/LanguageServiceProfiling/Options.fs @@ -170,12 +170,12 @@ let FCS (repositoryDir: string) : Options = @"src\fsharp\vs\Reactor.fsi" @"src\fsharp\vs\Reactor.fs" @"src\fsharp\vs\ServiceConstants.fs" - @"src\fsharp\vs\ServiceDeclarations.fsi" - @"src\fsharp\vs\ServiceDeclarations.fs" - @"src\fsharp\vs\Symbols.fsi" - @"src\fsharp\vs\Symbols.fs" - @"src\fsharp\vs\Exprs.fsi" - @"src\fsharp\vs\Exprs.fs" + @"src\fsharp\symbols\SymbolHelpers.fsi" + @"src\fsharp\symbols\SymbolHelpers.fs" + @"src\fsharp\symbols\Symbols.fsi" + @"src\fsharp\symbols\Symbols.fs" + @"src\fsharp\symbols\Exprs.fsi" + @"src\fsharp\symbols\Exprs.fs" @"src\fsharp\vs\ServiceLexing.fsi" @"src\fsharp\vs\ServiceLexing.fs" @"src\fsharp\vs\ServiceParseTreeWalk.fs" @@ -208,8 +208,8 @@ let FCS (repositoryDir: string) : Options = @"--define:FX_LCIDFROMCODEPAGE"; "--define:FX_RESX_RESOURCE_READER"; @"--define:FX_RESIDENT_COMPILER"; "--define:SHADOW_COPY_REFERENCES"; @"--define:EXTENSIONTYPING"; - @"--define:COMPILER_SERVICE_ASSUMES_FSHARP_CORE_4_4_0_0"; - @"--define:COMPILER_SERVICE"; "--define:NO_STRONG_NAMES"; "--define:TRACE"; + @"--define:COMPILER_SERVICE_DLL_ASSUMES_FSHARP_CORE_4_4_0_0"; + @"--define:COMPILER_SERVICE_DLL"; "--define:NO_STRONG_NAMES"; "--define:TRACE"; @"--doc:..\..\..\bin\v4.5\FSharp.Compiler.Service.xml"; "--optimize-"; @"--platform:anycpu"; @"-r:" + (repositoryDir @"packages\Microsoft.DiaSymReader\lib\net20\Microsoft.DiaSymReader.dll"); diff --git a/vsintegration/Utils/LanguageServiceProfiling/ProjectCracker.fs b/vsintegration/Utils/LanguageServiceProfiling/ProjectCracker.fs index 23fde5a7806..119fdc9317b 100644 --- a/vsintegration/Utils/LanguageServiceProfiling/ProjectCracker.fs +++ b/vsintegration/Utils/LanguageServiceProfiling/ProjectCracker.fs @@ -1,567 +1,2 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices.ProjectCrackerTool -//#if !NETSTANDARD1_6 -//open System.Runtime.Serialization.Json -//open System.Runtime -//open System.Diagnostics -//#endif -//open System.Text -//open System.IO -//open System -//open System.Reflection -//open Microsoft.FSharp.Compiler.SourceCodeServices - -//[] -//type ProjectOptions = -// { ProjectFile: string -// Options: string[] -// ReferencedProjectOptions: (string * ProjectOptions)[] -// LogOutput: string } - -//open System.Text -//open Microsoft.Build.Framework -//open Microsoft.Build.Utilities - -//module internal ProjectCrackerTool = - -// let runningOnMono = -//#if DOTNETCORE -// false -//#else -// try match System.Type.GetType("Mono.Runtime") with null -> false | _ -> true -// with e -> false -//#endif - -// type internal BasicStringLogger() = -// inherit Logger() - -// let sb = new StringBuilder() - -// let log (e: BuildEventArgs) = -// sb.Append(e.Message) |> ignore -// sb.AppendLine() |> ignore - -// override x.Initialize(eventSource:IEventSource) = -// sb.Clear() |> ignore -// eventSource.AnyEventRaised.Add(log) - -// member x.Log = sb.ToString() - -// type internal HostCompile() = -// member th.Compile(_:obj, _:obj, _:obj) = 0 -// interface ITaskHost - -// //---------------------------------------------------------------------------- -// // FSharpProjectFileInfo -// // -// [] -// type FSharpProjectFileInfo (fsprojFileName:string, ?properties, ?enableLogging) = - -// let properties = defaultArg properties [] -// let enableLogging = defaultArg enableLogging false -// let mkAbsolute dir v = -// if Path.IsPathRooted v then v -// else Path.Combine(dir, v) - -// let logOpt = -// if enableLogging then -// let log = new BasicStringLogger() -// do log.Verbosity <- Microsoft.Build.Framework.LoggerVerbosity.Diagnostic -// Some log -// else -// None - -//#if !DOTNETCORE -// let mkAbsoluteOpt dir v = Option.map (mkAbsolute dir) v - -// let CrackProjectUsingOldBuildAPI(fsprojFile:string) = -// let engine = new Microsoft.Build.Evaluation.ProjectCollection() -// Option.iter (fun l -> engine.RegisterLogger(l)) logOpt - -// engine.SetGlobalProperty("BuildingInsideVisualStudio", "true") - -// for (prop, value) in properties do -// engine.SetGlobalProperty(prop, value) - -// let projectFromFile (fsprojFile:string) = -// // We seem to need to pass 12.0/4.0 in here for some unknown reason -// engine.LoadProject(fsprojFile, engine.DefaultToolsVersion) - -// let project = projectFromFile fsprojFile -// project.Build([| "ResolveReferences" |]) |> ignore -// let directory = Path.GetDirectoryName project.FullPath - -// let getProp (p: Microsoft.Build.Evaluation.Project) s = -// let v = p.GetPropertyValue s -// if String.IsNullOrWhiteSpace v then None -// else Some v - -// let outFileOpt = -// match mkAbsoluteOpt directory (getProp project "OutDir") with -// | None -> None -// | Some d -> mkAbsoluteOpt d (getProp project "TargetFileName") - -// let getItems s = -// let fs = project.GetItems(s) -// [ for f in fs -> mkAbsolute directory f.EvaluatedInclude ] - -// let projectReferences = -// [ for i in project.GetItems("ProjectReference") do -// yield mkAbsolute directory i.EvaluatedInclude -// ] - -// let references = -// [ for i in project.GetItems("ReferencePath") do -// yield i.EvaluatedInclude -// for i in project.GetItems("ChildProjectReferences") do -// yield i.EvaluatedInclude ] -// // Duplicate slashes sometimes appear in the output here, which prevents -// // them from matching keys used in FSharpProjectOptions.ReferencedProjects -// |> List.map (fun (s: string) -> s.Replace("//","/")) - -// outFileOpt, directory, getItems, references, projectReferences, getProp project, project.FullPath -//#endif - -// let vs = -// let programFiles = -// let getEnv v = -// let result = System.Environment.GetEnvironmentVariable(v) -// match result with -// | null -> None -// | _ -> Some result - -// match List.tryPick getEnv [ "ProgramFiles(x86)"; "ProgramFiles" ] with -// | Some r -> r -// | None -> "C:\\Program Files (x86)" - -// let vsVersions = ["14.0"; "12.0"] -// let msbuildBin v = IO.Path.Combine(programFiles, "MSBuild", v, "Bin", "MSBuild.exe") -// List.tryFind (fun v -> IO.File.Exists(msbuildBin v)) vsVersions - -// let CrackProjectUsingNewBuildAPI(fsprojFile) = -// let fsprojFullPath = try Path.GetFullPath(fsprojFile) with _ -> fsprojFile -// let fsprojAbsDirectory = Path.GetDirectoryName fsprojFullPath - -// use _pwd = -// let dir = Directory.GetCurrentDirectory() -// Directory.SetCurrentDirectory(fsprojAbsDirectory) -// { new System.IDisposable with -// member x.Dispose() = Directory.SetCurrentDirectory(dir) } -// use engine = new Microsoft.Build.Evaluation.ProjectCollection() -// let host = new HostCompile() -// engine.HostServices.RegisterHostObject(fsprojFullPath, "CoreCompile", "Fsc", host) - - -// let projectInstanceFromFullPath (fsprojFullPath: string) = -// use file = new FileStream(fsprojFullPath, FileMode.Open, FileAccess.Read, FileShare.Read) -// use stream = new StreamReader(file) -// use xmlReader = System.Xml.XmlReader.Create(stream) - -// let project = engine.LoadProject(xmlReader, FullPath=fsprojFullPath) - -// project.SetGlobalProperty("BuildingInsideVisualStudio", "true") |> ignore -// if not (List.exists (fun (p,_) -> p = "VisualStudioVersion") properties) then -// match vs with -// | Some version -> project.SetGlobalProperty("VisualStudioVersion", version) |> ignore -// | None -> () -// project.SetGlobalProperty("ShouldUnsetParentConfigurationAndPlatform", "false") |> ignore -// for (prop, value) in properties do -// project.SetGlobalProperty(prop, value) |> ignore - -// project.CreateProjectInstance() - -// let project = projectInstanceFromFullPath fsprojFullPath -// let directory = project.Directory - -// let getprop (p: Microsoft.Build.Execution.ProjectInstance) s = -// let v = p.GetPropertyValue s -// if String.IsNullOrWhiteSpace v then None -// else Some v - -// let outFileOpt = getprop project "TargetPath" - -// let log = match logOpt with -// | None -> [] -// | Some l -> [l :> ILogger] - -// project.Build([| "Build" |], log) |> ignore - -// let getItems s = [ for f in project.GetItems(s) -> mkAbsolute directory f.EvaluatedInclude ] - -// let projectReferences = -// [ for cp in project.GetItems("ProjectReference") do -// yield cp.GetMetadataValue("FullPath") -// ] - -// let references = -// [ for i in project.GetItems("ReferencePath") do -// yield i.EvaluatedInclude -// for i in project.GetItems("ChildProjectReferences") do -// yield i.EvaluatedInclude ] - -// outFileOpt, directory, getItems, references, projectReferences, getprop project, project.FullPath - -// let outFileOpt, directory, getItems, references, projectReferences, getProp, fsprojFullPath = -// try -//#if DOTNETCORE -// CrackProjectUsingNewBuildAPI(fsprojFileName) -// with -//#else -// if runningOnMono then -// CrackProjectUsingOldBuildAPI(fsprojFileName) -// else -// CrackProjectUsingNewBuildAPI(fsprojFileName) -// with -// | :? Microsoft.Build.BuildEngine.InvalidProjectFileException as e -> -// raise (Microsoft.Build.Exceptions.InvalidProjectFileException( -// e.ProjectFile, -// e.LineNumber, -// e.ColumnNumber, -// e.EndLineNumber, -// e.EndColumnNumber, -// e.Message, -// e.ErrorSubcategory, -// e.ErrorCode, -// e.HelpKeyword)) -//#endif -// | :? ArgumentException as e -> raise (IO.FileNotFoundException(e.Message)) - -// let logOutput = match logOpt with None -> "" | Some l -> l.Log -// let pages = getItems "Page" -// let embeddedResources = getItems "EmbeddedResource" -// let files = getItems "Compile" -// let resources = getItems "Resource" -// let noaction = getItems "None" -// let content = getItems "Content" - -// let split (s : string option) (cs : char []) = -// match s with -// | None -> [||] -// | Some s -> -// if String.IsNullOrWhiteSpace s then [||] -// else s.Split(cs, StringSplitOptions.RemoveEmptyEntries) - -// let getbool (s : string option) = -// match s with -// | None -> false -// | Some s -> -// match (Boolean.TryParse s) with -// | (true, result) -> result -// | (false, _) -> false - -// let fxVer = getProp "TargetFrameworkVersion" -// let optimize = getProp "Optimize" |> getbool -// let assemblyNameOpt = getProp "AssemblyName" -// let tailcalls = getProp "Tailcalls" |> getbool -// let outputPathOpt = getProp "OutputPath" -// let docFileOpt = getProp "DocumentationFile" -// let outputTypeOpt = getProp "OutputType" -// let debugTypeOpt = getProp "DebugType" -// let baseAddressOpt = getProp "BaseAddress" -// let sigFileOpt = getProp "GenerateSignatureFile" -// let keyFileOpt = getProp "KeyFile" -// let pdbFileOpt = getProp "PdbFile" -// let platformOpt = getProp "Platform" -// let targetTypeOpt = getProp "TargetType" -// let versionFileOpt = getProp "VersionFile" -// let targetProfileOpt = getProp "TargetProfile" -// let warnLevelOpt = getProp "Warn" -// let subsystemVersionOpt = getProp "SubsystemVersion" -// let win32ResOpt = getProp "Win32ResourceFile" -// let heOpt = getProp "HighEntropyVA" |> getbool -// let win32ManifestOpt = getProp "Win32ManifestFile" -// let debugSymbols = getProp "DebugSymbols" |> getbool -// let prefer32bit = getProp "Prefer32Bit" |> getbool -// let warnAsError = getProp "TreatWarningsAsErrors" |> getbool -// let defines = split (getProp "DefineConstants") [| ';'; ','; ' ' |] -// let nowarn = split (getProp "NoWarn") [| ';'; ','; ' ' |] -// let warningsAsError = split (getProp "WarningsAsErrors") [| ';'; ','; ' ' |] -// let libPaths = split (getProp "ReferencePath") [| ';'; ',' |] -// let otherFlags = split (getProp "OtherFlags") [| ' ' |] -// let isLib = (outputTypeOpt = Some "Library") - -// let docFileOpt = -// match docFileOpt with -// | None -> None -// | Some docFile -> Some(mkAbsolute directory docFile) - - -// let options = -// [ yield "--simpleresolution" -// yield "--noframework" -// match outFileOpt with -// | None -> () -// | Some outFile -> yield "--out:" + outFile -// match docFileOpt with -// | None -> () -// | Some docFile -> yield "--doc:" + docFile -// match baseAddressOpt with -// | None -> () -// | Some baseAddress -> yield "--baseaddress:" + baseAddress -// match keyFileOpt with -// | None -> () -// | Some keyFile -> yield "--keyfile:" + keyFile -// match sigFileOpt with -// | None -> () -// | Some sigFile -> yield "--sig:" + sigFile -// match pdbFileOpt with -// | None -> () -// | Some pdbFile -> yield "--pdb:" + pdbFile -// match versionFileOpt with -// | None -> () -// | Some versionFile -> yield "--versionfile:" + versionFile -// match warnLevelOpt with -// | None -> () -// | Some warnLevel -> yield "--warn:" + warnLevel -// match subsystemVersionOpt with -// | None -> () -// | Some s -> yield "--subsystemversion:" + s -// if heOpt then yield "--highentropyva+" -// match win32ResOpt with -// | None -> () -// | Some win32Res -> yield "--win32res:" + win32Res -// match win32ManifestOpt with -// | None -> () -// | Some win32Manifest -> yield "--win32manifest:" + win32Manifest -// match targetProfileOpt with -// | None -> () -// | Some targetProfile -> yield "--targetprofile:" + targetProfile -// yield "--fullpaths" -// yield "--flaterrors" -// if warnAsError then yield "--warnaserror" -// yield -// if isLib then "--target:library" -// else "--target:exe" -// for symbol in defines do -// if not (String.IsNullOrWhiteSpace symbol) then yield "--define:" + symbol -// for nw in nowarn do -// if not (String.IsNullOrWhiteSpace nw) then yield "--nowarn:" + nw -// for nw in warningsAsError do -// if not (String.IsNullOrWhiteSpace nw) then yield "--warnaserror:" + nw -// yield if debugSymbols then "--debug+" -// else "--debug-" -// yield if optimize then "--optimize+" -// else "--optimize-" -// yield if tailcalls then "--tailcalls+" -// else "--tailcalls-" -// match debugTypeOpt with -// | None -> () -// | Some debugType -> -// match debugType.ToUpperInvariant() with -// | "NONE" -> () -// | "PDBONLY" -> yield "--debug:pdbonly" -// | "FULL" -> yield "--debug:full" -// | _ -> () -// match platformOpt |> Option.map (fun o -> o.ToUpperInvariant()), prefer32bit, -// targetTypeOpt |> Option.map (fun o -> o.ToUpperInvariant()) with -// | Some "ANYCPU", true, Some "EXE" | Some "ANYCPU", true, Some "WINEXE" -> yield "--platform:anycpu32bitpreferred" -// | Some "ANYCPU", _, _ -> yield "--platform:anycpu" -// | Some "X86", _, _ -> yield "--platform:x86" -// | Some "X64", _, _ -> yield "--platform:x64" -// | Some "ITANIUM", _, _ -> yield "--platform:Itanium" -// | _ -> () -// match targetTypeOpt |> Option.map (fun o -> o.ToUpperInvariant()) with -// | Some "LIBRARY" -> yield "--target:library" -// | Some "EXE" -> yield "--target:exe" -// | Some "WINEXE" -> yield "--target:winexe" -// | Some "MODULE" -> yield "--target:module" -// | _ -> () -// yield! otherFlags -// for f in resources do -// yield "--resource:" + f -// for i in libPaths do -// yield "--lib:" + mkAbsolute directory i -// for r in references do -// yield "-r:" + r -// yield! files ] - -// member x.Options = options -// member x.FrameworkVersion = fxVer -// member x.ProjectReferences = projectReferences -// member x.References = references -// member x.CompileFiles = files -// member x.ResourceFiles = resources -// member x.EmbeddedResourceFiles = embeddedResources -// member x.ContentFiles = content -// member x.OtherFiles = noaction -// member x.PageFiles = pages -// member x.OutputFile = outFileOpt -// member x.Directory = directory -// member x.AssemblyName = assemblyNameOpt -// member x.OutputPath = outputPathOpt -// member x.FullPath = fsprojFullPath -// member x.LogOutput = logOutput -// static member Parse(fsprojFileName:string, ?properties, ?enableLogging) = new FSharpProjectFileInfo(fsprojFileName, ?properties=properties, ?enableLogging=enableLogging) - -// let getOptions file enableLogging properties = -// let rec getOptions file : Option * ProjectOptions = -// let parsedProject = FSharpProjectFileInfo.Parse(file, properties=properties, enableLogging=enableLogging) -// let referencedProjectOptions = -// [| for file in parsedProject.ProjectReferences do -// if Path.GetExtension(file) = ".fsproj" then -// match getOptions file with -// | Some outFile, opts -> yield outFile, opts -// | None, _ -> () |] - -// // Workaround for Mono 4.2, which doesn't populate the subproject -// // details anymore outside of a solution context. See https://github.com/mono/mono/commit/76c6a08e730393927b6851709cdae1d397cbcc3a#diff-59afd196a55d61d5d1eaaef7bd49d1e5 -// // and some explanation from the author at https://github.com/fsharp/FSharp.Compiler.Service/pull/455#issuecomment-154103963 -// // -// // In particular we want the output path, which we can get from -// // fully parsing that project itself. We also have to specially parse -// // C# referenced projects, as we don't look at them otherwise. -// let referencedProjectOutputs = -// if runningOnMono then -// [ yield! Array.map (fun (s,_) -> "-r:" + s) referencedProjectOptions -// for file in parsedProject.ProjectReferences do -// let ext = Path.GetExtension(file) -// if ext = ".csproj" || ext = ".vbproj" then -// let parsedProject = FSharpProjectFileInfo.Parse(file, properties=properties, enableLogging=false) -// match parsedProject.OutputFile with -// | None -> () -// | Some f -> yield "-r:" + f ] -// else -// [] - -// // On some versions of Mono the referenced projects are already -// // correctly included, so we make sure not to introduce duplicates -// |> List.filter (fun r -> not (Set.contains r (set parsedProject.Options))) - -// let options = { ProjectFile = file -// Options = Array.ofSeq (parsedProject.Options @ referencedProjectOutputs) -// ReferencedProjectOptions = referencedProjectOptions -// LogOutput = parsedProject.LogOutput } - -// parsedProject.OutputFile, options - -// snd (getOptions file) - -//#if !DOTNETCORE -// let addMSBuildv14BackupResolution () = -// let onResolveEvent = new ResolveEventHandler(fun sender evArgs -> -// let requestedAssembly = AssemblyName(evArgs.Name) -// if requestedAssembly.Name.StartsWith("Microsoft.Build") && -// not (requestedAssembly.Name.EndsWith(".resources")) then -// // If the version of MSBuild that we're using wasn't present on the machine, then -// // just revert back to 12.0.0.0 since that's normally installed as part of the .NET -// // Framework. -// requestedAssembly.Version <- Version("12.0.0.0") -// Assembly.Load (requestedAssembly) -// else -// null) -// AppDomain.CurrentDomain.add_AssemblyResolve(onResolveEvent) -//#endif - -// let rec pairs l = -// match l with -// | [] | [_] -> [] -// | x::y::rest -> (x,y) :: pairs rest - -// let crackOpen (argv: string[])= -// if argv.Length >= 2 then -// let projectFile = argv.[0] -// let enableLogging = match Boolean.TryParse(argv.[1]) with -// | true, true -> true -// | _ -> false -// try -//#if !DOTNETCORE -// addMSBuildv14BackupResolution () -//#endif -// let props = pairs (List.ofArray argv.[2..]) -// let opts = getOptions argv.[0] enableLogging props -// 0, opts -// with e -> -// 2, { ProjectFile = projectFile; -// Options = [||]; -// ReferencedProjectOptions = [||]; -// LogOutput = e.ToString() } -// else -// 1, { ProjectFile = ""; -// Options = [||]; -// ReferencedProjectOptions = [||]; -// LogOutput = "At least two arguments required." } - -//type internal ProjectCracker = -// static member GetProjectOptionsFromProjectFileLogged(projectFileName : string, ?properties : (string * string) list, ?loadedTimeStamp, ?enableLogging) = -// let loadedTimeStamp = defaultArg loadedTimeStamp DateTime.MaxValue // Not 'now', we don't want to force reloading -// let properties = defaultArg properties [] -// let enableLogging = defaultArg enableLogging true -// let logMap = ref Map.empty - -// let rec convert (opts: ProjectOptions) : FSharpProjectOptions = -// let referencedProjects = Array.map (fun (a, b) -> a, convert b) opts.ReferencedProjectOptions - -// let sourceFiles, otherOptions = -// opts.Options |> Array.partition (fun x -> Path.GetExtension(x).ToLower() = ".fs") - -// let sepChar = Path.DirectorySeparatorChar - -// let sourceFiles = sourceFiles |> Array.map (fun x -> -// match sepChar with -// | '\\' -> x.Replace('/', '\\') -// | '/' -> x.Replace('\\', '/') -// | _ -> x -// ) - -// logMap := Map.add opts.ProjectFile opts.LogOutput !logMap -// { ProjectFileName = opts.ProjectFile -// ProjectFileNames = sourceFiles -// OtherOptions = otherOptions -// ReferencedProjects = referencedProjects -// IsIncompleteTypeCheckEnvironment = false -// UseScriptResolutionRules = false -// LoadTime = loadedTimeStamp -// UnresolvedReferences = None -// OriginalLoadReferences = [] -// ExtraProjectInfo = None } - -//#if NETSTANDARD1_6 -// let arguments = [| -// yield projectFileName -// yield enableLogging.ToString() -// for k, v in properties do -// yield k -// yield v -// |] - -// let ret, opts = Microsoft.FSharp.Compiler.SourceCodeServices.ProjectCrackerTool.ProjectCrackerTool.crackOpen arguments -// ignore ret -//#else -// //let arguments = new StringBuilder() -// //arguments.Append('"').Append(projectFileName).Append('"') |> ignore -// //arguments.Append(' ').Append(enableLogging.ToString()) |> ignore - -// //for k, v in properties do -// // arguments.Append(' ').Append(k).Append(' ').Append(v) |> ignore - -// //let crackerFilename = -// // Path.Combine(Path.GetDirectoryName(Assembly.GetExecutingAssembly().Location), -// // @"..\..\..\..\..\packages\FSharp.Compiler.Service.ProjectCracker.9.0.1\utilities\net45\FSharp.Compiler.Service.ProjectCrackerTool.exe") - -// //if not (File.Exists crackerFilename) then failwithf "ProjectCracker exe not found at: %s." crackerFilename -// //let p = new Process() -// //p.StartInfo.FileName <- crackerFilename -// //p.StartInfo.Arguments <- arguments.ToString() -// //p.StartInfo.UseShellExecute <- false -// //p.StartInfo.CreateNoWindow <- true -// //p.StartInfo.RedirectStandardOutput <- true -// //ignore <| p.Start() - -// //let json = p.StandardOutput.ReadToEnd() -// //printfn "Got JSON: %A" json - -// //let ser = new DataContractJsonSerializer(typeof) -// //let json = ser.ReadObject(p.StandardOutput.BaseStream) -// //let opts = json :?> ProjectOptions -// let opts = ProjectCrackerTool.getOptions projectFileName true properties -//#endif - -// convert opts, !logMap - -// static member GetProjectOptionsFromProjectFile(projectFileName : string, ?properties : (string * string) list, ?loadedTimeStamp) = -// fst (ProjectCracker.GetProjectOptionsFromProjectFileLogged( -// projectFileName, -// ?properties=properties, -// ?loadedTimeStamp=loadedTimeStamp, -// enableLogging=false)) - diff --git a/vsintegration/Vsix/VisualFSharpFull/VisualFSharpFull.csproj b/vsintegration/Vsix/VisualFSharpFull/VisualFSharpFull.csproj index 33247d44ddf..a2f19acd75f 100644 --- a/vsintegration/Vsix/VisualFSharpFull/VisualFSharpFull.csproj +++ b/vsintegration/Vsix/VisualFSharpFull/VisualFSharpFull.csproj @@ -11,7 +11,6 @@ 15.0 2.0 - true {82b43b9b-a64c-4715-b499-d71e9ca2bd60};{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC} @@ -145,16 +144,16 @@ DebugSymbolsProjectOutputGroup%3b True - + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B} - fsiAnyCpu + FsiAnyCPU BuiltProjectOutputGroup%3bGetCopyToOutputDirectoryItems%3bSatelliteDllsProjectOutputGroup%3b DebugSymbolsProjectOutputGroup%3b True - + {D0E98C0D-490B-4C61-9329-0862F6E87645} - fsi + Fsi BuiltProjectOutputGroup%3bGetCopyToOutputDirectoryItems%3bSatelliteDllsProjectOutputGroup%3b DebugSymbolsProjectOutputGroup%3b True diff --git a/vsintegration/Vsix/VisualFSharpOpenSource/VisualFSharpOpenSource.csproj b/vsintegration/Vsix/VisualFSharpOpenSource/VisualFSharpOpenSource.csproj index 80b1705ac3b..321026e0008 100644 --- a/vsintegration/Vsix/VisualFSharpOpenSource/VisualFSharpOpenSource.csproj +++ b/vsintegration/Vsix/VisualFSharpOpenSource/VisualFSharpOpenSource.csproj @@ -11,7 +11,6 @@ 15.0 2.0 - true {82b43b9b-a64c-4715-b499-d71e9ca2bd60};{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC} @@ -144,16 +143,16 @@ DebugSymbolsProjectOutputGroup%3b True - + {8B3E283D-B5FE-4055-9D80-7E3A32F3967B} - fsiAnyCpu + FsiAnyCPU BuiltProjectOutputGroup%3bGetCopyToOutputDirectoryItems%3bSatelliteDllsProjectOutputGroup%3b DebugSymbolsProjectOutputGroup%3b True - + {D0E98C0D-490B-4C61-9329-0862F6E87645} - fsi + Fsi BuiltProjectOutputGroup%3bGetCopyToOutputDirectoryItems%3bSatelliteDllsProjectOutputGroup%3b DebugSymbolsProjectOutputGroup%3b True diff --git a/vsintegration/fsharp-vsintegration-unittests-build.proj b/vsintegration/fsharp-vsintegration-unittests-build.proj index 0a5f471c410..678830c9da0 100644 --- a/vsintegration/fsharp-vsintegration-unittests-build.proj +++ b/vsintegration/fsharp-vsintegration-unittests-build.proj @@ -7,6 +7,8 @@ + + diff --git a/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj b/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj index 1bcd20d077f..35c9885a2a5 100644 --- a/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj +++ b/vsintegration/src/FSharp.Editor/FSharp.Editor.fsproj @@ -4,7 +4,7 @@ $(MSBuildProjectDirectory)\..\..\..\src FSharp - true + true diff --git a/vsintegration/src/FSharp.LanguageService.Base/FSharp.LanguageService.Base.csproj b/vsintegration/src/FSharp.LanguageService.Base/FSharp.LanguageService.Base.csproj index c23c7cc0b37..a8796e7c037 100644 --- a/vsintegration/src/FSharp.LanguageService.Base/FSharp.LanguageService.Base.csproj +++ b/vsintegration/src/FSharp.LanguageService.Base/FSharp.LanguageService.Base.csproj @@ -4,7 +4,6 @@ $(MSBuildProjectDirectory)\..\..\..\src CSharp - true 15.4.1.0 cs @@ -23,7 +22,6 @@ $(NoWarn);3001,3002,3003 $(DefineConstants);UITHREAD_FOR_LANGUAGESERVICE v4.6 - $(DefineConstants);FSHARP_CORE_4_5 true diff --git a/vsintegration/src/FSharp.LanguageService/FSharp.LanguageService.fsproj b/vsintegration/src/FSharp.LanguageService/FSharp.LanguageService.fsproj index 7c5e24f0070..11ed5ee2deb 100644 --- a/vsintegration/src/FSharp.LanguageService/FSharp.LanguageService.fsproj +++ b/vsintegration/src/FSharp.LanguageService/FSharp.LanguageService.fsproj @@ -3,10 +3,11 @@ $(MSBuildProjectDirectory)\..\..\..\src + true FSharp - true v4.6 true + true false false true @@ -26,7 +27,6 @@ LIBRARY false $(OtherFlags) --warnon:1182 --subsystemversion:6.00 - true diff --git a/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectSystem.Base.csproj b/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectSystem.Base.csproj index 7f126918701..49bc816091e 100644 --- a/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectSystem.Base.csproj +++ b/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectSystem.Base.csproj @@ -4,7 +4,6 @@ $(MSBuildProjectDirectory)\..\..\..\..\src CSharp - true 11 3001,3002,3003,3005,3008,3009,3021,3024 15.4.1.0 @@ -23,7 +22,6 @@ $(DefineConstants);CODE_ANALYSIS true v4.6 - $(DefineConstants);FSHARP_CORE_4_5 $(DefineConstants);FX_PREFERRED_UI_LANG diff --git a/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectSystem.fsproj b/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectSystem.fsproj index fbc8310a180..a7fdea92ebe 100644 --- a/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectSystem.fsproj +++ b/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectSystem.fsproj @@ -3,9 +3,8 @@ $(MSBuildProjectDirectory)\..\..\..\src + true FSharp - true - 11 diff --git a/vsintegration/src/FSharp.ProjectSystem.PropertyPages/FSharp.PropertiesPages.vbproj b/vsintegration/src/FSharp.ProjectSystem.PropertyPages/FSharp.PropertiesPages.vbproj index 64b38da0b9c..9ba9df97d57 100644 --- a/vsintegration/src/FSharp.ProjectSystem.PropertyPages/FSharp.PropertiesPages.vbproj +++ b/vsintegration/src/FSharp.ProjectSystem.PropertyPages/FSharp.PropertiesPages.vbproj @@ -4,7 +4,6 @@ $(MSBuildProjectDirectory)\..\..\..\src VisualBasic - true 15.4.1.0 vb @@ -33,7 +32,6 @@ true v4.6 - $(DefineConstants),FSHARP_CORE_4_5=True true diff --git a/vsintegration/src/FSharp.UIResources/FSharp.UIResources.csproj b/vsintegration/src/FSharp.UIResources/FSharp.UIResources.csproj index 1acd2e1c269..5f2afe63a34 100644 --- a/vsintegration/src/FSharp.UIResources/FSharp.UIResources.csproj +++ b/vsintegration/src/FSharp.UIResources/FSharp.UIResources.csproj @@ -4,7 +4,6 @@ $(MSBuildProjectDirectory)\..\..\..\src CSharp - true 15.4.1.0 cs @@ -22,7 +21,6 @@ true $(DefineConstants) v4.6 - $(DefineConstants);FSHARP_CORE_4_5 true diff --git a/vsintegration/src/FSharp.VS.FSI/FSHarp.VS.FSI.fsproj b/vsintegration/src/FSharp.VS.FSI/FSHarp.VS.FSI.fsproj index f1c22d7a48b..c91751f6666 100644 --- a/vsintegration/src/FSharp.VS.FSI/FSHarp.VS.FSI.fsproj +++ b/vsintegration/src/FSharp.VS.FSI/FSHarp.VS.FSI.fsproj @@ -4,9 +4,8 @@ $(MSBuildProjectDirectory)\..\..\..\src FSharp - true - 11 FSharp.VS.FSI + true diff --git a/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj b/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj index 322bdadb67a..2655b9f6083 100644 --- a/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj +++ b/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj @@ -4,7 +4,6 @@ $(MSBuildProjectDirectory)\..\..\..\src FSharp - true VisualFSharp.Salsa diff --git a/vsintegration/tests/Salsa/salsa.fs b/vsintegration/tests/Salsa/salsa.fs index cf7f9462dd7..51a0625e40b 100644 --- a/vsintegration/tests/Salsa/salsa.fs +++ b/vsintegration/tests/Salsa/salsa.fs @@ -1550,8 +1550,8 @@ module internal Salsa = member ops.CleanUp vs = VsImpl(vs).CleanUp() member ops.ClearLanguageServiceRootCachesAndCollectAndFinalizeAllTransients vs = VsImpl(vs).ClearLanguageServiceRootCachesAndCollectAndFinalizeAllTransients() member ops.AutoCompleteMemberDataTipsThrowsScope message = - ItemDescriptionsImpl.ToolTipFault <- Some message - { new System.IDisposable with member x.Dispose() = ItemDescriptionsImpl.ToolTipFault <- None } + SymbolHelpers.ToolTipFault <- Some message + { new System.IDisposable with member x.Dispose() = SymbolHelpers.ToolTipFault <- None } member ops.OutOfConeFilesAreAddedAsLinks = false member ops.SupportsOutputWindowPane = false member ops.CleanInvisibleProject vs = VsImpl(vs).CleanInvisibleProject() diff --git a/vsintegration/tests/unittests/BraceMatchingServiceTests.fs b/vsintegration/tests/unittests/BraceMatchingServiceTests.fs index 818c0c6ce1a..cc18dab3c06 100644 --- a/vsintegration/tests/unittests/BraceMatchingServiceTests.fs +++ b/vsintegration/tests/unittests/BraceMatchingServiceTests.fs @@ -12,6 +12,7 @@ open Microsoft.CodeAnalysis.Text open Microsoft.FSharp.Compiler.SourceCodeServices open Microsoft.VisualStudio.FSharp.Editor open Microsoft.VisualStudio.FSharp.LanguageService +open UnitTests.TestLib.LanguageService [][] type BraceMatchingServiceTests() = @@ -34,7 +35,7 @@ type BraceMatchingServiceTests() = let position = fileContents.IndexOf(marker) Assert.IsTrue(position >= 0, "Cannot find marker '{0}' in file contents", marker) - match FSharpBraceMatchingService.GetBraceMatchingResult(FSharpChecker.Instance, sourceText, fileName, options, position) |> Async.RunSynchronously with + match FSharpBraceMatchingService.GetBraceMatchingResult(checker, sourceText, fileName, options, position) |> Async.RunSynchronously with | None -> () | Some(left, right) -> Assert.Fail("Found match for brace '{0}'", marker) @@ -46,7 +47,7 @@ type BraceMatchingServiceTests() = Assert.IsTrue(startMarkerPosition >= 0, "Cannot find start marker '{0}' in file contents", startMarkerPosition) Assert.IsTrue(endMarkerPosition >= 0, "Cannot find end marker '{0}' in file contents", endMarkerPosition) - match FSharpBraceMatchingService.GetBraceMatchingResult(FSharpChecker.Instance, sourceText, fileName, options, startMarkerPosition) |> Async.RunSynchronously with + match FSharpBraceMatchingService.GetBraceMatchingResult(checker, sourceText, fileName, options, startMarkerPosition) |> Async.RunSynchronously with | None -> Assert.Fail("Didn't find a match for start brace at position '{0}", startMarkerPosition) | Some(left, right) -> let endPositionInRange(range) = diff --git a/vsintegration/tests/unittests/BreakpointResolutionService.fs b/vsintegration/tests/unittests/BreakpointResolutionService.fs index 51a5c300d41..e5e22533cb1 100644 --- a/vsintegration/tests/unittests/BreakpointResolutionService.fs +++ b/vsintegration/tests/unittests/BreakpointResolutionService.fs @@ -16,6 +16,8 @@ open Microsoft.VisualStudio.FSharp.LanguageService open Microsoft.FSharp.Compiler.SourceCodeServices open Microsoft.FSharp.Compiler.Range +open UnitTests.TestLib.LanguageService + [][] type BreakpointResolutionServiceTests() = @@ -71,7 +73,7 @@ let main argv = let sourceText = SourceText.From(code) let searchSpan = TextSpan.FromBounds(searchPosition, searchPosition + searchToken.Length) - let actualResolutionOption = FSharpBreakpointResolutionService.GetBreakpointLocation(FSharpChecker.Instance, sourceText, fileName, searchSpan, options) |> Async.RunSynchronously + let actualResolutionOption = FSharpBreakpointResolutionService.GetBreakpointLocation(checker, sourceText, fileName, searchSpan, options) |> Async.RunSynchronously match actualResolutionOption with | None -> Assert.IsTrue(expectedResolution.IsNone, "BreakpointResolutionService failed to resolve breakpoint position") diff --git a/vsintegration/tests/unittests/CompletionProviderTests.fs b/vsintegration/tests/unittests/CompletionProviderTests.fs index b17e77de0e8..58a96592508 100644 --- a/vsintegration/tests/unittests/CompletionProviderTests.fs +++ b/vsintegration/tests/unittests/CompletionProviderTests.fs @@ -32,6 +32,7 @@ open Microsoft.CodeAnalysis.Text open Microsoft.VisualStudio.FSharp.Editor open Microsoft.FSharp.Compiler.SourceCodeServices +open UnitTests.TestLib.LanguageService let filePath = "C:\\test.fs" let internal options = { @@ -50,7 +51,7 @@ let internal options = { let VerifyCompletionList(fileContents: string, marker: string, expected: string list, unexpected: string list) = let caretPosition = fileContents.IndexOf(marker) + marker.Length let results = - FSharpCompletionProvider.ProvideCompletionsAsyncAux(FSharpChecker.Instance, SourceText.From(fileContents), caretPosition, options, filePath, 0, fun _ -> []) + FSharpCompletionProvider.ProvideCompletionsAsyncAux(checker, SourceText.From(fileContents), caretPosition, options, filePath, 0, fun _ -> []) |> Async.RunSynchronously |> Option.defaultValue (ResizeArray()) |> Seq.map(fun result -> result.DisplayText) @@ -65,7 +66,7 @@ let VerifyCompletionListExactly(fileContents: string, marker: string, expected: let caretPosition = fileContents.IndexOf(marker) + marker.Length let actual = - FSharpCompletionProvider.ProvideCompletionsAsyncAux(FSharpChecker.Instance, SourceText.From(fileContents), caretPosition, options, filePath, 0, fun _ -> []) + FSharpCompletionProvider.ProvideCompletionsAsyncAux(checker, SourceText.From(fileContents), caretPosition, options, filePath, 0, fun _ -> []) |> Async.RunSynchronously |> Option.defaultValue (ResizeArray()) |> Seq.toList diff --git a/vsintegration/tests/unittests/DocumentDiagnosticAnalyzerTests.fs b/vsintegration/tests/unittests/DocumentDiagnosticAnalyzerTests.fs index 8f8208d2548..097479ef592 100644 --- a/vsintegration/tests/unittests/DocumentDiagnosticAnalyzerTests.fs +++ b/vsintegration/tests/unittests/DocumentDiagnosticAnalyzerTests.fs @@ -17,6 +17,8 @@ open Microsoft.VisualStudio.FSharp.LanguageService open Microsoft.FSharp.Compiler.SourceCodeServices open Microsoft.FSharp.Compiler.Range +open UnitTests.TestLib.LanguageService + [][] type DocumentDiagnosticAnalyzerTests() = let filePath = "C:\\test.fs" @@ -37,8 +39,8 @@ type DocumentDiagnosticAnalyzerTests() = let getDiagnostics (fileContents: string) = async { - let! syntacticDiagnostics = FSharpDocumentDiagnosticAnalyzer.GetDiagnostics(FSharpChecker.Instance, filePath, SourceText.From(fileContents), 0, options, DiagnosticsType.Syntax) - let! semanticDiagnostics = FSharpDocumentDiagnosticAnalyzer.GetDiagnostics(FSharpChecker.Instance, filePath, SourceText.From(fileContents), 0, options, DiagnosticsType.Semantic) + let! syntacticDiagnostics = FSharpDocumentDiagnosticAnalyzer.GetDiagnostics(checker, filePath, SourceText.From(fileContents), 0, options, DiagnosticsType.Syntax) + let! semanticDiagnostics = FSharpDocumentDiagnosticAnalyzer.GetDiagnostics(checker, filePath, SourceText.From(fileContents), 0, options, DiagnosticsType.Semantic) return syntacticDiagnostics.AddRange(semanticDiagnostics) } |> Async.RunSynchronously diff --git a/vsintegration/tests/unittests/DocumentHighlightsServiceTests.fs b/vsintegration/tests/unittests/DocumentHighlightsServiceTests.fs index 8714652033d..892fda3f3ba 100644 --- a/vsintegration/tests/unittests/DocumentHighlightsServiceTests.fs +++ b/vsintegration/tests/unittests/DocumentHighlightsServiceTests.fs @@ -33,6 +33,7 @@ open Microsoft.VisualStudio.FSharp.Editor open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.SourceCodeServices +open UnitTests.TestLib.LanguageService let filePath = "C:\\test.fs" @@ -51,7 +52,7 @@ let internal options = { let private getSpans (sourceText: SourceText) (caretPosition: int) = let documentId = DocumentId.CreateNewId(ProjectId.CreateNewId()) - FSharpDocumentHighlightsService.GetDocumentHighlights(FSharpChecker.Instance, documentId, sourceText, filePath, caretPosition, [], options, 0) + FSharpDocumentHighlightsService.GetDocumentHighlights(checker, documentId, sourceText, filePath, caretPosition, [], options, 0) |> Async.RunSynchronously |> Option.defaultValue [||] diff --git a/vsintegration/tests/unittests/GoToDefinitionServiceTests.fs b/vsintegration/tests/unittests/GoToDefinitionServiceTests.fs index 635cd48cac3..4299b9bb1e5 100644 --- a/vsintegration/tests/unittests/GoToDefinitionServiceTests.fs +++ b/vsintegration/tests/unittests/GoToDefinitionServiceTests.fs @@ -28,9 +28,9 @@ open NUnit.Framework open Microsoft.CodeAnalysis open Microsoft.CodeAnalysis.Text open Microsoft.VisualStudio.FSharp.Editor - open Microsoft.FSharp.Compiler.SourceCodeServices open Microsoft.FSharp.Compiler.Range +open UnitTests.TestLib.LanguageService [][] module GoToDefinitionServiceTests = @@ -121,7 +121,7 @@ let _ = Module1.foo 1 let caretPosition = fileContents.IndexOf(caretMarker) + caretMarker.Length - 1 // inside the marker let documentId = DocumentId.CreateNewId(ProjectId.CreateNewId()) let actual = - findDefinition(FSharpChecker.Instance, documentId, SourceText.From(fileContents), filePath, caretPosition, [], options, 0) + findDefinition(checker, documentId, SourceText.From(fileContents), filePath, caretPosition, [], options, 0) |> Option.map (fun range -> (range.StartLine, range.EndLine, range.StartColumn, range.EndColumn)) if actual <> expected then diff --git a/vsintegration/tests/unittests/HelpContextServiceTests.fs b/vsintegration/tests/unittests/HelpContextServiceTests.fs index af6f5aa2256..22d819bc127 100644 --- a/vsintegration/tests/unittests/HelpContextServiceTests.fs +++ b/vsintegration/tests/unittests/HelpContextServiceTests.fs @@ -14,6 +14,7 @@ open Microsoft.FSharp.Compiler.SourceCodeServices open Microsoft.VisualStudio.FSharp.Editor open Microsoft.VisualStudio.FSharp.LanguageService open UnitTests.TestLib.Utils +open UnitTests.TestLib.LanguageService [][] type HelpContextServiceTests() = @@ -55,12 +56,12 @@ type HelpContextServiceTests() = let res = [ for marker in markers fileContents do - let span = TextSpan(marker, 0) + let span = Microsoft.CodeAnalysis.Text.TextSpan(marker, 0) let textLine = sourceText.Lines.GetLineFromPosition(marker) let documentId = DocumentId.CreateNewId(ProjectId.CreateNewId()) let tokens = Tokenizer.getColorizationData(documentId, sourceText, textLine.Span, Some "test.fs", [], CancellationToken.None) - yield FSharpHelpContextService.GetHelpTerm(FSharpChecker.Instance, sourceText, fileName, newOptions, span, tokens, version) + yield FSharpHelpContextService.GetHelpTerm(checker, sourceText, fileName, newOptions, span, tokens, version) |> Async.RunSynchronously ] let equalLength = List.length expectedKeywords = List.length res diff --git a/vsintegration/tests/unittests/QuickInfoProviderTests.fs b/vsintegration/tests/unittests/QuickInfoProviderTests.fs index bab2871308c..9444da16dd7 100644 --- a/vsintegration/tests/unittests/QuickInfoProviderTests.fs +++ b/vsintegration/tests/unittests/QuickInfoProviderTests.fs @@ -29,8 +29,8 @@ open NUnit.Framework open Microsoft.CodeAnalysis open Microsoft.CodeAnalysis.Text open Microsoft.VisualStudio.FSharp.Editor - open Microsoft.FSharp.Compiler.SourceCodeServices +open UnitTests.TestLib.LanguageService let filePath = "C:\\test.fs" @@ -97,7 +97,7 @@ Full name: System.Console" let documentId = DocumentId.CreateNewId(ProjectId.CreateNewId()) let quickInfo = - FSharpQuickInfoProvider.ProvideQuickInfo(FSharpChecker.Instance, documentId, SourceText.From(fileContents), filePath, caretPosition, options, 0) + FSharpQuickInfoProvider.ProvideQuickInfo(checker, documentId, SourceText.From(fileContents), filePath, caretPosition, options, 0) |> Async.RunSynchronously let actual = quickInfo |> Option.map (fun (text, _, _, _) -> getQuickInfoText text) @@ -227,7 +227,7 @@ let res8 = abs 5.0 let documentId = DocumentId.CreateNewId(ProjectId.CreateNewId()) let quickInfo = - FSharpQuickInfoProvider.ProvideQuickInfo(FSharpChecker.Instance, documentId, SourceText.From(fileContents), filePath, caretPosition, options, 0) + FSharpQuickInfoProvider.ProvideQuickInfo(checker, documentId, SourceText.From(fileContents), filePath, caretPosition, options, 0) |> Async.RunSynchronously let actual = quickInfo |> Option.map (fun (text, _, _, _) -> getQuickInfoText text) diff --git a/vsintegration/tests/unittests/SignatureHelpProviderTests.fs b/vsintegration/tests/unittests/SignatureHelpProviderTests.fs index 27eb27f782d..fc69f3140f3 100644 --- a/vsintegration/tests/unittests/SignatureHelpProviderTests.fs +++ b/vsintegration/tests/unittests/SignatureHelpProviderTests.fs @@ -28,6 +28,7 @@ open NUnit.Framework open Microsoft.CodeAnalysis.Text open Microsoft.VisualStudio.FSharp.Editor open Microsoft.FSharp.Compiler.SourceCodeServices +open UnitTests.TestLib.LanguageService let filePath = "C:\\test.fs" @@ -143,8 +144,8 @@ type foo5 = N1.T } let triggerChar = if marker = "," then Some ',' elif marker = "(" then Some '(' elif marker = "<" then Some '<' else None - let triggered = FSharpSignatureHelpProvider.ProvideMethodsAsyncAux(FSharpChecker.Instance, documentationProvider, SourceText.From(fileContents), caretPosition, options, triggerChar, filePath, 0) |> Async.RunSynchronously - FSharpChecker.Instance.ClearLanguageServiceRootCachesAndCollectAndFinalizeAllTransients() + let triggered = FSharpSignatureHelpProvider.ProvideMethodsAsyncAux(checker, documentationProvider, SourceText.From(fileContents), caretPosition, options, triggerChar, filePath, 0) |> Async.RunSynchronously + checker.ClearLanguageServiceRootCachesAndCollectAndFinalizeAllTransients() let actual = match triggered with | None -> None diff --git a/vsintegration/tests/unittests/TestLib.LanguageService.fs b/vsintegration/tests/unittests/TestLib.LanguageService.fs index e43dd01e6a2..dd9ad290c19 100644 --- a/vsintegration/tests/unittests/TestLib.LanguageService.fs +++ b/vsintegration/tests/unittests/TestLib.LanguageService.fs @@ -16,6 +16,10 @@ open System.Text.RegularExpressions open Microsoft.FSharp.Compiler.SourceCodeServices #nowarn "52" // The value has been copied to ensure the original is not mutated +[] +module internal Globals = + let checker = FSharpChecker.Create() + //open Internal.Utilities type internal TextSpan = Microsoft.VisualStudio.TextManager.Interop.TextSpan @@ -173,21 +177,24 @@ type internal GlobalParseAndTypeCheckCounter private(initialParseCount:int, init expectedParsedFiles |> List.map GetNameOfOpenFile, expectedTypeCheckedFiles |> List.map GetNameOfOpenFile, false) - member this.AssertExactly((aap,expectedParsedFiles) : string option * list, (aat,expectedTypeCheckedFiles) : string option * list) = + member this.AssertExactly((aap: string option,expectedParsedFiles:list), (aat: string option,expectedTypeCheckedFiles:list)) = this.AssertExactly((aap,expectedParsedFiles), (aat,expectedTypeCheckedFiles), false) member this.AssertExactly((aap,expectedParsedFiles) : string option * list, (aat,expectedTypeCheckedFiles) : string option * list, expectCreate : bool) = - let p = match aap with - | Some(aap) -> aap :: (expectedParsedFiles |> List.map GetNameOfOpenFile) - | _ -> (expectedParsedFiles |> List.map GetNameOfOpenFile) - let t = match aat with - | Some(aat) -> aat :: (expectedTypeCheckedFiles |> List.map GetNameOfOpenFile) - | _ -> (expectedTypeCheckedFiles |> List.map GetNameOfOpenFile) + let p = + match aap with + | Some(aap) -> aap :: (expectedParsedFiles |> List.map GetNameOfOpenFile) + | _ -> (expectedParsedFiles |> List.map GetNameOfOpenFile) + let t = + match aat with + | Some(aat) -> aat :: (expectedTypeCheckedFiles |> List.map GetNameOfOpenFile) + | _ -> (expectedTypeCheckedFiles |> List.map GetNameOfOpenFile) this.AssertExactly(p.Length, t.Length, p, t, expectCreate) member private this.AssertExactly(expectedParses, expectedTypeChecks, expectedParsedFiles : list, expectedTypeCheckedFiles : list, expectCreate : bool) = - let note,ok = if expectCreate then - if this.SawIBCreated() then ("The incremental builder was created, as expected",true) else ("The incremental builder was NOT deleted and recreated, even though we expected it to be",false) - else - if this.SawIBCreated() then ("The incremental builder was UNEXPECTEDLY deleted",false) else ("",true) + let note,ok = + if expectCreate then + if this.SawIBCreated() then ("The incremental builder was created, as expected",true) else ("The incremental builder was NOT deleted and recreated, even though we expected it to be",false) + else + if this.SawIBCreated() then ("The incremental builder was UNEXPECTEDLY deleted",false) else ("",true) let actualParsedFiles = this.GetParsedFilesSet() let actualTypeCheckedFiles = this.GetTypeCheckedFilesSet() let actualParses = actualParsedFiles.Count diff --git a/vsintegration/tests/unittests/Tests.LanguageService.ParameterInfo.fs b/vsintegration/tests/unittests/Tests.LanguageService.ParameterInfo.fs index e89458ced07..6d07bc886c4 100644 --- a/vsintegration/tests/unittests/Tests.LanguageService.ParameterInfo.fs +++ b/vsintegration/tests/unittests/Tests.LanguageService.ParameterInfo.fs @@ -884,7 +884,7 @@ type UsingMSBuild() = let info = info.Value AssertEqual("f1", info.GetName(0)) // note about (5,0): service.fs adds three lines of empty text to the end of every file, so it reports the location of 'end of file' as first the char, 3 lines past the last line of the file - AssertEqual([|(2,10);(2,12);(2,13);(5,0)|], info.GetNoteworthyParamInfoLocations()) + AssertEqual([|(2,10);(2,12);(2,13);(3,0)|], info.GetNoteworthyParamInfoLocations()) [] member this.``LocationOfParams.AfterQuicklyTyping.CallConstructor``() = @@ -906,7 +906,7 @@ type UsingMSBuild() = let info = info.Value AssertEqual("Foo", info.GetName(0)) // note about (4,0): service.fs adds three lines of empty text to the end of every file, so it reports the location of 'end of file' as first the char, 3 lines past the last line of the file - AssertEqual([|(1,14);(1,17);(1,18);(4,0)|], info.GetNoteworthyParamInfoLocations()) + AssertEqual([|(1,14);(1,17);(1,18);(2,0)|], info.GetNoteworthyParamInfoLocations()) (* @@ -970,9 +970,9 @@ We really need to rewrite some code paths here to use the real parse tree rather r.ToString(), locs) let testLines = testLinesAndLocs |> List.map fst let expectedLocs = testLinesAndLocs |> List.map snd |> List.collect id |> List.toArray - // note: service.fs adds three lines of empty text to the end of every file, so it reports the location of 'end of file' as first the char, 3 lines past the last line of the file + // note: service.fs adds a new line character to the end of every file, so it reports the location of 'end of file' as first the char, 3 lines past the last line of the file let expectedLocs = if defaultArg markAtEOF false then - Array.append expectedLocs [| (testLines.Length-1)+3, 0 |] + Array.append expectedLocs [| (testLines.Length-1)+1, 0 |] else expectedLocs let cursorPrefix = cursorPrefix.Replace("^","") diff --git a/vsintegration/tests/unittests/Tests.Watson.fs b/vsintegration/tests/unittests/Tests.Watson.fs index e305f3d9814..2a73fff7961 100644 --- a/vsintegration/tests/unittests/Tests.Watson.fs +++ b/vsintegration/tests/unittests/Tests.Watson.fs @@ -4,6 +4,8 @@ namespace Tests.Compiler.Watson #nowarn "52" // The value has been copied to ensure the original is not mutated +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open Microsoft.FSharp.Compiler.Driver open NUnit.Framework open System open System.Text.RegularExpressions @@ -23,7 +25,9 @@ type Check = File.Delete("watson-test.fs") File.WriteAllText("watson-test.fs", "// Hello watson" ) let argv = [| "--simulateException:"+simulationCode; "watson-test.fs"|] - let _code = Microsoft.FSharp.Compiler.Driver.mainCompile (argv, Microsoft.FSharp.Compiler.MSBuildReferenceResolver.Resolver, false, Microsoft.FSharp.Compiler.ErrorLogger.QuitProcessExiter) + + let ctok = AssumeCompilationThreadWithoutEvidence () + let _code = mainCompile (ctok, argv, Microsoft.FSharp.Compiler.MSBuildReferenceResolver.Resolver, false, false, Microsoft.FSharp.Compiler.ErrorLogger.QuitProcessExiter, ConsoleLoggerProvider(), None, None) () with | :? 'TException as e -> @@ -32,6 +36,10 @@ type Check = else printfn "%s" msg Assert.Fail("The correct callstack was not reported to watson.") + | (Microsoft.FSharp.Compiler.ErrorLogger.ReportedError (Some (Microsoft.FSharp.Compiler.ErrorLogger.InternalError (msg, range) as e))) + | (Microsoft.FSharp.Compiler.ErrorLogger.InternalError (msg, range) as e) -> + printfn "InternalError Exception: %s, range = %A, stack = %s" msg range (e.ToString()) + Assert.Fail("An InternalError exception occurred.") finally #if DEBUG Microsoft.FSharp.Compiler.CompileOps.CompilerService.showAssertForUnexpectedException := true diff --git a/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj b/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj index 70413e4013d..1de1130d208 100644 --- a/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj +++ b/vsintegration/tests/unittests/VisualFSharp.Unittests.fsproj @@ -4,7 +4,6 @@ $(MSBuildProjectDirectory)\..\..\..\src FSharp - true VisualFSharp.Unittests @@ -18,6 +17,7 @@ 58;75 x86 v4.6 + EXTENSIONTYPING;$(DefineConstants) NO_PROJECTCRACKER;$(DefineConstants) @@ -77,6 +77,18 @@ MultiProjectAnalysisTests.fs + + PerfTests.fs + + + InteractiveCheckerTests.fs + + + ExprTests.fs + + + CSharpProjectAnalysis.fs + ProjectOptionsTests.fs