From 266b3ea4c13c34d3e2a55218c6d363d568bfea1e Mon Sep 17 00:00:00 2001 From: 0101 <0101@innit.cz> Date: Tue, 1 Nov 2022 12:35:21 +0100 Subject: [PATCH 1/7] Testing compiler workflows with synthetic projects --- .../FSharp.Compiler.ComponentTests.fsproj | 5 +- .../FSharpChecker/CommonWorkflows.fs | 69 ++++ .../FSharp.Test.Utilities.fsproj | 1 + .../ProjectGeneration.fs | 344 ++++++++++++++++++ .../SomethingToCompile.fs | 252 +++++++++++++ 5 files changed, 669 insertions(+), 2 deletions(-) create mode 100644 tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs create mode 100644 tests/FSharp.Test.Utilities/ProjectGeneration.fs create mode 100644 tests/FSharp.Test.Utilities/SomethingToCompile.fs diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 29cca6690d0..726443902e0 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -160,8 +160,8 @@ - - + + @@ -207,6 +207,7 @@ + diff --git a/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs b/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs new file mode 100644 index 00000000000..62e428fd5f9 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs @@ -0,0 +1,69 @@ +module FSharp.Compiler.ComponentTests.FSharpChecker.CommonWorkflows + +open System +open System.IO + +open Xunit + +open FSharp.Test.ProjectGeneration + +let projectDir = "test-projects" + +let makeTestProject () = + let name = $"testProject{Guid.NewGuid().ToString()[..7]}" + let dir = Path.GetFullPath projectDir + { + Name = name + ProjectDir = dir ++ name + SourceFiles = [ + sourceFile "First" [] + sourceFile "Second" ["First"] + sourceFile "Third" ["First"] + { sourceFile "Last" ["Second"; "Third"] with EntryPoint = true } + ] + } + +[] +let ``Edit file, check it, then check dependent file`` () = + projectWorkflow (makeTestProject()) { + updateFile "First" breakDependentFiles + checkFile "First" expectSignatureChanged + saveFile "First" + checkFile "Second" expectErrors + } + +[] +let ``Edit file, don't check it, check dependent file`` () = + projectWorkflow (makeTestProject()) { + updateFile "First" breakDependentFiles + saveFile "First" + checkFile "Second" expectErrors + } + +[] +let ``Check transitive dependency`` () = + projectWorkflow (makeTestProject()) { + updateFile "First" breakDependentFiles + saveFile "First" + checkFile "Last" expectSignatureChanged + } + +[] +let ``Change multiple files at once`` () = + projectWorkflow (makeTestProject()) { + updateFile "First" (setPublicVersion 2) + updateFile "Second" (setPublicVersion 2) + updateFile "Third" (setPublicVersion 2) + saveAll + checkFile "Last" (expectSignatureContains "val f: x: 'a -> (ModuleFirst.TFirstV_2<'a> * ModuleSecond.TSecondV_2<'a>) * (ModuleFirst.TFirstV_2<'a> * ModuleThird.TThirdV_2<'a>) * TLastV_1<'a>") + } + +[] +let ``Files depend on signature file if present`` () = + (makeTestProject() + |> updateFile "First" (fun f -> { f with HasSignatureFile = true }) + |> projectWorkflow) { + updateFile "First" breakDependentFiles + saveFile "First" + checkFile "Second" expectNoChanges + } \ No newline at end of file diff --git a/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj b/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj index 5410b2abb15..aac6dca42d0 100644 --- a/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj +++ b/tests/FSharp.Test.Utilities/FSharp.Test.Utilities.fsproj @@ -17,6 +17,7 @@ scriptlib.fsx + diff --git a/tests/FSharp.Test.Utilities/ProjectGeneration.fs b/tests/FSharp.Test.Utilities/ProjectGeneration.fs new file mode 100644 index 00000000000..a196ad67cc8 --- /dev/null +++ b/tests/FSharp.Test.Utilities/ProjectGeneration.fs @@ -0,0 +1,344 @@ +/// Tools for generating synthetic projects where we can model dependencies between files. +/// +/// Each file in the project has a string identifier. It then contains a type and a function. +/// The function calls functions from all the files the given file depends on and returns their +/// results + it's own type in a tuple. +/// +/// To model changes, we change the type name in a file which resutls in signatures of all the +/// dependent files also changing. +/// +/// To model breaking changes we change the name of the function which will make dependent files +/// not compile. +/// +/// To model changes to "private" code in a file we change the body of a second function which +/// no one calls. +/// +module FSharp.Test.ProjectGeneration + +open System +open System.IO +open FSharp.Compiler.CodeAnalysis +open FSharp.Compiler.Diagnostics +open FSharp.Compiler.Text +open Xunit + + +let private projectRoot = __SOURCE_DIRECTORY__ + +let private defaultFunctionName = "f" + + +type SyntheticSourceFile = + { + Id: string + /// This is part of the file's type name + PublicVersion: int + InternalVersion: int + DependsOn: string list + /// Changing this makes dependent files' code invalid + FunctionName: string + HasSignatureFile: bool + HasErrors: bool + EntryPoint: bool + ExtraCodeToCompile: bool + } + + member this.FileName = $"File{this.Id}.fs" + member this.SignatureFileName = $"{this.FileName}i" + +let sourceFile fileId deps = + { Id = fileId + PublicVersion = 1 + InternalVersion = 1 + DependsOn = deps + FunctionName = defaultFunctionName + HasSignatureFile = false + HasErrors = false + EntryPoint = false + ExtraCodeToCompile = false } + +type SyntheticProject = + { Name: string + ProjectDir: string + SourceFiles: SyntheticSourceFile list } + + member this.Find fileId = + this.SourceFiles + |> List.tryFind (fun f -> f.Id = fileId) + |> Option.defaultWith (fun () -> failwith $"File with ID '{fileId}' not found in project {this.Name}") + + member this.FindByPath path = + this.SourceFiles + |> List.tryFind (fun f -> this.ProjectDir ++ f.FileName = path) + |> Option.defaultWith (fun () -> failwith $"File {path} not found in project {this.Name}") + + member this.ProjectFileName = this.ProjectDir ++ $"{this.Name}.fsproj" + + member this.ProjectOptions = + { ProjectFileName = this.ProjectFileName + ProjectId = None + SourceFiles = + [| for f in this.SourceFiles do + if f.HasSignatureFile then + this.ProjectDir ++ f.SignatureFileName + + this.ProjectDir ++ f.FileName |] + OtherOptions = [| "--optimize+" |] + ReferencedProjects = [||] + IsIncompleteTypeCheckEnvironment = false + UseScriptResolutionRules = false + LoadTime = DateTime() + UnresolvedReferences = None + OriginalLoadReferences = [] + Stamp = None } + + +module Internal = + + let extraCodeToCompile = File.ReadAllText(projectRoot ++ "SomethingToCompile.fs") + + let renderSourceFile projectName (f: SyntheticSourceFile) = + seq { + $"module %s{projectName}.Module{f.Id}" + + $"type T{f.Id}V_{f.PublicVersion}<'a> = T{f.Id} of 'a" + + $"let {f.FunctionName} x =" + + for dep in f.DependsOn do + $" Module{dep}.{defaultFunctionName} x," + + $" T{f.Id} x" + + $"let f2 x = x + {f.InternalVersion}" + + if f.HasErrors then + "let wrong = 1 + 'a'" + + if f.ExtraCodeToCompile then + extraCodeToCompile + + if f.EntryPoint then + "[]" + "let main _ =" + " f 1 |> ignore" + " printfn \"Hello World!\"" + " 0" + } + |> String.concat Environment.NewLine + + let renderFsProj (p: SyntheticProject) = + seq { + """ + + + + Exe + net7.0 + + + + """ + + for f in p.SourceFiles do + if f.HasSignatureFile then + $"" + + $"" + + """ + + + """ + } + |> String.concat Environment.NewLine + + let writeFileIfChanged path content = + if not (File.Exists path) || File.ReadAllText(path) <> content then + File.WriteAllText(path, content) + + let writeFile (p: SyntheticProject) (f: SyntheticSourceFile) = + let fileName = p.ProjectDir ++ f.FileName + let content = renderSourceFile p.Name f + writeFileIfChanged fileName content + + +open Internal + + +[] +module ProjectOperations = + + let updateFile fileId updateFunction project = + let index = project.SourceFiles |> List.findIndex (fun file -> file.Id = fileId) + + { project with + SourceFiles = + project.SourceFiles + |> List.updateAt index (updateFunction project.SourceFiles[index]) } + + let private counter = (Seq.initInfinite id).GetEnumerator() + + let updatePublicSurface f = + counter.MoveNext() |> ignore + { f with PublicVersion = counter.Current } + + let updateInternal f = + counter.MoveNext() |> ignore + { f with InternalVersion = counter.Current } + + let breakDependentFiles f = { f with FunctionName = "g" } + + let setPublicVersion n f = { f with PublicVersion = n } + + let checkFile fileId (project: SyntheticProject) (checker: FSharpChecker) = + let file = project.Find fileId + let contents = renderSourceFile project.Name file + let absFileName = project.ProjectDir ++ file.FileName + checker.ParseAndCheckFileInProject(absFileName, 0, SourceText.ofString contents, project.ProjectOptions) + + let getTypeCheckResult (parseResults: FSharpParseFileResults, checkResults: FSharpCheckFileAnswer) = + Assert.True(not parseResults.ParseHadErrors) + + match checkResults with + | FSharpCheckFileAnswer.Aborted -> failwith "Type checking was aborted" + | FSharpCheckFileAnswer.Succeeded checkResults -> checkResults + + let getSignature parseAndCheckResults = + match (getTypeCheckResult parseAndCheckResults).GenerateSignature() with + | Some s -> s.ToString() + | None -> "" + + let expectOk parseAndCheckResults _ = + let checkResult = getTypeCheckResult parseAndCheckResults + + if checkResult.Diagnostics.Length > 0 then + failwith $"Expected no errors, but there were some: \n%A{checkResult.Diagnostics}" + + let expectErrors parseAndCheckResults _ = + let checkResult = getTypeCheckResult parseAndCheckResults + + if + (checkResult.Diagnostics + |> Array.where (fun d -> d.Severity = FSharpDiagnosticSeverity.Error)) + .Length = 0 + then + failwith "Expected errors, but there were none" + + let expectSignatureChanged result (oldSignature: string, newSignature: string) = + expectOk result () + Assert.NotEqual(oldSignature, newSignature) + + let expectSignatureContains expected result (_oldSignature, newSignature) = + expectOk result () + Assert.Contains(expected, newSignature) + + let expectNoChanges result (oldSignature: string, newSignature: string) = + expectOk result () + Assert.Equal(oldSignature, newSignature) + + let saveProject (p: SyntheticProject) generateSignatureFiles checker = + async { + Directory.CreateDirectory(p.ProjectDir) |> ignore + + for i in 0 .. p.SourceFiles.Length - 1 do + let file = p.SourceFiles.[i] + writeFile p file + + if file.HasSignatureFile && generateSignatureFiles then + let project = { p with SourceFiles = p.SourceFiles.[0..i] } + let! results = checkFile file.Id project checker + let signature = getSignature results + let signatureFileName = p.ProjectDir ++ file.SignatureFileName + writeFileIfChanged signatureFileName signature + + writeFileIfChanged (p.ProjectDir ++ $"{p.Name}.fsproj") (renderFsProj p) + } + +type WorkflowContext = + { Project: SyntheticProject + Signatures: Map } + +type ProjectWorkflowBuilder(initialProject: SyntheticProject, ?checker: FSharpChecker) = + + let checker = defaultArg checker (FSharpChecker.Create()) + + member this.Checker = checker + + member this.Yield _ = + async { + do! saveProject initialProject true checker + + let! results = checker.ParseAndCheckProject(initialProject.ProjectOptions) + + if not (Array.isEmpty results.Diagnostics) then + failwith $"Project {initialProject.Name} failed initial check: \n%A{results.Diagnostics}" + + let! signatures = + Async.Sequential + [ for file in initialProject.SourceFiles do + async { + let! result = checkFile file.Id initialProject checker + let signature = getSignature result + return file.Id, signature + } ] + + return + { Project = initialProject + Signatures = Map signatures } + } + + member this.Run(workflow: Async) = + try + Async.RunSynchronously workflow + finally + if Directory.Exists initialProject.ProjectDir then + Directory.Delete(initialProject.ProjectDir, true) + + /// Change contents of given file using `processFile` function. + /// Does not save the file to disk. + [] + member this.UpdateFile(x: Async, fileId: string, processFile) : Async = + async { + let! ctx = x + let project = ctx.Project |> updateFile fileId processFile + return { ctx with Project = project } + } + + /// Parse and type check given file and process the results using `processResults` function. + [] + member this.CheckFile(x: Async, fileId: string, processResults) = + async { + let! ctx = x + let! results = checkFile fileId ctx.Project checker + + let oldSignature = ctx.Signatures.[fileId] + let newSignature = getSignature results + + processResults results (oldSignature, newSignature) + + return { ctx with Signatures = ctx.Signatures.Add(fileId, newSignature) } + } + + /// Save given file to disk. + [] + member this.SaveFile(x: Async, fileId: string) = + async { + let! ctx = x + let f = ctx.Project.Find fileId + writeFile ctx.Project f + return ctx + } + + /// Save all files to disk + [] + member this.SaveAll(x: Async) = + async { + let! ctx = x + do! saveProject ctx.Project false checker + return ctx + } + +/// Execute a set of operations on a given synthetic project. +/// The project is saved to disk and type checked at the start. +let projectWorkflow x = ProjectWorkflowBuilder x diff --git a/tests/FSharp.Test.Utilities/SomethingToCompile.fs b/tests/FSharp.Test.Utilities/SomethingToCompile.fs new file mode 100644 index 00000000000..f693025431a --- /dev/null +++ b/tests/FSharp.Test.Utilities/SomethingToCompile.fs @@ -0,0 +1,252 @@ +// This is some code to be added to synthetic source files if we want to +// make the compiler do some work. The code is not actually used. + +let SomethingToCompile f = + + let inline map + (mapper: 'okInput -> 'okOutput) + (input: Result<'okInput, 'error>) + = + match input with + | Ok x -> Ok(f (mapper x)) + | Error e -> Error e + + let inline mapError + (errorMapper: 'errorInput -> 'errorOutput) + (input: Result<'ok, 'errorInput>) + : Result<'ok, 'errorOutput> = + match input with + | Ok x -> Ok x + | Error e -> Error(errorMapper e) + + let inline bind + (binder: 'okInput -> Result<'okOutput, 'error>) + (input: Result<'okInput, 'error>) + : Result<'okOutput, 'error> = + match input with + | Ok x -> binder x + | Error e -> Error e + + let inline isOk (value: Result<'ok, 'error>) : bool = + match value with + | Ok _ -> true + | Error _ -> false + + let inline isError (value: Result<'ok, 'error>) : bool = + match value with + | Ok _ -> false + | Error _ -> true + + let inline either + (onOk: 'okInput -> 'output) + (onError: 'errorInput -> 'output) + (input: Result<'okInput, 'errorInput>) + : 'output = + match input with + | Ok x -> onOk x + | Error err -> onError err + + let inline eitherMap + (onOk: 'okInput -> 'okOutput) + (onError: 'errorInput -> 'errorOutput) + (input: Result<'okInput, 'errorInput>) + : Result<'okOutput, 'errorOutput> = + match input with + | Ok x -> Ok(onOk x) + | Error err -> Error(onError err) + + let inline apply + (applier: Result<'okInput -> 'okOutput, 'error>) + (input: Result<'okInput, 'error>) + : Result<'okOutput, 'error> = + match (applier, input) with + | Ok f, Ok x -> Ok(f x) + | Error e, _ + | _, Error e -> Error e + + let inline map2 + (mapper: 'okInput1 -> 'okInput2 -> 'okOutput) + (input1: Result<'okInput1, 'error>) + (input2: Result<'okInput2, 'error>) + : Result<'okOutput, 'error> = + match (input1, input2) with + | Ok x, Ok y -> Ok(mapper x y) + | Error e, _ + | _, Error e -> Error e + + + let inline map3 + (mapper: 'okInput1 -> 'okInput2 -> 'okInput3 -> 'okOutput) + (input1: Result<'okInput1, 'error>) + (input2: Result<'okInput2, 'error>) + (input3: Result<'okInput3, 'error>) + : Result<'okOutput, 'error> = + match (input1, input2, input3) with + | Ok x, Ok y, Ok z -> Ok(mapper x y z) + | Error e, _, _ + | _, Error e, _ + | _, _, Error e -> Error e + + let inline fold + (onOk: 'okInput -> 'output) + (onError: 'errorInput -> 'output) + (input: Result<'okInput, 'errorInput>) + : 'output = + match input with + | Ok x -> onOk x + | Error err -> onError err + + let inline ofChoice (input: Choice<'ok, 'error>) : Result<'ok, 'error> = + match input with + | Choice1Of2 x -> Ok x + | Choice2Of2 e -> Error e + + let inline tryCreate (fieldName: string) (x: 'a) : Result< ^b, (string * 'c) > = + let tryCreate' x = + (^b: (static member TryCreate: 'a -> Result< ^b, 'c >) x) + + tryCreate' x |> mapError (fun z -> (fieldName, z)) + + + let inline orElse (ifError: Result<'ok, 'errorOutput>) (result: Result<'ok, 'error>) : Result<'ok, 'errorOutput> = + match result with + | Ok x -> Ok x + | Error e -> ifError + + + let inline orElseWith + (ifErrorFunc: 'error -> Result<'ok, 'errorOutput>) + (result: Result<'ok, 'error>) + : Result<'ok, 'errorOutput> = + match result with + | Ok x -> Ok x + | Error e -> ifErrorFunc e + + let inline ignore (result: Result<'ok, 'error>) : Result = + match result with + | Ok _ -> Ok() + | Error e -> Error e + + let inline requireTrue (error: 'error) (value: bool) : Result = if value then Ok() else Error error + + let inline requireFalse (error: 'error) (value: bool) : Result = + if not value then Ok() else Error error + + let inline requireSome (error: 'error) (option: 'ok option) : Result<'ok, 'error> = + match option with + | Some x -> Ok x + | None -> Error error + + let inline requireNone (error: 'error) (option: 'value option) : Result = + match option with + | Some _ -> Error error + | None -> Ok() + + let inline requireNotNull (error: 'error) (value: 'ok) : Result<'ok, 'error> = + match value with + | null -> Error error + | nonnull -> Ok nonnull + + let inline requireEqualTo (other: 'value) (error: 'error) (this: 'value) : Result = + if this = other then + Ok() + else + Error error + + let inline requireEqual (x1: 'value) (x2: 'value) (error: 'error) : Result = + if x1 = x2 then Ok() else Error error + + let inline requireEmpty (error: 'error) (xs: #seq<'value>) : Result = + if Seq.isEmpty xs then + Ok() + else + Error error + + let inline requireNotEmpty (error: 'error) (xs: #seq<'value>) : Result = + if Seq.isEmpty xs then + Error error + else + Ok() + + let inline requireHead (error: 'error) (xs: #seq<'ok>) : Result<'ok, 'error> = + match Seq.tryHead xs with + | Some x -> Ok x + | None -> Error error + + let inline setError (error: 'error) (result: Result<'ok, 'errorIgnored>) : Result<'ok, 'error> = + result |> mapError (fun _ -> error) + + let inline withError (error: 'error) (result: Result<'ok, unit>) : Result<'ok, 'error> = + result |> mapError (fun () -> error) + + let inline defaultValue (ifError: 'ok) (result: Result<'ok, 'error>) : 'ok = + match result with + | Ok x -> x + | Error _ -> ifError + + let inline defaultError (ifOk: 'error) (result: Result<'ok, 'error>) : 'error = + match result with + | Error error -> error + | Ok _ -> ifOk + + let inline defaultWith (ifErrorThunk: unit -> 'ok) (result: Result<'ok, 'error>) : 'ok = + match result with + | Ok x -> x + | Error _ -> ifErrorThunk () + + let inline ignoreError (result: Result) : unit = defaultValue () result + + let inline teeIf + (predicate: 'ok -> bool) + (inspector: 'ok -> unit) + (result: Result<'ok, 'error>) + : Result<'ok, 'error> = + match result with + | Ok x -> if predicate x then inspector x + | Error _ -> () + + result + + let inline teeErrorIf + (predicate: 'error -> bool) + (inspector: 'error -> unit) + (result: Result<'ok, 'error>) + : Result<'ok, 'error> = + match result with + | Ok _ -> () + | Error x -> if predicate x then inspector x + + result + + let inline tee (inspector: 'ok -> unit) (result: Result<'ok, 'error>) : Result<'ok, 'error> = + teeIf (fun _ -> true) inspector result + + let inline teeError + (inspector: 'error -> unit) + (result: Result<'ok, 'error>) + : Result<'ok, 'error> = + teeErrorIf (fun _ -> true) inspector result + + let inline valueOr (f: 'error -> 'ok) (res: Result<'ok, 'error>) : 'ok = + match res with + | Ok x -> x + | Error x -> f x + + let zip (left: Result<'leftOk, 'error>) (right: Result<'rightOk, 'error>) : Result<'leftOk * 'rightOk, 'error> = + match left, right with + | Ok x1res, Ok x2res -> Ok(x1res, x2res) + | Error e, _ -> Error e + | _, Error e -> Error e + + let zipError + (left: Result<'ok, 'leftError>) + (right: Result<'ok, 'rightError>) + : Result<'ok, 'leftError * 'rightError> = + match left, right with + | Error x1res, Error x2res -> Error(x1res, x2res) + | Ok e, _ -> Ok e + | _, Ok e -> Ok e + + map id + +let whatever x = SomethingToCompile f x From 327c0abf2bca45fbd9901fd98a3af4a28065ab63 Mon Sep 17 00:00:00 2001 From: 0101 <0101@innit.cz> Date: Tue, 1 Nov 2022 12:42:31 +0100 Subject: [PATCH 2/7] Remove extra code to compile for now --- .../ProjectGeneration.fs | 7 +- .../SomethingToCompile.fs | 252 ------------------ 2 files changed, 1 insertion(+), 258 deletions(-) delete mode 100644 tests/FSharp.Test.Utilities/SomethingToCompile.fs diff --git a/tests/FSharp.Test.Utilities/ProjectGeneration.fs b/tests/FSharp.Test.Utilities/ProjectGeneration.fs index a196ad67cc8..fdc2741370c 100644 --- a/tests/FSharp.Test.Utilities/ProjectGeneration.fs +++ b/tests/FSharp.Test.Utilities/ProjectGeneration.fs @@ -40,7 +40,6 @@ type SyntheticSourceFile = HasSignatureFile: bool HasErrors: bool EntryPoint: bool - ExtraCodeToCompile: bool } member this.FileName = $"File{this.Id}.fs" @@ -54,8 +53,7 @@ let sourceFile fileId deps = FunctionName = defaultFunctionName HasSignatureFile = false HasErrors = false - EntryPoint = false - ExtraCodeToCompile = false } + EntryPoint = false } type SyntheticProject = { Name: string @@ -115,9 +113,6 @@ module Internal = if f.HasErrors then "let wrong = 1 + 'a'" - if f.ExtraCodeToCompile then - extraCodeToCompile - if f.EntryPoint then "[]" "let main _ =" diff --git a/tests/FSharp.Test.Utilities/SomethingToCompile.fs b/tests/FSharp.Test.Utilities/SomethingToCompile.fs deleted file mode 100644 index f693025431a..00000000000 --- a/tests/FSharp.Test.Utilities/SomethingToCompile.fs +++ /dev/null @@ -1,252 +0,0 @@ -// This is some code to be added to synthetic source files if we want to -// make the compiler do some work. The code is not actually used. - -let SomethingToCompile f = - - let inline map - (mapper: 'okInput -> 'okOutput) - (input: Result<'okInput, 'error>) - = - match input with - | Ok x -> Ok(f (mapper x)) - | Error e -> Error e - - let inline mapError - (errorMapper: 'errorInput -> 'errorOutput) - (input: Result<'ok, 'errorInput>) - : Result<'ok, 'errorOutput> = - match input with - | Ok x -> Ok x - | Error e -> Error(errorMapper e) - - let inline bind - (binder: 'okInput -> Result<'okOutput, 'error>) - (input: Result<'okInput, 'error>) - : Result<'okOutput, 'error> = - match input with - | Ok x -> binder x - | Error e -> Error e - - let inline isOk (value: Result<'ok, 'error>) : bool = - match value with - | Ok _ -> true - | Error _ -> false - - let inline isError (value: Result<'ok, 'error>) : bool = - match value with - | Ok _ -> false - | Error _ -> true - - let inline either - (onOk: 'okInput -> 'output) - (onError: 'errorInput -> 'output) - (input: Result<'okInput, 'errorInput>) - : 'output = - match input with - | Ok x -> onOk x - | Error err -> onError err - - let inline eitherMap - (onOk: 'okInput -> 'okOutput) - (onError: 'errorInput -> 'errorOutput) - (input: Result<'okInput, 'errorInput>) - : Result<'okOutput, 'errorOutput> = - match input with - | Ok x -> Ok(onOk x) - | Error err -> Error(onError err) - - let inline apply - (applier: Result<'okInput -> 'okOutput, 'error>) - (input: Result<'okInput, 'error>) - : Result<'okOutput, 'error> = - match (applier, input) with - | Ok f, Ok x -> Ok(f x) - | Error e, _ - | _, Error e -> Error e - - let inline map2 - (mapper: 'okInput1 -> 'okInput2 -> 'okOutput) - (input1: Result<'okInput1, 'error>) - (input2: Result<'okInput2, 'error>) - : Result<'okOutput, 'error> = - match (input1, input2) with - | Ok x, Ok y -> Ok(mapper x y) - | Error e, _ - | _, Error e -> Error e - - - let inline map3 - (mapper: 'okInput1 -> 'okInput2 -> 'okInput3 -> 'okOutput) - (input1: Result<'okInput1, 'error>) - (input2: Result<'okInput2, 'error>) - (input3: Result<'okInput3, 'error>) - : Result<'okOutput, 'error> = - match (input1, input2, input3) with - | Ok x, Ok y, Ok z -> Ok(mapper x y z) - | Error e, _, _ - | _, Error e, _ - | _, _, Error e -> Error e - - let inline fold - (onOk: 'okInput -> 'output) - (onError: 'errorInput -> 'output) - (input: Result<'okInput, 'errorInput>) - : 'output = - match input with - | Ok x -> onOk x - | Error err -> onError err - - let inline ofChoice (input: Choice<'ok, 'error>) : Result<'ok, 'error> = - match input with - | Choice1Of2 x -> Ok x - | Choice2Of2 e -> Error e - - let inline tryCreate (fieldName: string) (x: 'a) : Result< ^b, (string * 'c) > = - let tryCreate' x = - (^b: (static member TryCreate: 'a -> Result< ^b, 'c >) x) - - tryCreate' x |> mapError (fun z -> (fieldName, z)) - - - let inline orElse (ifError: Result<'ok, 'errorOutput>) (result: Result<'ok, 'error>) : Result<'ok, 'errorOutput> = - match result with - | Ok x -> Ok x - | Error e -> ifError - - - let inline orElseWith - (ifErrorFunc: 'error -> Result<'ok, 'errorOutput>) - (result: Result<'ok, 'error>) - : Result<'ok, 'errorOutput> = - match result with - | Ok x -> Ok x - | Error e -> ifErrorFunc e - - let inline ignore (result: Result<'ok, 'error>) : Result = - match result with - | Ok _ -> Ok() - | Error e -> Error e - - let inline requireTrue (error: 'error) (value: bool) : Result = if value then Ok() else Error error - - let inline requireFalse (error: 'error) (value: bool) : Result = - if not value then Ok() else Error error - - let inline requireSome (error: 'error) (option: 'ok option) : Result<'ok, 'error> = - match option with - | Some x -> Ok x - | None -> Error error - - let inline requireNone (error: 'error) (option: 'value option) : Result = - match option with - | Some _ -> Error error - | None -> Ok() - - let inline requireNotNull (error: 'error) (value: 'ok) : Result<'ok, 'error> = - match value with - | null -> Error error - | nonnull -> Ok nonnull - - let inline requireEqualTo (other: 'value) (error: 'error) (this: 'value) : Result = - if this = other then - Ok() - else - Error error - - let inline requireEqual (x1: 'value) (x2: 'value) (error: 'error) : Result = - if x1 = x2 then Ok() else Error error - - let inline requireEmpty (error: 'error) (xs: #seq<'value>) : Result = - if Seq.isEmpty xs then - Ok() - else - Error error - - let inline requireNotEmpty (error: 'error) (xs: #seq<'value>) : Result = - if Seq.isEmpty xs then - Error error - else - Ok() - - let inline requireHead (error: 'error) (xs: #seq<'ok>) : Result<'ok, 'error> = - match Seq.tryHead xs with - | Some x -> Ok x - | None -> Error error - - let inline setError (error: 'error) (result: Result<'ok, 'errorIgnored>) : Result<'ok, 'error> = - result |> mapError (fun _ -> error) - - let inline withError (error: 'error) (result: Result<'ok, unit>) : Result<'ok, 'error> = - result |> mapError (fun () -> error) - - let inline defaultValue (ifError: 'ok) (result: Result<'ok, 'error>) : 'ok = - match result with - | Ok x -> x - | Error _ -> ifError - - let inline defaultError (ifOk: 'error) (result: Result<'ok, 'error>) : 'error = - match result with - | Error error -> error - | Ok _ -> ifOk - - let inline defaultWith (ifErrorThunk: unit -> 'ok) (result: Result<'ok, 'error>) : 'ok = - match result with - | Ok x -> x - | Error _ -> ifErrorThunk () - - let inline ignoreError (result: Result) : unit = defaultValue () result - - let inline teeIf - (predicate: 'ok -> bool) - (inspector: 'ok -> unit) - (result: Result<'ok, 'error>) - : Result<'ok, 'error> = - match result with - | Ok x -> if predicate x then inspector x - | Error _ -> () - - result - - let inline teeErrorIf - (predicate: 'error -> bool) - (inspector: 'error -> unit) - (result: Result<'ok, 'error>) - : Result<'ok, 'error> = - match result with - | Ok _ -> () - | Error x -> if predicate x then inspector x - - result - - let inline tee (inspector: 'ok -> unit) (result: Result<'ok, 'error>) : Result<'ok, 'error> = - teeIf (fun _ -> true) inspector result - - let inline teeError - (inspector: 'error -> unit) - (result: Result<'ok, 'error>) - : Result<'ok, 'error> = - teeErrorIf (fun _ -> true) inspector result - - let inline valueOr (f: 'error -> 'ok) (res: Result<'ok, 'error>) : 'ok = - match res with - | Ok x -> x - | Error x -> f x - - let zip (left: Result<'leftOk, 'error>) (right: Result<'rightOk, 'error>) : Result<'leftOk * 'rightOk, 'error> = - match left, right with - | Ok x1res, Ok x2res -> Ok(x1res, x2res) - | Error e, _ -> Error e - | _, Error e -> Error e - - let zipError - (left: Result<'ok, 'leftError>) - (right: Result<'ok, 'rightError>) - : Result<'ok, 'leftError * 'rightError> = - match left, right with - | Error x1res, Error x2res -> Error(x1res, x2res) - | Ok e, _ -> Ok e - | _, Ok e -> Ok e - - map id - -let whatever x = SomethingToCompile f x From 992cb2210603dd482d2706aa19bc1dc243b79feb Mon Sep 17 00:00:00 2001 From: 0101 <0101@innit.cz> Date: Tue, 1 Nov 2022 13:25:38 +0100 Subject: [PATCH 3/7] Added workflows for adding and removing files --- .../FSharpChecker/CommonWorkflows.fs | 19 ++++++++++- .../ProjectGeneration.fs | 32 +++++++++++++++++++ 2 files changed, 50 insertions(+), 1 deletion(-) diff --git a/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs b/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs index 62e428fd5f9..b5fa9d070cd 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs +++ b/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs @@ -66,4 +66,21 @@ let ``Files depend on signature file if present`` () = updateFile "First" breakDependentFiles saveFile "First" checkFile "Second" expectNoChanges - } \ No newline at end of file + } + +[] +let ``Adding a file`` () = + projectWorkflow (makeTestProject()) { + addFileAbove "Second" (sourceFile "New" []) + updateFile "Second" (addDependency "New") + saveAll + checkFile "Last" (expectSignatureContains "val f: x: 'a -> (ModuleNew.TNewV_1<'a> * ModuleFirst.TFirstV_1<'a> * ModuleSecond.TSecondV_1<'a>) * (ModuleFirst.TFirstV_1<'a> * ModuleThird.TThirdV_1<'a>) * TLastV_1<'a>") + } + +[] +let ``Removing a file`` () = + projectWorkflow (makeTestProject()) { + removeFile "Second" + saveAll + checkFile "Last" expectErrors + } diff --git a/tests/FSharp.Test.Utilities/ProjectGeneration.fs b/tests/FSharp.Test.Utilities/ProjectGeneration.fs index fdc2741370c..87b4136dac6 100644 --- a/tests/FSharp.Test.Utilities/ProjectGeneration.fs +++ b/tests/FSharp.Test.Utilities/ProjectGeneration.fs @@ -186,6 +186,9 @@ module ProjectOperations = let setPublicVersion n f = { f with PublicVersion = n } + let addDependency fileId f = + { f with DependsOn = fileId :: f.DependsOn } + let checkFile fileId (project: SyntheticProject) (checker: FSharpChecker) = let file = project.Find fileId let contents = renderSourceFile project.Name file @@ -300,6 +303,35 @@ type ProjectWorkflowBuilder(initialProject: SyntheticProject, ?checker: FSharpCh return { ctx with Project = project } } + /// Add a file above given file in the project + [] + member this.AddFileAbove(x: Async, addAboveId: string, newFile) : Async = + async { + let! ctx = x + + let index = + ctx.Project.SourceFiles + |> List.tryFindIndex (fun f -> f.Id = addAboveId) + |> Option.defaultWith (fun () -> failwith $"File {addAboveId} not found") + + let project = + { ctx.Project with SourceFiles = ctx.Project.SourceFiles |> List.insertAt index newFile } + + return { ctx with Project = project } + } + + /// Remove a file from the project. The file is not deleted from disk. + [] + member this.RemoveFile(x: Async, fileId: string) : Async = + async { + let! ctx = x + + let project = + { ctx.Project with SourceFiles = ctx.Project.SourceFiles |> List.filter (fun f -> f.Id <> fileId) } + + return { ctx with Project = project } + } + /// Parse and type check given file and process the results using `processResults` function. [] member this.CheckFile(x: Async, fileId: string, processResults) = From 1aaefbc9813c040d9b00795a11cfc1961d71ee11 Mon Sep 17 00:00:00 2001 From: 0101 <0101@innit.cz> Date: Tue, 1 Nov 2022 13:49:29 +0100 Subject: [PATCH 4/7] refactoring --- .../ProjectGeneration.fs | 64 ++++++++----------- 1 file changed, 28 insertions(+), 36 deletions(-) diff --git a/tests/FSharp.Test.Utilities/ProjectGeneration.fs b/tests/FSharp.Test.Utilities/ProjectGeneration.fs index 87b4136dac6..8ca4b49f676 100644 --- a/tests/FSharp.Test.Utilities/ProjectGeneration.fs +++ b/tests/FSharp.Test.Utilities/ProjectGeneration.fs @@ -261,6 +261,12 @@ type ProjectWorkflowBuilder(initialProject: SyntheticProject, ?checker: FSharpCh let checker = defaultArg checker (FSharpChecker.Create()) + let mapProject f workflow = + async { + let! ctx = workflow + return { ctx with Project = f ctx.Project } + } + member this.Checker = checker member this.Yield _ = @@ -296,47 +302,33 @@ type ProjectWorkflowBuilder(initialProject: SyntheticProject, ?checker: FSharpCh /// Change contents of given file using `processFile` function. /// Does not save the file to disk. [] - member this.UpdateFile(x: Async, fileId: string, processFile) : Async = - async { - let! ctx = x - let project = ctx.Project |> updateFile fileId processFile - return { ctx with Project = project } - } + member this.UpdateFile(workflow: Async, fileId: string, processFile) = + workflow |> mapProject (updateFile fileId processFile) - /// Add a file above given file in the project + /// Add a file above given file in the project. [] - member this.AddFileAbove(x: Async, addAboveId: string, newFile) : Async = - async { - let! ctx = x - + member this.AddFileAbove(workflow: Async, addAboveId: string, newFile) = + workflow + |> mapProject (fun project -> let index = - ctx.Project.SourceFiles + project.SourceFiles |> List.tryFindIndex (fun f -> f.Id = addAboveId) |> Option.defaultWith (fun () -> failwith $"File {addAboveId} not found") - let project = - { ctx.Project with SourceFiles = ctx.Project.SourceFiles |> List.insertAt index newFile } - - return { ctx with Project = project } - } + { project with SourceFiles = project.SourceFiles |> List.insertAt index newFile }) /// Remove a file from the project. The file is not deleted from disk. [] - member this.RemoveFile(x: Async, fileId: string) : Async = - async { - let! ctx = x - - let project = - { ctx.Project with SourceFiles = ctx.Project.SourceFiles |> List.filter (fun f -> f.Id <> fileId) } - - return { ctx with Project = project } - } + member this.RemoveFile(workflow: Async, fileId: string) = + workflow + |> mapProject (fun project -> + { project with SourceFiles = project.SourceFiles |> List.filter (fun f -> f.Id <> fileId) }) /// Parse and type check given file and process the results using `processResults` function. [] - member this.CheckFile(x: Async, fileId: string, processResults) = + member this.CheckFile(workflow: Async, fileId: string, processResults) = async { - let! ctx = x + let! ctx = workflow let! results = checkFile fileId ctx.Project checker let oldSignature = ctx.Signatures.[fileId] @@ -349,23 +341,23 @@ type ProjectWorkflowBuilder(initialProject: SyntheticProject, ?checker: FSharpCh /// Save given file to disk. [] - member this.SaveFile(x: Async, fileId: string) = + member this.SaveFile(workflow: Async, fileId: string) = async { - let! ctx = x - let f = ctx.Project.Find fileId - writeFile ctx.Project f + let! ctx = workflow + let file = ctx.Project.Find fileId + writeFile ctx.Project file return ctx } - /// Save all files to disk + /// Save all files to disk. [] - member this.SaveAll(x: Async) = + member this.SaveAll(workflow: Async) = async { - let! ctx = x + let! ctx = workflow do! saveProject ctx.Project false checker return ctx } /// Execute a set of operations on a given synthetic project. /// The project is saved to disk and type checked at the start. -let projectWorkflow x = ProjectWorkflowBuilder x +let projectWorkflow project = ProjectWorkflowBuilder project From 2ebf7c3be50cb4453dd8e640d761b523fab3e034 Mon Sep 17 00:00:00 2001 From: 0101 <0101@innit.cz> Date: Wed, 2 Nov 2022 11:53:10 +0100 Subject: [PATCH 5/7] Added referenced projects --- .../FSharpChecker/CommonWorkflows.fs | 22 ++++++ .../ProjectGeneration.fs | 79 +++++++++++++++---- 2 files changed, 85 insertions(+), 16 deletions(-) diff --git a/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs b/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs index b5fa9d070cd..4f6c1ae0f05 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs +++ b/tests/FSharp.Compiler.ComponentTests/FSharpChecker/CommonWorkflows.fs @@ -21,6 +21,7 @@ let makeTestProject () = sourceFile "Third" ["First"] { sourceFile "Last" ["Second"; "Third"] with EntryPoint = true } ] + DependsOn = [] } [] @@ -84,3 +85,24 @@ let ``Removing a file`` () = saveAll checkFile "Last" expectErrors } + +[] +let ``Changes in a referenced project`` () = + let name = $"library{Guid.NewGuid().ToString()[..7]}" + let dir = Path.GetFullPath projectDir + let library = { + Name = name + ProjectDir = dir ++ name + SourceFiles = [ sourceFile "Library" [] ] + DependsOn = [] + } + + let project = + { makeTestProject() with DependsOn = [library] } + |> updateFile "First" (addDependency "Library") + + projectWorkflow project { + updateFile "Library" updatePublicSurface + saveFile "Library" + checkFile "Last" expectSignatureChanged + } diff --git a/tests/FSharp.Test.Utilities/ProjectGeneration.fs b/tests/FSharp.Test.Utilities/ProjectGeneration.fs index 8ca4b49f676..af9c10e62ec 100644 --- a/tests/FSharp.Test.Utilities/ProjectGeneration.fs +++ b/tests/FSharp.Test.Utilities/ProjectGeneration.fs @@ -58,20 +58,28 @@ let sourceFile fileId deps = type SyntheticProject = { Name: string ProjectDir: string - SourceFiles: SyntheticSourceFile list } + SourceFiles: SyntheticSourceFile list + DependsOn: SyntheticProject list } member this.Find fileId = this.SourceFiles |> List.tryFind (fun f -> f.Id = fileId) - |> Option.defaultWith (fun () -> failwith $"File with ID '{fileId}' not found in project {this.Name}") + |> Option.defaultWith (fun () -> failwith $"File with ID '{fileId}' not found in project {this.Name}.") + + member this.FindInAllProjects fileId = + this.GetAllFiles() + |> List.tryFind (fun (_, f) -> f.Id = fileId) + |> Option.defaultWith (fun () -> failwith $"File with ID '{fileId}' not found in any project.") member this.FindByPath path = this.SourceFiles |> List.tryFind (fun f -> this.ProjectDir ++ f.FileName = path) - |> Option.defaultWith (fun () -> failwith $"File {path} not found in project {this.Name}") + |> Option.defaultWith (fun () -> failwith $"File {path} not found in project {this.Name}.") member this.ProjectFileName = this.ProjectDir ++ $"{this.Name}.fsproj" + member this.OutputFilename = this.ProjectDir ++ $"{this.Name}.dll" + member this.ProjectOptions = { ProjectFileName = this.ProjectFileName ProjectId = None @@ -81,8 +89,14 @@ type SyntheticProject = this.ProjectDir ++ f.SignatureFileName this.ProjectDir ++ f.FileName |] - OtherOptions = [| "--optimize+" |] - ReferencedProjects = [||] + OtherOptions = + [| + "--optimize+" + for p in this.DependsOn do + $"-r:{p.OutputFilename}" |] + ReferencedProjects = + [| for p in this.DependsOn do + FSharpReferencedProject.CreateFSharp(p.OutputFilename, p.ProjectOptions) |] IsIncompleteTypeCheckEnvironment = false UseScriptResolutionRules = false LoadTime = DateTime() @@ -90,14 +104,21 @@ type SyntheticProject = OriginalLoadReferences = [] Stamp = None } + member this.GetAllFiles() = [ + for f in this.SourceFiles do + this, f + for p in this.DependsOn do + yield! p.GetAllFiles() ] -module Internal = - let extraCodeToCompile = File.ReadAllText(projectRoot ++ "SomethingToCompile.fs") +module Internal = - let renderSourceFile projectName (f: SyntheticSourceFile) = + let renderSourceFile (project: SyntheticProject) (f: SyntheticSourceFile) = seq { - $"module %s{projectName}.Module{f.Id}" + $"module %s{project.Name}.Module{f.Id}" + + for p in project.DependsOn do + $"open {p.Name}" $"type T{f.Id}V_{f.PublicVersion}<'a> = T{f.Id} of 'a" @@ -154,9 +175,15 @@ module Internal = let writeFile (p: SyntheticProject) (f: SyntheticSourceFile) = let fileName = p.ProjectDir ++ f.FileName - let content = renderSourceFile p.Name f + let content = renderSourceFile p f writeFileIfChanged fileName content + let validateFileIdsAreUnique (project: SyntheticProject) = + let ids = [for _, f in project.GetAllFiles() -> f.Id] + let duplicates = ids |> List.groupBy id |> List.filter (fun (_, g) -> g.Length > 1) + if duplicates.Length > 0 then + failwith $"""Source file IDs have to be unique across the project and all referenced projects. Found duplicates: {String.Join(", ", duplicates |> List.map fst)}""" + open Internal @@ -172,6 +199,21 @@ module ProjectOperations = project.SourceFiles |> List.updateAt index (updateFunction project.SourceFiles[index]) } + let updateFileInAnyProject fileId updateFunction (rootProject: SyntheticProject) = + let project, _ = + rootProject.GetAllFiles() + |> List.tryFind (fun (_, f) -> f.Id = fileId) + |> Option.defaultWith (fun () -> failwith $"File with ID '{fileId}' not found in any project") + + if project = rootProject then + updateFile fileId updateFunction project + else + let index = rootProject.DependsOn |> List.findIndex ((=) project) + { rootProject with + DependsOn = + rootProject.DependsOn + |> List.updateAt index (updateFile fileId updateFunction project) } + let private counter = (Seq.initInfinite id).GetEnumerator() let updatePublicSurface f = @@ -186,12 +228,12 @@ module ProjectOperations = let setPublicVersion n f = { f with PublicVersion = n } - let addDependency fileId f = + let addDependency fileId f: SyntheticSourceFile = { f with DependsOn = fileId :: f.DependsOn } let checkFile fileId (project: SyntheticProject) (checker: FSharpChecker) = let file = project.Find fileId - let contents = renderSourceFile project.Name file + let contents = renderSourceFile project file let absFileName = project.ProjectDir ++ file.FileName checker.ParseAndCheckFileInProject(absFileName, 0, SourceText.ofString contents, project.ProjectOptions) @@ -235,10 +277,13 @@ module ProjectOperations = expectOk result () Assert.Equal(oldSignature, newSignature) - let saveProject (p: SyntheticProject) generateSignatureFiles checker = + let rec saveProject (p: SyntheticProject) generateSignatureFiles checker = async { Directory.CreateDirectory(p.ProjectDir) |> ignore + for ref in p.DependsOn do + do! saveProject ref generateSignatureFiles checker + for i in 0 .. p.SourceFiles.Length - 1 do let file = p.SourceFiles.[i] writeFile p file @@ -271,6 +316,8 @@ type ProjectWorkflowBuilder(initialProject: SyntheticProject, ?checker: FSharpCh member this.Yield _ = async { + validateFileIdsAreUnique initialProject + do! saveProject initialProject true checker let! results = checker.ParseAndCheckProject(initialProject.ProjectOptions) @@ -303,7 +350,7 @@ type ProjectWorkflowBuilder(initialProject: SyntheticProject, ?checker: FSharpCh /// Does not save the file to disk. [] member this.UpdateFile(workflow: Async, fileId: string, processFile) = - workflow |> mapProject (updateFile fileId processFile) + workflow |> mapProject (updateFileInAnyProject fileId processFile) /// Add a file above given file in the project. [] @@ -344,8 +391,8 @@ type ProjectWorkflowBuilder(initialProject: SyntheticProject, ?checker: FSharpCh member this.SaveFile(workflow: Async, fileId: string) = async { let! ctx = workflow - let file = ctx.Project.Find fileId - writeFile ctx.Project file + let project, file = ctx.Project.FindInAllProjects fileId + writeFile project file return ctx } From 0863dac26a9256a5905fceed2926b8ca4af5296b Mon Sep 17 00:00:00 2001 From: 0101 <0101@innit.cz> Date: Wed, 2 Nov 2022 11:55:30 +0100 Subject: [PATCH 6/7] fantomas --- .../ProjectGeneration.fs | 28 ++++++++++--------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/tests/FSharp.Test.Utilities/ProjectGeneration.fs b/tests/FSharp.Test.Utilities/ProjectGeneration.fs index af9c10e62ec..c6909c792b1 100644 --- a/tests/FSharp.Test.Utilities/ProjectGeneration.fs +++ b/tests/FSharp.Test.Utilities/ProjectGeneration.fs @@ -90,13 +90,12 @@ type SyntheticProject = this.ProjectDir ++ f.FileName |] OtherOptions = - [| - "--optimize+" - for p in this.DependsOn do - $"-r:{p.OutputFilename}" |] + [| "--optimize+" + for p in this.DependsOn do + $"-r:{p.OutputFilename}" |] ReferencedProjects = [| for p in this.DependsOn do - FSharpReferencedProject.CreateFSharp(p.OutputFilename, p.ProjectOptions) |] + FSharpReferencedProject.CreateFSharp(p.OutputFilename, p.ProjectOptions) |] IsIncompleteTypeCheckEnvironment = false UseScriptResolutionRules = false LoadTime = DateTime() @@ -104,11 +103,11 @@ type SyntheticProject = OriginalLoadReferences = [] Stamp = None } - member this.GetAllFiles() = [ - for f in this.SourceFiles do - this, f - for p in this.DependsOn do - yield! p.GetAllFiles() ] + member this.GetAllFiles() = + [ for f in this.SourceFiles do + this, f + for p in this.DependsOn do + yield! p.GetAllFiles() ] module Internal = @@ -179,10 +178,12 @@ module Internal = writeFileIfChanged fileName content let validateFileIdsAreUnique (project: SyntheticProject) = - let ids = [for _, f in project.GetAllFiles() -> f.Id] + let ids = [ for _, f in project.GetAllFiles() -> f.Id ] let duplicates = ids |> List.groupBy id |> List.filter (fun (_, g) -> g.Length > 1) + if duplicates.Length > 0 then - failwith $"""Source file IDs have to be unique across the project and all referenced projects. Found duplicates: {String.Join(", ", duplicates |> List.map fst)}""" + failwith + $"""Source file IDs have to be unique across the project and all referenced projects. Found duplicates: {String.Join(", ", duplicates |> List.map fst)}""" open Internal @@ -209,6 +210,7 @@ module ProjectOperations = updateFile fileId updateFunction project else let index = rootProject.DependsOn |> List.findIndex ((=) project) + { rootProject with DependsOn = rootProject.DependsOn @@ -228,7 +230,7 @@ module ProjectOperations = let setPublicVersion n f = { f with PublicVersion = n } - let addDependency fileId f: SyntheticSourceFile = + let addDependency fileId f : SyntheticSourceFile = { f with DependsOn = fileId :: f.DependsOn } let checkFile fileId (project: SyntheticProject) (checker: FSharpChecker) = From dde66a469dce0a20ac7e5245937d2849f4e271b4 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Wed, 2 Nov 2022 13:32:59 +0100 Subject: [PATCH 7/7] Make it work on non-windows --- .../ProjectGeneration.fs | 68 +++++++++++-------- 1 file changed, 40 insertions(+), 28 deletions(-) diff --git a/tests/FSharp.Test.Utilities/ProjectGeneration.fs b/tests/FSharp.Test.Utilities/ProjectGeneration.fs index c6909c792b1..4f3ad9b4aee 100644 --- a/tests/FSharp.Test.Utilities/ProjectGeneration.fs +++ b/tests/FSharp.Test.Utilities/ProjectGeneration.fs @@ -4,7 +4,7 @@ /// The function calls functions from all the files the given file depends on and returns their /// results + it's own type in a tuple. /// -/// To model changes, we change the type name in a file which resutls in signatures of all the +/// To model changes, we change the type name in a file which results in signatures of all the /// dependent files also changing. /// /// To model breaking changes we change the name of the function which will make dependent files @@ -80,28 +80,34 @@ type SyntheticProject = member this.OutputFilename = this.ProjectDir ++ $"{this.Name}.dll" - member this.ProjectOptions = - { ProjectFileName = this.ProjectFileName - ProjectId = None - SourceFiles = - [| for f in this.SourceFiles do - if f.HasSignatureFile then - this.ProjectDir ++ f.SignatureFileName - - this.ProjectDir ++ f.FileName |] - OtherOptions = - [| "--optimize+" - for p in this.DependsOn do - $"-r:{p.OutputFilename}" |] - ReferencedProjects = - [| for p in this.DependsOn do - FSharpReferencedProject.CreateFSharp(p.OutputFilename, p.ProjectOptions) |] - IsIncompleteTypeCheckEnvironment = false - UseScriptResolutionRules = false - LoadTime = DateTime() - UnresolvedReferences = None - OriginalLoadReferences = [] - Stamp = None } + member this.GetProjectOptions(checker: FSharpChecker) = + let baseOptions, _ = + checker.GetProjectOptionsFromScript("file.fs", SourceText.ofString "", assumeDotNetFramework = false) + |> Async.RunSynchronously + + { baseOptions with + ProjectFileName = this.ProjectFileName + ProjectId = None + SourceFiles = + [| for f in this.SourceFiles do + if f.HasSignatureFile then + this.ProjectDir ++ f.SignatureFileName + + this.ProjectDir ++ f.FileName |] + OtherOptions = + [| yield! baseOptions.OtherOptions + "--optimize+" + for p in this.DependsOn do + $"-r:{p.OutputFilename}" |] + ReferencedProjects = + [| for p in this.DependsOn do + FSharpReferencedProject.CreateFSharp(p.OutputFilename, p.GetProjectOptions checker) |] + IsIncompleteTypeCheckEnvironment = false + UseScriptResolutionRules = false + LoadTime = DateTime() + UnresolvedReferences = None + OriginalLoadReferences = [] + Stamp = None } member this.GetAllFiles() = [ for f in this.SourceFiles do @@ -237,7 +243,13 @@ module ProjectOperations = let file = project.Find fileId let contents = renderSourceFile project file let absFileName = project.ProjectDir ++ file.FileName - checker.ParseAndCheckFileInProject(absFileName, 0, SourceText.ofString contents, project.ProjectOptions) + + checker.ParseAndCheckFileInProject( + absFileName, + 0, + SourceText.ofString contents, + project.GetProjectOptions checker + ) let getTypeCheckResult (parseResults: FSharpParseFileResults, checkResults: FSharpCheckFileAnswer) = Assert.True(not parseResults.ParseHadErrors) @@ -287,11 +299,11 @@ module ProjectOperations = do! saveProject ref generateSignatureFiles checker for i in 0 .. p.SourceFiles.Length - 1 do - let file = p.SourceFiles.[i] + let file = p.SourceFiles[i] writeFile p file if file.HasSignatureFile && generateSignatureFiles then - let project = { p with SourceFiles = p.SourceFiles.[0..i] } + let project = { p with SourceFiles = p.SourceFiles[0..i] } let! results = checkFile file.Id project checker let signature = getSignature results let signatureFileName = p.ProjectDir ++ file.SignatureFileName @@ -322,7 +334,7 @@ type ProjectWorkflowBuilder(initialProject: SyntheticProject, ?checker: FSharpCh do! saveProject initialProject true checker - let! results = checker.ParseAndCheckProject(initialProject.ProjectOptions) + let! results = checker.ParseAndCheckProject(initialProject.GetProjectOptions checker) if not (Array.isEmpty results.Diagnostics) then failwith $"Project {initialProject.Name} failed initial check: \n%A{results.Diagnostics}" @@ -380,7 +392,7 @@ type ProjectWorkflowBuilder(initialProject: SyntheticProject, ?checker: FSharpCh let! ctx = workflow let! results = checkFile fileId ctx.Project checker - let oldSignature = ctx.Signatures.[fileId] + let oldSignature = ctx.Signatures[fileId] let newSignature = getSignature results processResults results (oldSignature, newSignature)