diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index f44e3f1aed0..3042ad88da8 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -2086,6 +2086,61 @@ type CcuLoadFailureAction = | RaiseError | ReturnNone +type LType = + | Resolution + | RestoreSource + +type LStatus = + | Unprocessed + | Processed + +type PackageManagerLine = + { LineType: LType + LineStatus: LStatus + Line: string + Range: range } + + static member AddLineWithKey (packageKey: string) (lt:LType) (line: string) (m: range) (packageManagerLines: Map): Map = + let path = PackageManagerLine.StripDependencyManagerKey packageKey line + let map = + let mutable found = false + let result = + packageManagerLines + |> Map.map(fun key lines -> + if key = packageKey then + found <- true + lines |> List.append [{LineType=lt; LineStatus=LStatus.Unprocessed; Line=path; Range=m}] + else + lines) + if found then + result + else + result.Add(packageKey, [{LineType=lt; LineStatus=LStatus.Unprocessed; Line=path; Range=m}]) + map + + static member RemoveUnprocessedLines (packageKey: string) (packageManagerLines: Map): Map = + let map = + packageManagerLines + |> Map.map(fun key lines -> + if key = packageKey then + lines |> List.filter(fun line -> line.LineStatus=LStatus.Processed) + else + lines) + map + + static member SetLinesAsProcessed (packageKey:string) (packageManagerLines: Map): Map = + let map = + packageManagerLines + |> Map.map(fun key lines -> + if key = packageKey then + lines |> List.map(fun line -> {line with LineStatus = LStatus.Processed;}) + else + lines) + map + + static member StripDependencyManagerKey (packageKey: string) (line: string): string = + line.Substring(packageKey.Length + 1).Trim() + [] type TcConfigBuilder = { mutable primaryAssembly: PrimaryAssembly @@ -2107,7 +2162,7 @@ type TcConfigBuilder = mutable loadedSources: (range * string * string) list mutable compilerToolPaths: string list mutable referencedDLLs: AssemblyReference list - mutable packageManagerLines: Map + mutable packageManagerLines: Map mutable projectReferences: IProjectReference list mutable knownUnresolvedReferences: UnresolvedAssemblyReference list reduceMemoryUsage: ReduceMemoryFlag @@ -2536,13 +2591,9 @@ type TcConfigBuilder = elif not (tcConfigB.referencedDLLs |> List.exists (fun ar2 -> Range.equals m ar2.Range && path=ar2.Text)) then // NOTE: We keep same paths if range is different. let projectReference = tcConfigB.projectReferences |> List.tryPick (fun pr -> if pr.FileName = path then Some pr else None) tcConfigB.referencedDLLs <- tcConfigB.referencedDLLs ++ AssemblyReference(m, path, projectReference) - - member tcConfigB.AddDependencyManagerText (packageManager:IDependencyManagerProvider, m, path:string) = - let path = tcConfigB.dependencyProvider.RemoveDependencyManagerKey(packageManager.Key, path) - match tcConfigB.packageManagerLines |> Map.tryFind packageManager.Key with - | Some lines -> tcConfigB.packageManagerLines <- Map.add packageManager.Key (lines ++ (false, path, m)) tcConfigB.packageManagerLines - | _ -> tcConfigB.packageManagerLines <- Map.add packageManager.Key [false, path, m] tcConfigB.packageManagerLines + member tcConfigB.AddDependencyManagerText (packageManager: IDependencyManagerProvider, lt, m, path: string) = + tcConfigB.packageManagerLines <- PackageManagerLine.AddLineWithKey packageManager.Key lt path m tcConfigB.packageManagerLines member tcConfigB.RemoveReferencedAssemblyByPath (m, path) = tcConfigB.referencedDLLs <- tcConfigB.referencedDLLs |> List.filter (fun ar -> not (Range.equals ar.Range m) || ar.Text <> path) @@ -5002,7 +5053,7 @@ let RequireDLL (ctok, tcImports: TcImports, tcEnv, thisAssemblyName, m, file) = let ProcessMetaCommandsFromInput (nowarnF: 'state -> range * string -> 'state, dllRequireF: 'state -> range * string -> 'state, - packageRequireF: 'state -> IDependencyManagerProvider * range * string -> 'state, + packageRequireF: 'state -> IDependencyManagerProvider * LType * range * string -> 'state, loadSourceF: 'state -> range * string -> unit) (tcConfig:TcConfigBuilder, inp, pathOfMetaCommandSource, state0) = @@ -5051,7 +5102,7 @@ let ProcessMetaCommandsFromInput match dm with | _, dependencyManager when not(isNull dependencyManager) -> if tcConfig.langVersion.SupportsFeature(LanguageFeature.PackageManagement) then - packageRequireF state (dependencyManager, m, path) + packageRequireF state (dependencyManager, LType.Resolution, m, path) else errorR(Error(FSComp.SR.packageManagementRequiresVFive(), m)) state @@ -5143,7 +5194,7 @@ let ApplyNoWarnsToTcConfig (tcConfig: TcConfig, inp: ParsedInput, pathOfMetaComm let tcConfigB = tcConfig.CloneOfOriginalBuilder let addNoWarn = fun () (m,s) -> tcConfigB.TurnWarningOff(m, s) let addReferencedAssemblyByPath = fun () (_m,_s) -> () - let addDependencyManagerText = fun () (_prefix,_m,_s) -> () + let addDependencyManagerText = fun () (_prefix, _lt, _m, _s) -> () let addLoadedSource = fun () (_m,_s) -> () ProcessMetaCommandsFromInput (addNoWarn, addReferencedAssemblyByPath, addDependencyManagerText, addLoadedSource) (tcConfigB, inp, pathOfMetaCommandSource, ()) TcConfig.Create(tcConfigB, validate=false) @@ -5153,7 +5204,7 @@ let ApplyMetaCommandsFromInputToTcConfig (tcConfig: TcConfig, inp: ParsedInput, let tcConfigB = tcConfig.CloneOfOriginalBuilder let getWarningNumber = fun () _ -> () let addReferencedAssemblyByPath = fun () (m,s) -> tcConfigB.AddReferencedAssemblyByPath(m,s) - let addDependencyManagerText = fun () (packageManager, m,s) -> tcConfigB.AddDependencyManagerText(packageManager,m,s) + let addDependencyManagerText = fun () (packageManager, lt, m,s) -> tcConfigB.AddDependencyManagerText(packageManager, lt, m, s) let addLoadedSource = fun () (m,s) -> tcConfigB.AddLoadedSource(m,s,pathOfMetaCommandSource) ProcessMetaCommandsFromInput (getWarningNumber, addReferencedAssemblyByPath, addDependencyManagerText, addLoadedSource) (tcConfigB, inp, pathOfMetaCommandSource, ()) TcConfig.Create(tcConfigB, validate=false) @@ -5303,7 +5354,7 @@ module ScriptPreprocessClosure = let mutable nowarns = [] let getWarningNumber = fun () (m, s) -> nowarns <- (s, m) :: nowarns let addReferencedAssemblyByPath = fun () (m, s) -> tcConfigB.AddReferencedAssemblyByPath(m, s) - let addDependencyManagerText = fun () (packageManagerPrefix,m,s) -> tcConfigB.AddDependencyManagerText(packageManagerPrefix,m,s) + let addDependencyManagerText = fun () (packageManagerPrefix, lt, m, s) -> tcConfigB.AddDependencyManagerText(packageManagerPrefix, lt, m, s) let addLoadedSource = fun () (m, s) -> tcConfigB.AddLoadedSource(m, s, pathOfMetaCommandSource) try ProcessMetaCommandsFromInput (getWarningNumber, addReferencedAssemblyByPath, addDependencyManagerText, addLoadedSource) (tcConfigB, inp, pathOfMetaCommandSource, ()) @@ -5331,7 +5382,7 @@ module ScriptPreprocessClosure = let packageManagerKey, packageManagerLines = kv.Key, kv.Value match packageManagerLines with | [] -> () - | (_, _, m)::_ -> + | { LineType=_; LineStatus=_; Line=_; Range=m } :: _ -> let reportError = let report errorType err msg = let error = err, msg @@ -5349,8 +5400,7 @@ module ScriptPreprocessClosure = errorR(Error(tcConfig.dependencyProvider.CreatePackageManagerUnknownError(tcConfig.compilerToolPaths, outputDir, packageManagerKey, reportError), m)) | dependencyManager -> - let inline snd3 (_, b, _) = b - let packageManagerTextLines = packageManagerLines |> List.map snd3 + let packageManagerTextLines = packageManagerLines |> List.map(fun l -> l.Line) let result = tcConfig.dependencyProvider.Resolve(dependencyManager, ".fsx", packageManagerTextLines, reportError, executionTfm, executionRid, tcConfig.implicitIncludeDir, mainFile, scriptName) match result.Success with | true -> @@ -5359,7 +5409,7 @@ module ScriptPreprocessClosure = let tcConfigB = tcConfig.CloneOfOriginalBuilder for folder in result.Roots do tcConfigB.AddIncludePath(m, folder, "") - tcConfigB.packageManagerLines <- tcConfigB.packageManagerLines |> Map.map(fun _ l -> l |> List.map(fun (_, p, m) -> true, p, m)) + tcConfigB.packageManagerLines <- PackageManagerLine.SetLinesAsProcessed packageManagerKey tcConfigB.packageManagerLines tcConfig <- TcConfig.Create(tcConfigB, validate=false) for script in result.SourceFiles do let scriptText = File.ReadAllText script @@ -5371,7 +5421,7 @@ module ScriptPreprocessClosure = // Resolution produced errors update packagerManagerLines entries to note these failure // failed resolutions will no longer be considered let tcConfigB = tcConfig.CloneOfOriginalBuilder - tcConfigB.packageManagerLines <- tcConfigB.packageManagerLines |> Map.map(fun _ l -> l |> List.filter(fun (tried, _, _) -> tried)) + tcConfigB.packageManagerLines <- PackageManagerLine.RemoveUnprocessedLines packageManagerKey tcConfigB.packageManagerLines tcConfig <- TcConfig.Create(tcConfigB, validate=false)] else [] diff --git a/src/fsharp/CompileOps.fsi b/src/fsharp/CompileOps.fsi index 31407c3b956..b6dff421ab9 100644 --- a/src/fsharp/CompileOps.fsi +++ b/src/fsharp/CompileOps.fsi @@ -254,6 +254,25 @@ type VersionFlag = member GetVersionInfo: implicitIncludeDir:string -> ILVersionInfo member GetVersionString: implicitIncludeDir:string -> string +type LType = + | Resolution + | RestoreSource + +type LStatus = + | Unprocessed + | Processed + +type PackageManagerLine = + { LineType: LType + LineStatus: LStatus + Line: string + Range: range } + + static member AddLineWithKey: string -> LType -> string -> range -> Map -> Map + static member RemoveUnprocessedLines: string -> Map -> Map + static member SetLinesAsProcessed: string -> Map -> Map + static member StripDependencyManagerKey: string -> string -> string + [] type TcConfigBuilder = { mutable primaryAssembly: PrimaryAssembly @@ -277,8 +296,7 @@ type TcConfigBuilder = mutable loadedSources: (range * string * string) list mutable compilerToolPaths: string list mutable referencedDLLs: AssemblyReference list - mutable packageManagerLines: Map - + mutable packageManagerLines: Map mutable projectReferences: IProjectReference list mutable knownUnresolvedReferences: UnresolvedAssemblyReference list reduceMemoryUsage: ReduceMemoryFlag @@ -396,8 +414,7 @@ type TcConfigBuilder = mutable langVersion : LanguageVersion - mutable dependencyProvider : DependencyProvider - + mutable dependencyProvider: DependencyProvider } static member Initial: TcConfigBuilder @@ -694,7 +711,7 @@ val RequireDLL: CompilationThreadToken * TcImports * TcEnv * thisAssemblyName: s /// Processing # commands val ProcessMetaCommandsFromInput : - (('T -> range * string -> 'T) * ('T -> range * string -> 'T) * ('T -> IDependencyManagerProvider * range * string -> 'T) * ('T -> range * string -> unit)) + (('T -> range * string -> 'T) * ('T -> range * string -> 'T) * ('T -> IDependencyManagerProvider * LType * range * string -> 'T) * ('T -> range * string -> unit)) -> TcConfigBuilder * ParsedInput * string * 'T -> 'T diff --git a/src/fsharp/FSharp.Core/reflect.fs b/src/fsharp/FSharp.Core/reflect.fs index d18a0bf16e0..56bcc317d0c 100644 --- a/src/fsharp/FSharp.Core/reflect.fs +++ b/src/fsharp/FSharp.Core/reflect.fs @@ -13,6 +13,7 @@ open Microsoft.FSharp.Core.Operators open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open Microsoft.FSharp.Collections open Microsoft.FSharp.Primitives.Basics +open System.Linq.Expressions module internal ReflectionUtils = @@ -63,6 +64,19 @@ module internal Impl = | null -> None | prop -> Some(fun (obj: obj) -> prop.GetValue (obj, instancePropertyFlags ||| bindingFlags, null, null, null)) + let compilePropGetterFunc (prop: PropertyInfo) = + let param = Expression.Parameter (typeof, "param") + + let expr = + Expression.Lambda> ( + Expression.Convert ( + Expression.Property ( + Expression.Convert (param, prop.DeclaringType), + prop), + typeof), + param) + expr.Compile () + //----------------------------------------------------------------- // ATTRIBUTE DECOMPILATION @@ -585,6 +599,10 @@ module internal Impl = let props = fieldPropsOfRecordType(typ, bindingFlags) (fun (obj: obj) -> props |> Array.map (fun prop -> prop.GetValue (obj, null))) + let getRecordReaderFromFuncs(typ: Type, bindingFlags) = + let props = fieldPropsOfRecordType(typ, bindingFlags) |> Array.map compilePropGetterFunc + (fun (obj: obj) -> props |> Array.map (fun prop -> prop.Invoke obj)) + let getRecordConstructorMethod(typ: Type, bindingFlags) = let props = fieldPropsOfRecordType(typ, bindingFlags) let ctor = typ.GetConstructor(BindingFlags.Instance ||| bindingFlags, null, props |> Array.map (fun p -> p.PropertyType), null) @@ -806,7 +824,7 @@ type FSharpValue = static member PreComputeRecordReader(recordType: Type, ?bindingFlags) : (obj -> obj[]) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public checkRecordType ("recordType", recordType, bindingFlags) - getRecordReader (recordType, bindingFlags) + getRecordReaderFromFuncs (recordType, bindingFlags) static member PreComputeRecordConstructor(recordType: Type, ?bindingFlags) = let bindingFlags = defaultArg bindingFlags BindingFlags.Public diff --git a/src/fsharp/Microsoft.DotNet.DependencyManager/DependencyProvider.fs b/src/fsharp/Microsoft.DotNet.DependencyManager/DependencyProvider.fs index 21461731c0e..02340a06181 100644 --- a/src/fsharp/Microsoft.DotNet.DependencyManager/DependencyProvider.fs +++ b/src/fsharp/Microsoft.DotNet.DependencyManager/DependencyProvider.fs @@ -359,11 +359,6 @@ type DependencyProvider (assemblyProbingPaths: AssemblyResolutionProbe, nativePr reportError.Invoke(ErrorReportType.Error, err, msg) null, Unchecked.defaultof - /// Remove the dependency mager with the specified key - member _.RemoveDependencyManagerKey(packageManagerKey:string, path:string): string = - - path.Substring(packageManagerKey.Length + 1).Trim() - /// Fetch a dependencymanager that supports a specific key member _.TryFindDependencyManagerByKey (compilerTools: string seq, outputDir: string, reportError: ResolvingErrorReport, key: string): IDependencyManagerProvider = diff --git a/src/fsharp/Microsoft.DotNet.DependencyManager/DependencyProvider.fsi b/src/fsharp/Microsoft.DotNet.DependencyManager/DependencyProvider.fsi index 47cff0724ff..137b367a527 100644 --- a/src/fsharp/Microsoft.DotNet.DependencyManager/DependencyProvider.fsi +++ b/src/fsharp/Microsoft.DotNet.DependencyManager/DependencyProvider.fsi @@ -72,9 +72,6 @@ type DependencyProvider = /// Returns a formatted error message for the host to present member CreatePackageManagerUnknownError: string seq * string * string * ResolvingErrorReport -> int * string - /// Remove the dependency manager with the specified key - member RemoveDependencyManagerKey: packageManagerKey: string * path: string -> string - /// Resolve reference for a list of package manager lines member Resolve : packageManager: IDependencyManagerProvider * scriptExt: string * packageManagerTextLines: string seq * reportError: ResolvingErrorReport * executionTfm: string * []executionRid: string * []implicitIncludeDir: string * []mainScriptName: string * []fileName: string -> IResolveDependenciesResult diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs index d43bd29b318..5628483bea2 100644 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -1444,15 +1444,9 @@ type internal FsiDynamicCompiler resolutions, { addCcusToIncrementalEnv istate ccuinfos with tcState = tcState.NextStateAfterIncrementalFragment(tcEnv) } + member __.EvalDependencyManagerTextFragment (packageManager:IDependencyManagerProvider, lt, m, path: string) = - member __.EvalDependencyManagerTextFragment (packageManager:IDependencyManagerProvider,m,path: string) = - let path = tcConfigB.dependencyProvider.RemoveDependencyManagerKey(packageManager.Key, path) - - - match tcConfigB.packageManagerLines |> Map.tryFind packageManager.Key with - | Some lines -> tcConfigB.packageManagerLines <- Map.add packageManager.Key (lines @ [false, path, m]) tcConfigB.packageManagerLines - | _ -> tcConfigB.packageManagerLines <- Map.add packageManager.Key [false, path, m] tcConfigB.packageManagerLines - + tcConfigB.packageManagerLines <- PackageManagerLine.AddLineWithKey packageManager.Key lt path m tcConfigB.packageManagerLines needsPackageResolution <- true member fsiDynamicCompiler.CommitDependencyManagerText (ctok, istate: FsiDynamicCompilerState, lexResourceManager, errorLogger) = @@ -1460,11 +1454,10 @@ type internal FsiDynamicCompiler needsPackageResolution <- false tcConfigB.packageManagerLines |> Seq.fold(fun istate kv -> - let inline snd3 (_, b, _) = b let packageManagerKey, packageManagerLines = kv.Key, kv.Value match packageManagerLines with | [] -> istate - | (_, _, m)::_ -> + | { LineType=_; LineStatus=_; Line=_; Range=m } :: _ -> let outputDir = tcConfigB.outputDir |> Option.defaultValue "" match tcConfigB.dependencyProvider.TryFindDependencyManagerByKey(tcConfigB.compilerToolPaths, getOutputDir tcConfigB, reportError m, packageManagerKey) with @@ -1472,26 +1465,26 @@ type internal FsiDynamicCompiler errorR(Error(tcConfigB.dependencyProvider.CreatePackageManagerUnknownError(tcConfigB.compilerToolPaths, outputDir, packageManagerKey, reportError m), m)) istate | dependencyManager -> - let packageManagerTextLines = packageManagerLines |> List.map snd3 - let removeErrorLinesFromScript () = - tcConfigB.packageManagerLines <- tcConfigB.packageManagerLines |> Map.map(fun _ l -> l |> List.filter(fun (tried, _, _) -> tried)) + let packageManagerTextLines = packageManagerLines |> List.map (fun line -> line.Line) try let result = tcConfigB.dependencyProvider.Resolve(dependencyManager, ".fsx", packageManagerTextLines, reportError m, executionTfm, executionRid, tcConfigB.implicitIncludeDir, "stdin.fsx", "stdin.fsx") match result.Success with | false -> - removeErrorLinesFromScript () + tcConfigB.packageManagerLines <- PackageManagerLine.RemoveUnprocessedLines packageManagerKey tcConfigB.packageManagerLines istate // error already reported + | true -> - tcConfigB.packageManagerLines <- tcConfigB.packageManagerLines |> Map.map(fun _ l -> l |> List.map(fun (_, p, m) -> true, p, m)) + tcConfigB.packageManagerLines <- PackageManagerLine.SetLinesAsProcessed packageManagerKey tcConfigB.packageManagerLines for folder in result.Roots do tcConfigB.AddIncludePath(m, folder, "") let scripts = result.SourceFiles |> Seq.toList if not (isNil scripts) then fsiDynamicCompiler.EvalSourceFiles(ctok, istate, m, scripts, lexResourceManager, errorLogger) else istate + with _ -> // An exception occured during processing, so remove the lines causing the error from the package manager list. - removeErrorLinesFromScript () + tcConfigB.packageManagerLines <- PackageManagerLine.RemoveUnprocessedLines packageManagerKey tcConfigB.packageManagerLines reraise () ) istate @@ -1502,7 +1495,7 @@ type internal FsiDynamicCompiler ProcessMetaCommandsFromInput ((fun st (m,nm) -> tcConfigB.TurnWarningOff(m,nm); st), (fun st (m,nm) -> snd (fsiDynamicCompiler.EvalRequireReference (ctok, st, m, nm))), - (fun st (packageManagerPrefix,m,nm) -> fsiDynamicCompiler.EvalDependencyManagerTextFragment (packageManagerPrefix,m,nm); st), + (fun st (packageManagerPrefix, lt, m, nm) -> fsiDynamicCompiler.EvalDependencyManagerTextFragment (packageManagerPrefix, lt, m, nm); st), (fun _ _ -> ())) (tcConfigB, inp, Path.GetDirectoryName sourceFile, istate)) @@ -1542,7 +1535,7 @@ type internal FsiDynamicCompiler | _-> input.SyntaxTree input.FileName, parsedInput) |> List.unzip - + errorLogger.AbortOnError(fsiConsoleOutput); if inputs |> List.exists Option.isNone then failwith "parse error" let inputs = List.map Option.get inputs @@ -2131,7 +2124,7 @@ type internal FsiInteractionProcessor | _, dependencyManager when not(isNull dependencyManager) -> if tcConfig.langVersion.SupportsFeature(LanguageFeature.PackageManagement) then - fsiDynamicCompiler.EvalDependencyManagerTextFragment(dependencyManager, m, path) + fsiDynamicCompiler.EvalDependencyManagerTextFragment(dependencyManager, LType.Resolution, m, path) istate, Completed None else errorR(Error(FSComp.SR.packageManagementRequiresVFive(), m)) diff --git a/tests/fsharp/Compiler/ConstraintSolver/MemberConstraints.fs b/tests/FSharp.Compiler.ComponentTests/ConstraintSolver/MemberConstraints.fs similarity index 51% rename from tests/fsharp/Compiler/ConstraintSolver/MemberConstraints.fs rename to tests/FSharp.Compiler.ComponentTests/ConstraintSolver/MemberConstraints.fs index e2be187bd78..6cdd83a5992 100644 --- a/tests/fsharp/Compiler/ConstraintSolver/MemberConstraints.fs +++ b/tests/FSharp.Compiler.ComponentTests/ConstraintSolver/MemberConstraints.fs @@ -1,27 +1,35 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -namespace FSharp.Compiler.UnitTests +namespace FSharp.Compiler.ConstraintSolver.ComponentTests -open NUnit.Framework -open FSharp.Test.Utilities -open FSharp.Compiler.SourceCodeServices +open Xunit +open FSharp.Test.Utilities.Compiler -[] module MemberConstraints = - [] - let ``we can overload operators on a type and not add all the extra jazz such as inlining and the ^ operator.``() = - CompilerAssert.CompileExeAndRun - """ -type Foo(x : int) = + [] + let ``Invalid member constraint with ErrorRanges``() = // Regression test for FSharp1.0:2262 + FSharp """ + let inline length (x: ^a) : int = (^a : (member Length : int with get, set) (x, ())) + """ + |> withOptions ["--test:ErrorRanges"] + |> typecheck + |> shouldFail + |> withSingleDiagnostic (Error 697, Line 2, Col 43, Line 2, Col 76, "Invalid constraint") + + [] + let ``we can overload operators on a type and not add all the extra jazz such as inlining and the ^ operator.``() = + + FSharp """ +type Foo(x : int) = member this.Val = x - + static member (-->) ((src : Foo), (target : Foo)) = new Foo(src.Val + target.Val) static member (-->) ((src : Foo), (target : int)) = new Foo(src.Val + target) - + static member (+) ((src : Foo), (target : Foo)) = new Foo(src.Val + target.Val) static member (+) ((src : Foo), (target : int)) = new Foo(src.Val + target) - + let x = Foo(3) --> 4 let y = Foo(3) --> Foo(4) let x2 = Foo(3) + 4 @@ -32,16 +40,8 @@ elif y.Val <> 7 then failwith "y.Val <> 7" elif x2.Val <> 7 then failwith "x2.Val <> 7" elif y2.Val <> 7 then failwith "x.Val <> 7" else () - """ - - [] - let ``Invalid member constraint with ErrorRanges``() = // Regression test for FSharp1.0:2262 - CompilerAssert.TypeCheckSingleErrorWithOptions - [| "--test:ErrorRanges" |] - """ -let inline length (x: ^a) : int = (^a : (member Length : int with get, set) (x, ())) - """ - FSharpErrorSeverity.Error - 697 - (2, 42, 2, 75) - "Invalid constraint" + """ + |> asExe + |> compile + |> run + // OR |> compileAsExeAndRun diff --git a/tests/fsharp/Compiler/ConstraintSolver/PrimitiveConstraints.fs b/tests/FSharp.Compiler.ComponentTests/ConstraintSolver/PrimitiveConstraints.fs similarity index 75% rename from tests/fsharp/Compiler/ConstraintSolver/PrimitiveConstraints.fs rename to tests/FSharp.Compiler.ComponentTests/ConstraintSolver/PrimitiveConstraints.fs index c86f85eb04e..873864edaff 100644 --- a/tests/fsharp/Compiler/ConstraintSolver/PrimitiveConstraints.fs +++ b/tests/FSharp.Compiler.ComponentTests/ConstraintSolver/PrimitiveConstraints.fs @@ -1,18 +1,27 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -namespace FSharp.Compiler.UnitTests +namespace FSharp.Compiler.ConstraintSolver.ComponentTests -open NUnit.Framework -open FSharp.Test.Utilities -open FSharp.Compiler.SourceCodeServices +open Xunit +open FSharp.Test.Utilities.Compiler -[] module PrimitiveConstraints = - [] + [] + /// Title: Type checking oddity + /// + /// This suggestion was resolved as by design, + /// so the test makes sure, we're emitting error message about 'not being a valid object construction expression' + let ``Invalid object constructor`` () = // Regression test for FSharp1.0:4189 + baseline + ((__SOURCE_DIRECTORY__ ++ "../testables/"), "typecheck/constructors/neg_invalid_constructor.fs") + |> withOptions ["--test:ErrorRanges"] + |> typecheck + + + [] let ``Test primitive : constraints``() = - CompilerAssert.CompileExeAndRun - """ + FSharp""" #light type Foo(x : int) = @@ -33,12 +42,12 @@ let b = new Bar(256) if test1 f <> 128 then failwith "test1 f <> 128" elif test2 b <> (-1, 256) then failwith "test2 b <> (-1, 256)" else () -""" + """ + |> compileExeAndRun - [] + [] let ``Test primitive :> constraints``() = - CompilerAssert.CompileExeAndRun - """ + FSharp""" #light type Foo(x : int) = member this.Value = x @@ -64,12 +73,12 @@ if test f <> (128, "Foo") then failwith "test f <> (128, 'Foo')" elif test b <> (-1, "Bar") then failwith "test b <> (-1, 'Bar')" elif test r <> (10, "Ram") then failwith "test r <> (10, 'Ram')" else () -""" + """ + |> compileExeAndRun - [] + [] let ``Test primitive : null constraint``() = - CompilerAssert.CompileExeAndRun - """ + FSharp""" let inline isNull<'a when 'a : null> (x : 'a) = match x with | null -> "is null" @@ -84,12 +93,5 @@ let runTest = with _ -> reraise() runTest -""" - - [] - /// Title: Type checking oddity - /// - /// This suggestion was resolved as by design, - /// so the test makes sure, we're emitting error message about 'not being a valid object construction expression' - let ``Invalid object constructor``() = // Regression test for FSharp1.0:4189 - CompilerAssert.TypeCheckWithErrorsAndOptionsAgainstBaseLine [| "--test:ErrorRanges" |] (__SOURCE_DIRECTORY__ ++ "../../") "typecheck/constructors/neg_invalid_constructor.fs" + """ + |> compileExeAndRun diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/ConfusingTypeName.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/ConfusingTypeName.fs index b67a75ec601..3c7e569007d 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/ConfusingTypeName.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/ConfusingTypeName.fs @@ -4,46 +4,40 @@ namespace FSharp.Compiler.ErrorMessages.ComponentTests open Xunit open FSharp.Test.Utilities +open FSharp.Test.Utilities.Compiler open FSharp.Test.Utilities.Utilities open FSharp.Compiler.SourceCodeServices module ``Confusing Type Name`` = [] - let ``Checks expected types with multiple references``() = - let csLibAB = """ + let ``Expected types with multiple references`` () = + + let csLibA = + CSharp """ public class A { } public class B { } - """ - let csLibACmpl = - CompilationUtil.CreateCSharpCompilation(csLibAB, CSharpLanguageVersion.CSharp8, TargetFramework.NetCoreApp30, name = "libA") - |> CompilationReference.Create + """ |> withName "libA" - let csLibBCmpl = - CompilationUtil.CreateCSharpCompilation(csLibAB, CSharpLanguageVersion.CSharp8, TargetFramework.NetCoreApp30, name = "libB") - |> CompilationReference.Create + let csLibB = + csLibA |> withName "libB" - let fsLibC = """ + let fsLibC = + FSharp """ module AMaker let makeA () : A = A() let makeB () = B<_>() - """ + """ |> withName "libC" |> withReferences [csLibA] - let fsLibD = """ + let fsLibD = + FSharp """ module OtherAMaker let makeOtherA () : A = A() let makeOtherB () = B<_>() - """ - - let fsLibCCmpl = - Compilation.Create(fsLibC, Fs, Library, cmplRefs = [csLibACmpl], name = "libC") - |> CompilationReference.CreateFSharp + """ |> withName "libD" |> withReferences [csLibB] - let fsLibDCmpl = - Compilation.Create(fsLibD, Fs, Library, cmplRefs = [csLibBCmpl], name = "libD") - |> CompilationReference.CreateFSharp - - let app = """ + let app = + FSharp """ module ConfusingTypeName let a = AMaker.makeA() let otherA = OtherAMaker.makeOtherA() @@ -54,14 +48,15 @@ let b = AMaker.makeB() let otherB = OtherAMaker.makeOtherB() printfn "%A %A" (b.GetType().AssemblyQualifiedName) (otherB.GetType().AssemblyQualifiedName) printfn "%A" (b = otherB) - """ - - let appCmpl = - Compilation.Create(app, Fs, Library, cmplRefs = [csLibACmpl; csLibBCmpl; fsLibCCmpl; fsLibDCmpl]) - - CompilerAssert.CompileWithErrors( - appCmpl, - [| - (FSharpErrorSeverity.Error, 1, (6, 19, 6, 25), ("This expression was expected to have type\n 'A (libA, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null)' \nbut here has type\n 'A (libB, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null)' ")) - (FSharpErrorSeverity.Error, 1, (11, 19, 11, 25), ("This expression was expected to have type\n 'B (libA, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null)' \nbut here has type\n 'B (libB, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null)' ")) - |], true) + """ |> withReferences [csLibA; csLibB; fsLibC; fsLibD] + + app + |> compile + |> shouldFail + |> withDiagnostics [ + (Warning 686, Line 8, Col 9, Line 8, Col 21, "The method or function 'makeB' should not be given explicit type argument(s) because it does not declare its type parameters explicitly") + (Warning 686, Line 9, Col 14, Line 9, Col 36, "The method or function 'makeOtherB' should not be given explicit type argument(s) because it does not declare its type parameters explicitly") + (Error 1, Line 6, Col 19, Line 6, Col 25, "This expression was expected to have type\n 'A (libA, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null)' \nbut here has type\n 'A (libB, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null)' ") + (Error 1, Line 11, Col 19, Line 11, Col 25, "This expression was expected to have type\n 'B (libA, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null)' \nbut here has type\n 'B (libB, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null)' ") + + ] diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index e78ad8e7725..14e96dfa23b 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -37,6 +37,10 @@ + + + + diff --git a/tests/FSharp.Compiler.ComponentTests/Interop/SimpleInteropTests.fs b/tests/FSharp.Compiler.ComponentTests/Interop/SimpleInteropTests.fs new file mode 100644 index 00000000000..59b0ce83438 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Interop/SimpleInteropTests.fs @@ -0,0 +1,75 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Compiler.ErrorMessages.ComponentTests + +open Xunit +open FSharp.Test.Utilities +open FSharp.Test.Utilities.Compiler + +module ``C# <-> F# basic interop`` = + + [] + let ``Instantiate C# type from F#`` () = + + let CSLib = + CSharp """ +public class A { } + """ |> withName "CSLib" + + let FSLib = + FSharp """ +module AMaker +let makeA () : A = A() + """ |> withName "FSLib" |> withReferences [CSLib] + + let app = + FSharp """ +module ReferenceCSfromFS +let a = AMaker.makeA() + """ |> withReferences [CSLib; FSLib] + + app + |> compile + |> shouldSucceed + + + [] + let ``Instantiate F# type from C#`` () = + let FSLib = + FSharp """ +namespace Interop.FS +type Bicycle(manufacturer: string) = + member this.Manufactirer = manufacturer + """ |> withName "FSLib" + + let app = + CSharp """ +using Interop.FS; +public class BicycleShop { + public Bicycle[] cycles; +} + """ |> withReferences [FSLib] + + app + |> compile + |> shouldSucceed + + [] + let ``Instantiate F# type from C# fails without import`` () = + let FSLib = + FSharp """ +namespace Interop.FS +type Bicycle(manufacturer: string) = + member this.Manufactirer = manufacturer + """ |> withName "FSLib" + + let app = + CSharp """ +public class BicycleShop { + public Bicycle[] cycles; +} + """ |> withReferences [FSLib] + + app + |> compile + |> shouldFail diff --git a/tests/FSharp.Compiler.ComponentTests/Language/CompilerDirectiveTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/CompilerDirectiveTests.fs new file mode 100644 index 00000000000..9f9d949667c --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Language/CompilerDirectiveTests.fs @@ -0,0 +1,27 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Compiler.Language.ComponentTests + +open Xunit +open FSharp.Test.Utilities +open FSharp.Test.Utilities.Compiler +open FSharp.Compiler.SourceCodeServices + +module ``Test Compiler Directives`` = + + [] + let ``r# "" is invalid`` () = + Fsx""" +#r "" + """ |> ignoreWarnings + |> compile + |> shouldSucceed + |> withSingleDiagnostic (Warning 213, Line 2, Col 1, Line 2, Col 6, "'' is not a valid assembly name") + + [] + let ``#r " " is invalid`` () = + Fsx""" +#r " " + """ |> compile + |> shouldFail + |> withSingleDiagnostic (Warning 213, Line 2, Col 1, Line 2, Col 10, "'' is not a valid assembly name") diff --git a/tests/FSharp.Compiler.ComponentTests/testables/typecheck/constructors/neg_invalid_constructor.bsl b/tests/FSharp.Compiler.ComponentTests/testables/typecheck/constructors/neg_invalid_constructor.bsl new file mode 100644 index 00000000000..3b2777c1504 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/testables/typecheck/constructors/neg_invalid_constructor.bsl @@ -0,0 +1,22 @@ +typecheck/constructors/neg_invalid_constructor.fs (3,29)-(3,56) typecheck error A unique overload for method 'ImmutableStack`1' could not be determined based on type information prior to this program point. A type annotation may be needed. + +Known type of argument: 'a list + +Candidates: + - new : col:'b -> ImmutableStack<'a> + - private new : items:'a list -> ImmutableStack<'a> +typecheck/constructors/neg_invalid_constructor.fs (4,93)-(4,111) typecheck error A unique overload for method 'ImmutableStack`1' could not be determined based on type information prior to this program point. A type annotation may be needed. + +Known type of argument: 'a list + +Candidates: + - new : col:'b -> ImmutableStack<'a> + - private new : items:'a list -> ImmutableStack<'a> +typecheck/constructors/neg_invalid_constructor.fs (7,30)-(7,60) typecheck error A unique overload for method 'ImmutableStack`1' could not be determined based on type information prior to this program point. A type annotation may be needed. + +Known type of argument: 'a list + +Candidates: + - new : col:'b -> ImmutableStack<'a> when 'b :> seq<'c> + - private new : items:'a list -> ImmutableStack<'a> +typecheck/constructors/neg_invalid_constructor.fs (7,30)-(7,60) typecheck error This is not a valid object construction expression. Explicit object constructors must either call an alternate constructor or initialize all fields of the object and specify a call to a super class constructor. \ No newline at end of file diff --git a/tests/FSharp.Compiler.ComponentTests/testables/typecheck/constructors/neg_invalid_constructor.fs b/tests/FSharp.Compiler.ComponentTests/testables/typecheck/constructors/neg_invalid_constructor.fs new file mode 100644 index 00000000000..02be510295d --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/testables/typecheck/constructors/neg_invalid_constructor.fs @@ -0,0 +1,7 @@ +type ImmutableStack<'a> private(items: 'a list) = + + member this.Push item = ImmutableStack(item::items) + member this.Pop = match items with | [] -> failwith "No elements in stack" | x::xs -> x,ImmutableStack(xs) + + // Notice type annotation is commented out, which results in an error + new(col (*: seq<'a>*)) = ImmutableStack(List.ofSeq col) diff --git a/tests/FSharp.Test.Utilities/Assert.fs b/tests/FSharp.Test.Utilities/Assert.fs index d059337834e..64a4b732160 100644 --- a/tests/FSharp.Test.Utilities/Assert.fs +++ b/tests/FSharp.Test.Utilities/Assert.fs @@ -4,6 +4,9 @@ module Assert = open FluentAssertions open System.Collections + let inline shouldBeEqualWith (expected : ^T) (message: string) (actual: ^U) = + actual.Should().BeEquivalentTo(expected, message) |> ignore + let inline shouldBeEquivalentTo (expected : ^T) (actual : ^U) = actual.Should().BeEquivalentTo(expected, "") |> ignore diff --git a/tests/FSharp.Test.Utilities/Compiler.fs b/tests/FSharp.Test.Utilities/Compiler.fs new file mode 100644 index 00000000000..6c6c51b10da --- /dev/null +++ b/tests/FSharp.Test.Utilities/Compiler.fs @@ -0,0 +1,507 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Test.Utilities + +open FSharp.Compiler.SourceCodeServices +open FSharp.Test.Utilities +open FSharp.Test.Utilities.Assert +open FSharp.Test.Utilities.Utilities +open Microsoft.CodeAnalysis +open Microsoft.CodeAnalysis.CSharp +open NUnit.Framework +open System +open System.Collections.Immutable +open System.IO + +module rec Compiler = + + type TestType = + | Text of string + | Path of string + | Baseline of (string * string) + + type CompilationUnit = + | FS of FSharpCompilationSource + | CS of CSharpCompilationSource + | IL of ILCompilationSource + + type FSharpCompilationSource = + { Source: TestType + Options: string list + OutputType: CompileOutput + SourceKind: SourceKind + Name: string option + IgnoreWarnings: bool + References: CompilationUnit list } + + type CSharpCompilationSource = + { Source: TestType + LangVersion: CSharpLanguageVersion + TargetFramework: TargetFramework + Name: string option + References: CompilationUnit list } + + type ILCompilationSource = + { Source: TestType + References: CompilationUnit list } + + type ErrorType = Error of int | Warning of int + + type Line = Line of int + type Col = Col of int + + type Range = + { StartLine: int + StartColumn: int + EndLine: int + EndColumn: int } + + type ErrorInfo = + { Error: ErrorType + Range: Range + Message: string } + + type Output = + { OutputPath: string option + Adjust: int + Errors: ErrorInfo list + Warnings: ErrorInfo list } + + type CompilationResult = + | Success of Output + | Failure of Output + + let private defaultOptions : string list = [] + + // Not very safe version of reading stuff from file, but we want to fail fast for now if anything goes wrong. + let private getSource (src: TestType) : string = + match src with + | Text t -> t + | Path p -> System.IO.File.ReadAllText p + | Baseline (d, f) -> System.IO.File.ReadAllText (System.IO.Path.Combine(d, f)) + + let private fsFromString (source: string) (kind: SourceKind) : FSharpCompilationSource = + match source with + | null -> failwith "Source cannot be null" + | _ -> + { Source = Text source + Options = defaultOptions + OutputType = Library + SourceKind = kind + Name = None + IgnoreWarnings = false + References = [] } + + let private csFromString (source: string) : CSharpCompilationSource = + match source with + | null -> failwith "Source cannot be null" + | _ -> + { Source = Text source + LangVersion = CSharpLanguageVersion.CSharp8 + TargetFramework = TargetFramework.NetCoreApp30 + Name = None + References = [] } + + let private fromFSharpErrorInfo (errors: FSharpErrorInfo[]) : (ErrorInfo list * ErrorInfo list) = + let toErrorInfo (e: FSharpErrorInfo) : ErrorInfo = + let errorNumber = e.ErrorNumber + let severity = e.Severity + + let error = if severity = FSharpErrorSeverity.Warning then Warning errorNumber else Error errorNumber + + { Error = error + Range = + { StartLine = e.StartLineAlternate + StartColumn = e.StartColumn + EndLine = e.EndLineAlternate + EndColumn = e.EndColumn } + Message = e.Message } + + errors + |> List.ofArray + |> List.distinctBy (fun e -> e.Severity, e.ErrorNumber, e.StartLineAlternate, e.StartColumn, e.EndLineAlternate, e.EndColumn, e.Message) + |> List.map toErrorInfo + |> List.partition (fun e -> match e.Error with Error _ -> true | _ -> false) + + let private adjustRange (range: Range) (adjust: int) : Range = + { range with + StartLine = range.StartLine - adjust + StartColumn = range.StartColumn + 1 + EndLine = range.EndLine - adjust + EndColumn = range.EndColumn + 1 } + + let Fsx (source: string) : CompilationUnit = + fsFromString source SourceKind.Fsx |> FS + + let FSharp (source: string) : CompilationUnit = + fsFromString source SourceKind.Fs |> FS + + let baseline (dir: string, file: string) : CompilationUnit = + match (dir, file) with + | dir, _ when String.IsNullOrWhiteSpace dir -> failwith "Baseline tests directory cannot be null or empty." + | _, file when String.IsNullOrWhiteSpace file -> failwith "Baseline source file name cannot be null or empty." + | _ -> + { Source = Baseline (dir, file) + Options = defaultOptions + OutputType = Library + SourceKind = Fs + Name = None + IgnoreWarnings = false + References = [] } |> FS + + let CSharp (source: string) : CompilationUnit = + csFromString source |> CS + + let withName (name: string) (cUnit: CompilationUnit) : CompilationUnit = + match cUnit with + | FS src -> FS { src with Name = Some name } + | CS src -> CS { src with Name = Some name } + | IL _ -> failwith "IL Compilation cannot be named." + + let withReferences (references: CompilationUnit list) (cUnit: CompilationUnit) : CompilationUnit = + match cUnit with + | FS fs -> FS { fs with References = fs.References @ references } + | CS cs -> CS { cs with References = cs.References @ references } + | IL _ -> failwith "References are not supported in IL" + + let withOptions (options: string list) (cUnit: CompilationUnit) : CompilationUnit = + match cUnit with + | FS fs -> FS { fs with Options = options } + | _ -> failwith "withOptions is only supported n F#" + + let asLibrary (cUnit: CompilationUnit) : CompilationUnit = + match cUnit with + | FS fs -> FS { fs with OutputType = CompileOutput.Library } + | _ -> failwith "TODO: Implement where applicable." + + let asExe (cUnit: CompilationUnit) : CompilationUnit = + match cUnit with + | FS fs -> FS { fs with OutputType = CompileOutput.Exe } + | _ -> failwith "TODO: Implement where applicable." + + let ignoreWarnings (cUnit: CompilationUnit) : CompilationUnit = + match cUnit with + | FS fs -> FS { fs with IgnoreWarnings = true } + | _ -> failwith "TODO: Implement ignorewarnings for the rest." + + let rec private asMetadataReference reference = + match reference with + | CompilationReference (cmpl, _) -> + let result = compileFSharpCompilation cmpl false + match result with + | Failure f -> + let message = sprintf "Compilation failed (expected to succeed).\n All errors:\n%A" (f.Errors @ f.Warnings) + failwith message + | Success s -> + match s.OutputPath with + | None -> failwith "Compilation didn't produce any output!" + | Some p -> p |> MetadataReference.CreateFromFile + | _ -> failwith "Conversion isn't possible" + + let private processReferences (references: CompilationUnit list) = + let rec loop acc = function + | [] -> List.rev acc + | x::xs -> + match x with + | FS fs -> + let refs = loop [] fs.References + let source = getSource fs.Source + let name = defaultArg fs.Name null + let cmpl = Compilation.Create(source, fs.SourceKind, fs.OutputType, cmplRefs = refs, name = name) |> CompilationReference.CreateFSharp + loop (cmpl::acc) xs + | CS cs -> + let refs = loop [] cs.References + let source = getSource cs.Source + let name = defaultArg cs.Name null + let metadataReferences = List.map asMetadataReference refs + let cmpl = CompilationUtil.CreateCSharpCompilation(source, cs.LangVersion, cs.TargetFramework, additionalReferences = metadataReferences.ToImmutableArray().As(), name = name) + |> CompilationReference.Create + loop (cmpl::acc) xs + | IL _ -> failwith "TODO: Process references for IL" + loop [] references + + let private compileFSharpCompilation compilation ignoreWarnings : CompilationResult = + + let ((err: FSharpErrorInfo[], outputFilePath: string), _) = CompilerAssert.CompileRaw(compilation) + + let (errors, warnings) = err |> fromFSharpErrorInfo + + let result = + { OutputPath = None + Adjust = 0 + Warnings = warnings + Errors = errors } + + // Treat warnings as errors if "IgnoreWarnings" is false + if errors.Length > 0 || (warnings.Length > 0 && not ignoreWarnings) then + Failure { result with Warnings = warnings + Errors = errors } + else + Success { result with Warnings = warnings + OutputPath = Some outputFilePath } + + let private compileFSharp (fsSource: FSharpCompilationSource) : CompilationResult = + + let source = getSource fsSource.Source + let sourceKind = fsSource.SourceKind + let output = fsSource.OutputType + let options = fsSource.Options |> Array.ofList + + let references = processReferences fsSource.References + + let compilation = Compilation.Create(source, sourceKind, output, options, references) + + compileFSharpCompilation compilation fsSource.IgnoreWarnings + + let private compileCSharpCompilation (compilation: CSharpCompilation) : CompilationResult = + + let outputPath = Path.Combine(Path.GetTempPath(), "FSharpCompilerTests", Path.GetRandomFileName()) + + Directory.CreateDirectory(outputPath) |> ignore + + let filename = compilation.AssemblyName + let output = Path.Combine(outputPath, Path.ChangeExtension(filename, ".dll")) + + let cmplResult = compilation.Emit (output) + + let result = + { OutputPath = None + Adjust = 0 + Warnings = [] + Errors = [] } + + if cmplResult.Success then + Success { result with OutputPath = Some output } + else + Failure result + + let private compileCSharp (csSource: CSharpCompilationSource) : CompilationResult = + + let source = getSource csSource.Source + let name = defaultArg csSource.Name (Guid.NewGuid().ToString ()) + + let additionalReferences = + match processReferences csSource.References with + | [] -> ImmutableArray.Empty + | r -> (List.map asMetadataReference r).ToImmutableArray().As() + + let references = TargetFrameworkUtil.getReferences csSource.TargetFramework + + let lv = + match csSource.LangVersion with + | CSharpLanguageVersion.CSharp8 -> LanguageVersion.CSharp8 + | _ -> LanguageVersion.Default + + let cmpl = + CSharpCompilation.Create( + name, + [ CSharpSyntaxTree.ParseText (source, CSharpParseOptions lv) ], + references.As().AddRange additionalReferences, + CSharpCompilationOptions (OutputKind.DynamicallyLinkedLibrary)) + + cmpl |> compileCSharpCompilation + + let compile (cUnit: CompilationUnit) : CompilationResult = + match cUnit with + | FS fs -> compileFSharp fs + | CS cs -> compileCSharp cs + | _ -> failwith "TODO" + + let private typecheckFSharpWithBaseline (options: string list) (dir: string) (file: string) : CompilationResult = + // Since TypecheckWithErrorsAndOptionsAgainsBaseLine throws if doesn't match expected baseline, + // We return a successfull CompilationResult if it succeeds. + CompilerAssert.TypeCheckWithErrorsAndOptionsAgainstBaseLine (Array.ofList options) dir file + + Success + { OutputPath = None + Adjust = 0 + Warnings = [] + Errors = [] } + + let private typecheckFSharpSource (fsSource: FSharpCompilationSource) : CompilationResult = + let source = getSource fsSource.Source + let options = fsSource.Options |> Array.ofList + + let (err: FSharpErrorInfo []) = CompilerAssert.TypeCheckWithOptions options source + + let (errors, warnings) = err |> fromFSharpErrorInfo + + let result = + { OutputPath = None + Adjust = 0 + Warnings = warnings + Errors = errors } + + // Treat warnings as errors if "IgnoreWarnings" is false; + if errors.Length > 0 || (warnings.Length > 0 && not fsSource.IgnoreWarnings) then + Failure { result with Warnings = warnings + Errors = errors } + else + Success { result with Warnings = warnings } + + let private typecheckFSharp (fsSource: FSharpCompilationSource) : CompilationResult = + match fsSource.Source with + | Baseline (f, d) -> typecheckFSharpWithBaseline fsSource.Options f d + | _ -> typecheckFSharpSource fsSource + + let typecheck (cUnit: CompilationUnit) : CompilationResult = + match cUnit with + | FS fs -> typecheckFSharp fs + | _ -> failwith "Typecheck only supports F#" + + let run (cResult: CompilationResult ) : unit = + match cResult with + | Failure o -> failwith (sprintf "Compilation should be successfull in order to run.\n Errors: %A" (o.Errors @ o.Warnings)) + | Success s -> + match s.OutputPath with + | None -> failwith "Compilation didn't produce any output. Unable to run. (did you forget to set output type to Exe?)" + | Some p -> CompilerAssert.Run p + + let compileAndRun = compile >> run + + let compileExeAndRun = asExe >> compileAndRun + + [] + module Assertions = + let private getErrorNumber (error: ErrorType) : int = + match error with + | Error e | Warning e -> e + + let private getErrorInfo (info: ErrorInfo) : string = + sprintf "%A %A" info.Error info.Message + + let inline private assertErrorsLength (source: ErrorInfo list) (expected: 'a list) : unit = + if (List.length source) <> (List.length expected) then + failwith (sprintf "Expected list of issues differ from compilation result:\nExpected:\n %A\nActual:\n %A" expected (List.map getErrorInfo source)) + () + + let private assertErrorMessages (source: ErrorInfo list) (expected: string list) : unit = + for exp in expected do + if not (List.exists (fun (el: ErrorInfo) -> el.Message = exp) source) then + failwith (sprintf "Mismatch in error message, expected '%A' was not found during compilation.\nAll errors:\n%A" exp (List.map getErrorInfo source)) + assertErrorsLength source expected + + let private assertErrorNumbers (source: ErrorInfo list) (expected: int list) : unit = + for exp in expected do + if not (List.exists (fun (el: ErrorInfo) -> (getErrorNumber el.Error) = exp) source) then + failwith (sprintf "Mismatch in ErrorNumber, expected '%A' was not found during compilation.\nAll errors:\n%A" exp (List.map getErrorInfo source)) + assertErrorsLength source expected + + let private assertErrors (what: string) libAdjust (source: ErrorInfo list) (expected: ErrorInfo list) : unit = + let errors = source |> List.map (fun error -> { error with Range = adjustRange error.Range libAdjust }) + + let inline checkEqual k a b = + if a <> b then + Assert.AreEqual(a, b, sprintf "%s: Mismatch in %s, expected '%A', got '%A'.\nAll errors:\n%A" what k a b errors) + + // TODO: Check all "categories", collect all results and print alltogether. + checkEqual "Errors count" expected.Length errors.Length + + List.zip errors expected + |> List.iter (fun (actualError, expectedError) -> + let { Error = actualError; Range = actualRange; Message = actualMessage } = actualError + let { Error = expectedError; Range = expectedRange; Message = expectedMessage } = expectedError + checkEqual "Error" expectedError actualError + checkEqual "ErrorRange" expectedRange actualRange + checkEqual "Message" expectedMessage actualMessage) + () + + let adjust (adjust: int) (result: CompilationResult) : CompilationResult = + match result with + | Success s -> Success { s with Adjust = adjust } + | Failure f -> Failure { f with Adjust = adjust } + + let shouldSucceed (result: CompilationResult) : CompilationResult = + match result with + | Success _ -> result + | Failure r -> + let message = sprintf "Compilation failed (expected to succeed).\n All errors:\n%A" (r.Errors @ r.Warnings) + failwith message + + let shouldFail (result: CompilationResult) : CompilationResult = + match result with + | Success _ -> failwith "Compilation was \"Success\" (expected: \"Failure\")." + | Failure _ -> result + + let private assertResultsCategory (what: string) (selector: Output -> ErrorInfo list) (expected: ErrorInfo list) (result: CompilationResult) : CompilationResult = + match result with + | Success r | Failure r -> + assertErrors what r.Adjust (selector r) expected + result + + let withResults (expectedResults: ErrorInfo list) result : CompilationResult = + assertResultsCategory "Results" (fun r -> r.Warnings @ r.Errors) expectedResults result + + let withResult (expectedResult: ErrorInfo ) (result: CompilationResult) : CompilationResult = + withResults [expectedResult] result + + let withDiagnostics (expected: (ErrorType * Line * Col * Line * Col * string) list) (result: CompilationResult) : CompilationResult = + let (expectedResults: ErrorInfo list) = + expected |> + List.map( + fun e -> + let (error, (Line startLine), (Col startCol), (Line endLine), (Col endCol), message) = e + { Error = error + Range = + { StartLine = startLine + StartColumn = startCol + EndLine = endLine + EndColumn = endCol } + Message = message }) + withResults expectedResults result + + let withSingleDiagnostic (expected: (ErrorType * Line * Col * Line * Col * string)) (result: CompilationResult) : CompilationResult = + withDiagnostics [expected] result + + let withErrors (expectedErrors: ErrorInfo list) (result: CompilationResult) : CompilationResult = + assertResultsCategory "Errors" (fun r -> r.Errors) expectedErrors result + + let withError (expectedError: ErrorInfo) (result: CompilationResult) : CompilationResult = + withErrors [expectedError] result + + let checkCodes (expected: int list) (selector: Output -> ErrorInfo list) (result: CompilationResult) : CompilationResult = + match result with + | Success r | Failure r -> + assertErrorNumbers (selector r) expected + result + + let withErrorCodes (expectedCodes: int list) (result: CompilationResult) : CompilationResult = + checkCodes expectedCodes (fun r -> r.Errors) result + + let withErrorCode (expectedCode: int) (result: CompilationResult) : CompilationResult = + withErrorCodes [expectedCode] result + + let withWarnings (expectedWarnings: ErrorInfo list) (result: CompilationResult) : CompilationResult = + assertResultsCategory "Warnings" (fun r -> r.Warnings) expectedWarnings result + + let withWarning (expectedWarning: ErrorInfo) (result: CompilationResult) : CompilationResult = + withWarnings [expectedWarning] result + + let withWarningCodes (expectedCodes: int list) (result: CompilationResult) : CompilationResult = + checkCodes expectedCodes (fun r -> r.Warnings) result + + let withWarningCode (expectedCode: int) (result: CompilationResult) : CompilationResult = + withWarningCodes [expectedCode] result + + let private checkErrorMessages (messages: string list) (selector: Output -> ErrorInfo list) (result: CompilationResult) : CompilationResult = + match result with + | Success r | Failure r -> assertErrorMessages (selector r) messages + result + + let withMessages (messages: string list) (result: CompilationResult) : CompilationResult = + checkErrorMessages messages (fun r -> r.Warnings @ r.Errors) result + + let withMessage (message: string) (result: CompilationResult) : CompilationResult = + withMessages [message] result + + let withErrorMessages (messages: string list) (result: CompilationResult) : CompilationResult = + checkErrorMessages messages (fun r -> r.Errors) result + + let withErrorMessage (message: string) (result: CompilationResult) : CompilationResult = + withErrorMessages [message] result + + let withWarningMessages (messages: string list) (result: CompilationResult) : CompilationResult = + checkErrorMessages messages (fun r -> r.Warnings) result + + let withWarningMessage (message: string) (result: CompilationResult) : CompilationResult = + withWarningMessages [message] result diff --git a/tests/FSharp.Test.Utilities/CompilerAssert.fs b/tests/FSharp.Test.Utilities/CompilerAssert.fs index ac75e88ee9a..4956b3e2035 100644 --- a/tests/FSharp.Test.Utilities/CompilerAssert.fs +++ b/tests/FSharp.Test.Utilities/CompilerAssert.fs @@ -362,6 +362,14 @@ let main argv = 0""" disposals |> Seq.iter (fun x -> x.Dispose()) + // NOTE: This function will not clean up all the compiled projects after itself. + // The reason behind is so we can compose verification of test runs easier. + // TODO: We must not rely on the filesystem when compiling + static let rec returnCompilation (cmpl: Compilation) = + let compileDirectory = Path.Combine(Path.GetTempPath(), "CompilerAssert", Path.GetRandomFileName()) + Directory.CreateDirectory(compileDirectory) |> ignore + compileCompilationAux compileDirectory (ResizeArray()) false cmpl + static member CompileWithErrors(cmpl: Compilation, expectedErrors, ?ignoreWarnings) = let ignoreWarnings = defaultArg ignoreWarnings false lock gate (fun () -> @@ -371,6 +379,9 @@ let main argv = 0""" static member Compile(cmpl: Compilation, ?ignoreWarnings) = CompilerAssert.CompileWithErrors(cmpl, [||], defaultArg ignoreWarnings false) + static member CompileRaw(cmpl: Compilation) = + lock gate (fun () -> returnCompilation cmpl) + static member Execute(cmpl: Compilation, ?ignoreWarnings, ?beforeExecute, ?newProcess, ?onOutput) = let ignoreWarnings = defaultArg ignoreWarnings false let beforeExecute = defaultArg beforeExecute (fun _ _ -> ()) @@ -481,6 +492,27 @@ let main argv = 0""" Assert.AreEqual(errorsExpectedBaseLine.Replace("\r\n","\n"), errorsActual.Replace("\r\n","\n")) + static member TypeCheckWithOptions options (source: string) = + lock gate <| fun () -> + let errors = + let parseResults, fileAnswer = + checker.ParseAndCheckFileInProject( + "test.fs", + 0, + SourceText.ofString source, + { defaultProjectOptions with OtherOptions = Array.append options defaultProjectOptions.OtherOptions}) + |> Async.RunSynchronously + + if parseResults.Errors.Length > 0 then + parseResults.Errors + else + + match fileAnswer with + | FSharpCheckFileAnswer.Aborted _ -> Assert.Fail("Type Checker Aborted"); [| |] + | FSharpCheckFileAnswer.Succeeded(typeCheckResults) -> typeCheckResults.Errors + + errors + static member TypeCheckWithErrorsAndOptionsAndAdjust options libAdjust (source: string) expectedTypeErrors = lock gate <| fun () -> let errors = @@ -502,6 +534,7 @@ let main argv = 0""" assertErrors libAdjust false errors expectedTypeErrors + static member TypeCheckWithErrorsAndOptions options (source: string) expectedTypeErrors = CompilerAssert.TypeCheckWithErrorsAndOptionsAndAdjust options 0 (source: string) expectedTypeErrors @@ -587,6 +620,9 @@ let main argv = 0""" static member RunScript source expectedErrorMessages = CompilerAssert.RunScriptWithOptions [||] source expectedErrorMessages + static member Run (exe: string) = + executeBuiltApp exe [] + static member ParseWithErrors (source: string) expectedParseErrors = let sourceFileName = "test.fs" let parsingOptions = { FSharpParsingOptions.Default with SourceFiles = [| sourceFileName |] } diff --git a/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj b/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj index 5ddfa74eb83..3d97f8aea6a 100644 --- a/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj +++ b/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj @@ -22,6 +22,7 @@ + @@ -34,7 +35,7 @@ - + diff --git a/tests/FSharp.Test.Utilities/Utilities.fs b/tests/FSharp.Test.Utilities/Utilities.fs index 1415fee273f..9db412a1361 100644 --- a/tests/FSharp.Test.Utilities/Utilities.fs +++ b/tests/FSharp.Test.Utilities/Utilities.fs @@ -4,6 +4,7 @@ namespace FSharp.Test.Utilities open System open System.IO +open System.Reflection open System.Collections.Immutable open Microsoft.CodeAnalysis open Microsoft.CodeAnalysis.CSharp @@ -20,7 +21,6 @@ module Utilities = | NetCoreApp30 module private TestReferences = - [] module NetStandard20 = let netStandard = lazy AssemblyMetadata.CreateFromImage(TestResources.NetFX.netstandard20.netstandard).GetReference(display = "netstandard.dll (netstandard 2.0 ref)") @@ -38,8 +38,9 @@ module Utilities = let systemDynamicRuntimeRef = lazy AssemblyMetadata.CreateFromImage(TestResources.NetFX.netcoreapp30.System_Dynamic_Runtime).GetReference(display = "System.Dynamic.Runtime.dll (netcoreapp 3.0 ref)") let systemConsoleRef = lazy AssemblyMetadata.CreateFromImage(TestResources.NetFX.netcoreapp30.System_Console).GetReference(display = "System.Console.dll (netcoreapp 3.0 ref)") + [] - module private TargetFrameworkUtil = + module internal TargetFrameworkUtil = open TestReferences @@ -60,8 +61,6 @@ module Utilities = | None = 0x0 | InternalsVisibleTo = 0x1 - // TODO: this and Compilation.Compile needs to be merged for sake of consistency. - // TODO: After merging, add new type of FSharp compilation. [] type TestCompilation = | CSharp of CSharpCompilation diff --git a/tests/fsharp/FSharpSuite.Tests.fsproj b/tests/fsharp/FSharpSuite.Tests.fsproj index fdfe27411ec..db41395b37c 100644 --- a/tests/fsharp/FSharpSuite.Tests.fsproj +++ b/tests/fsharp/FSharpSuite.Tests.fsproj @@ -37,8 +37,6 @@ - -