From 3bc0c4e9e8cb8f70818c7b041bdacb211829a570 Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Tue, 12 May 2026 06:36:50 +0200 Subject: [PATCH] Empty Program.fs --- Mutannot/Program.fs | 579 +------------------------------------------- 1 file changed, 1 insertion(+), 578 deletions(-) diff --git a/Mutannot/Program.fs b/Mutannot/Program.fs index 9baab14..5b77edb 100644 --- a/Mutannot/Program.fs +++ b/Mutannot/Program.fs @@ -1,579 +1,2 @@ -open System -open System.Collections.Generic -open System.Diagnostics -open System.IO -open System.Reflection - -exception UserError of string - -type MutationCase = - { Id: string - File: string - Line: int - Find: string - Replace: string - TestName: string - DeclaringType: string } - -type MutationOutcome = - | Killed - | Survived - | BuildFailed - -type Command = - | Validate - | List - | Show of string - | Run of string list - -type Options = - { Configuration: string - ProjectPath: string - BuildArgs: string list - NoBuild: bool - Command: Command } - -type ProjectInfo = - { RelativeProjectPath: string - AbsoluteProjectPath: string } - -let fail message = - raise (UserError message) - -let runProcess (workingDirectory: string) (exe: string) (args: string list) = - let psi = ProcessStartInfo() - psi.FileName <- exe - psi.WorkingDirectory <- workingDirectory - psi.RedirectStandardOutput <- false - psi.RedirectStandardError <- false - psi.UseShellExecute <- false - - for arg in args do - psi.ArgumentList.Add arg - - use proc = new Process() - proc.StartInfo <- psi - - if not (proc.Start()) then - failwithf "Failed to start %s" exe - - proc.WaitForExit() - proc.ExitCode - -let captureProcess (workingDirectory: string) (exe: string) (args: string list) = - let psi = ProcessStartInfo() - psi.FileName <- exe - psi.WorkingDirectory <- workingDirectory - psi.RedirectStandardOutput <- true - psi.RedirectStandardError <- true - psi.UseShellExecute <- false - - for arg in args do - psi.ArgumentList.Add arg - - use proc = new Process() - proc.StartInfo <- psi - - if not (proc.Start()) then - failwithf "Failed to start %s" exe - - let stdout = proc.StandardOutput.ReadToEnd() - let stderr = proc.StandardError.ReadToEnd() - proc.WaitForExit() - proc.ExitCode, stdout, stderr - -let repoRoot = - let exitCode, stdout, stderr = - captureProcess Environment.CurrentDirectory "git" [ "rev-parse"; "--show-toplevel" ] - - if exitCode <> 0 then - fail stderr - - stdout.Trim() - -let parseArgs (args: string list) = - let usage () = - fail "Usage: mutannot [--configuration Debug|Release] [--build-arg ...] [--no-build] [--validate | --list | --show | --run [id...]]" - - let rec loop configuration projectPath buildArgs noBuild remaining = - match remaining with - | [] -> - { Configuration = configuration - ProjectPath = projectPath - BuildArgs = List.rev buildArgs - NoBuild = noBuild - Command = Run [] } - | "--configuration" :: value :: tail -> loop value projectPath buildArgs noBuild tail - | "--build-arg" :: value :: tail -> loop configuration projectPath (value :: buildArgs) noBuild tail - | "--no-build" :: tail -> loop configuration projectPath buildArgs true tail - | "--validate" :: tail when tail.IsEmpty -> - { Configuration = configuration - ProjectPath = projectPath - BuildArgs = List.rev buildArgs - NoBuild = noBuild - Command = Validate } - | "--list" :: tail when tail.IsEmpty -> - { Configuration = configuration - ProjectPath = projectPath - BuildArgs = List.rev buildArgs - NoBuild = noBuild - Command = List } - | "--show" :: id :: tail when tail.IsEmpty -> - { Configuration = configuration - ProjectPath = projectPath - BuildArgs = List.rev buildArgs - NoBuild = noBuild - Command = Show id } - | "--run" :: tail -> - { Configuration = configuration - ProjectPath = projectPath - BuildArgs = List.rev buildArgs - NoBuild = noBuild - Command = Run tail } - | value :: tail when not (value.StartsWith "--") -> - { Configuration = configuration - ProjectPath = projectPath - BuildArgs = List.rev buildArgs - NoBuild = noBuild - Command = Run (value :: tail) } - | _ -> usage () - - match args with - | projectPath :: tail when not (projectPath.StartsWith "--") -> loop "Debug" projectPath [] false tail - | _ -> usage () - -let ensureWithinRepo (path: string) = - let relativePath = Path.GetRelativePath(repoRoot, path) - - if relativePath = ".." || relativePath.StartsWith($"..{Path.DirectorySeparatorChar}") then - fail $"Project path must be inside the repository: {path}" - - relativePath - -let loadProjectInfo (projectPath: string) = - let absoluteProjectPath = - if Path.IsPathRooted projectPath then - projectPath - else - Path.GetFullPath(Path.Combine(Environment.CurrentDirectory, projectPath)) - - if not (File.Exists absoluteProjectPath) then - fail $"Project file not found: {absoluteProjectPath}" - - let relativeProjectPath = ensureWithinRepo absoluteProjectPath - - { RelativeProjectPath = relativeProjectPath - AbsoluteProjectPath = absoluteProjectPath } - -let targetPathForProject (workingDirectory: string) (projectPath: string) (configuration: string) = - let exitCode, stdout, stderr = - captureProcess - workingDirectory - "dotnet" - [ "msbuild" - projectPath - "--getProperty:TargetPath" - $"-property:Configuration={configuration}" ] - - if exitCode <> 0 then - fail stderr - - let targetPath = stdout.Trim() - - if String.IsNullOrWhiteSpace targetPath then - fail $"MSBuild did not return a TargetPath for {projectPath}." - - targetPath - -let buildArgs configuration extraArgs projectPath = - [ "build"; projectPath; "--configuration"; configuration; "--nologo" ] @ extraArgs - -let ensureBuilt options project assemblyPath = - if not options.NoBuild then - let exitCode = runProcess repoRoot "dotnet" (buildArgs options.Configuration options.BuildArgs project.RelativeProjectPath) - - if exitCode <> 0 then - fail "dotnet build failed." - - if not (File.Exists assemblyPath) then - fail $"Compiled test assembly not found at {assemblyPath}." - -let requireConstructorArgumentString (args: IList) index name = - match args[index].Value with - | :? string as value when not (isNull value) -> value - | null -> fail $"MutationCaseAttribute constructor argument '{name}' must not be null." - | value -> - fail - $"MutationCaseAttribute constructor argument '{name}' had unexpected type '{value.GetType().FullName}'." - -let requireConstructorArgumentInt32 (args: IList) index name = - match args[index].Value with - | :? int as value -> value - | null -> fail $"MutationCaseAttribute constructor argument '{name}' must not be null." - | value -> - fail - $"MutationCaseAttribute constructor argument '{name}' had unexpected type '{value.GetType().FullName}'." - -let metadataLoadContextPaths (assemblyPath: string) = - let assemblyDir = Path.GetDirectoryName assemblyPath - - let runtimeAssemblies = - match AppContext.GetData "TRUSTED_PLATFORM_ASSEMBLIES" with - | :? string as value when not (String.IsNullOrWhiteSpace value) -> - value.Split(Path.PathSeparator, StringSplitOptions.RemoveEmptyEntries) - | _ -> fail "Unable to discover trusted platform assemblies for MetadataLoadContext." - - let localAssemblies = - seq { - yield assemblyPath - yield! Directory.EnumerateFiles(assemblyDir, "*.dll") - yield! Directory.EnumerateFiles(assemblyDir, "*.exe") - } - - Seq.append runtimeAssemblies localAssemblies - |> Seq.distinct - |> Seq.toArray - -let createMetadataLoadContext (assemblyPath: string) = - let resolver = PathAssemblyResolver(metadataLoadContextPaths assemblyPath) - let coreAssemblyName = typeof.Assembly.GetName().Name - - new MetadataLoadContext(resolver, coreAssemblyName) - -let mutationCases options project assemblyPath = - ensureBuilt options project assemblyPath - - use mlc = createMetadataLoadContext assemblyPath - let asm = mlc.LoadFromAssemblyPath assemblyPath - - asm.GetTypes() - |> Array.collect (fun t -> - let declaringType = - match t.FullName with - | null -> t.Name - | name -> name - - t.GetMethods(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static ||| BindingFlags.Instance) - |> Array.collect (fun m -> - m.GetCustomAttributesData() - |> Seq.choose (fun attr -> - if attr.AttributeType.FullName <> "Mutannot.MutationCaseAttribute" then - None - else - let args = attr.ConstructorArguments - - if args.Count <> 5 then - fail $"Unexpected MutationCaseAttribute shape on {declaringType}.{m.Name}" - - Some - { Id = requireConstructorArgumentString args 0 "id" - File = requireConstructorArgumentString args 1 "file" - Line = requireConstructorArgumentInt32 args 2 "line" - Find = requireConstructorArgumentString args 3 "find" - Replace = requireConstructorArgumentString args 4 "replace" - TestName = m.Name - DeclaringType = declaringType }) - |> Seq.toArray)) - |> Array.sortBy (fun mutation -> mutation.Id) - -let findMutation id mutations = - mutations - |> Array.tryFind (fun mutation -> mutation.Id = id) - |> Option.defaultWith (fun () -> fail $"Unknown mutation id: {id}") - -let lineSpan (filePath: string) (text: string) (lineNumber: int) = - if lineNumber < 1 then - fail $"Line number must be positive: {lineNumber}" - - let mutable currentLine = 1 - let mutable lineStart = 0 - let mutable index = 0 - - while index < text.Length && currentLine < lineNumber do - if text[index] = '\n' then - currentLine <- currentLine + 1 - lineStart <- index + 1 - - index <- index + 1 - - if currentLine <> lineNumber then - fail $"Line {lineNumber} does not exist in {filePath}" - - let mutable lineEnd = lineStart - - while lineEnd < text.Length && text[lineEnd] <> '\n' && text[lineEnd] <> '\r' do - lineEnd <- lineEnd + 1 - - lineStart, lineEnd - -let replaceOccurrenceOnLine (mutation: MutationCase) (text: string) = - let lineStart, lineEnd = lineSpan mutation.File text mutation.Line - let lineText = text.Substring(lineStart, lineEnd - lineStart) - let lineOffset = lineText.IndexOf(mutation.Find, StringComparison.Ordinal) - - if lineOffset < 0 then - fail $"Line {mutation.Line} in {mutation.File} does not contain '{mutation.Find}'." - - let absoluteOffset = lineStart + lineOffset - text.Remove(absoluteOffset, mutation.Find.Length).Insert(absoluteOffset, mutation.Replace) - -let countOccurrencesOnLine (needle: string) (lineText: string) = - if String.IsNullOrEmpty needle then - 0 - else - let mutable count = 0 - let mutable startIndex = 0 - let mutable keepSearching = true - - while keepSearching do - let index = lineText.IndexOf(needle, startIndex, StringComparison.Ordinal) - - if index < 0 then - keepSearching <- false - else - count <- count + 1 - startIndex <- index + needle.Length - - count - -let trimLineForDisplay (lineText: string) = - let trimmed = lineText.Trim() - - if String.IsNullOrEmpty trimmed then - "" - else - trimmed - -let staleMutationMessage (mutation: MutationCase) (detail: string) = - $"Mutation '{mutation.Id}' is stale: the recorded target at {mutation.File}:{mutation.Line} no longer matches the current source. {detail} Re-locate the intended mutation and update its file/line/find metadata." - -let validateMutation (repoRoot: string) (mutation: MutationCase) = - let targetFile = Path.Combine(repoRoot, mutation.File.Replace('/', Path.DirectorySeparatorChar)) - - if String.IsNullOrEmpty mutation.Find then - Some(staleMutationMessage mutation "The recorded find text is empty.") - elif not (File.Exists targetFile) then - Some(staleMutationMessage mutation $"The target file '{mutation.File}' no longer exists.") - else - let originalText = File.ReadAllText targetFile - - try - let lineStart, lineEnd = lineSpan mutation.File originalText mutation.Line - let lineText = originalText.Substring(lineStart, lineEnd - lineStart) - let occurrenceCount = countOccurrencesOnLine mutation.Find lineText - - match occurrenceCount with - | 0 -> - Some - (staleMutationMessage - mutation - $"Expected to find '{mutation.Find}' on that line, but it has changed to '{trimLineForDisplay lineText}'.") - | 1 -> None - | count -> - Some - (staleMutationMessage - mutation - $"The text '{mutation.Find}' now appears {count} times on that line, so the recorded target is no longer unique. Current line: '{trimLineForDisplay lineText}'.") - with - | UserError message -> Some(staleMutationMessage mutation message) - -let printValidationErrors errors = - eprintfn "Validation failed for %d mutation(s):" (errors |> List.length) - - for mutation, message in errors do - eprintfn "[%s] %s:%d %s" mutation.Id mutation.File mutation.Line message - -let collectValidationErrors repoRoot mutations = - mutations - |> List.choose (fun mutation -> validateMutation repoRoot mutation |> Option.map (fun message -> mutation, message)) - -let printMutation mutation = - printfn "id: %s" mutation.Id - printfn "test: %s.%s" mutation.DeclaringType mutation.TestName - printfn "file: %s:%d" mutation.File mutation.Line - printfn "find: %s" mutation.Find - printfn "replace: %s" mutation.Replace - -let splitNullSeparated (text: string) = - text.Split('\000', StringSplitOptions.RemoveEmptyEntries) |> Array.toList - -let repoRelativePath (path: string) = - path.Replace('/', Path.DirectorySeparatorChar) - -let listUntrackedFiles () = - let exitCode, stdout, stderr = - captureProcess repoRoot "git" [ "ls-files"; "--others"; "--exclude-standard"; "-z" ] - - if exitCode <> 0 then - fail stderr - - splitNullSeparated stdout - -let copyFileIntoWorktree (repoRoot: string) (worktreePath: string) (relativePath: string) = - let sourcePath = Path.Combine(repoRoot, repoRelativePath relativePath) - let destinationPath = Path.Combine(worktreePath, repoRelativePath relativePath) - let destinationDir = Path.GetDirectoryName destinationPath - - if not (String.IsNullOrEmpty destinationDir) then - Directory.CreateDirectory(destinationDir) |> ignore - - File.Copy(sourcePath, destinationPath, true) - -let cleanup (tempRoot: string) (worktreePath: string) = - if Directory.Exists worktreePath then - let _ = captureProcess repoRoot "git" [ "worktree"; "remove"; "--force"; worktreePath ] - () - - if Directory.Exists tempRoot then - Directory.Delete(tempRoot, true) - -let createWorktree (patchPath: string) (worktreePath: string) = - let tempRoot = Path.GetDirectoryName patchPath - Directory.CreateDirectory(tempRoot) |> ignore - - let untrackedFiles = listUntrackedFiles () - let exitCode, diffText, stderr = captureProcess repoRoot "git" [ "diff"; "--binary"; "HEAD" ] - - if exitCode <> 0 then - fail stderr - - File.WriteAllText(patchPath, diffText) - - let exitCode2, stdout2, stderr2 = captureProcess repoRoot "git" [ "rev-parse"; "HEAD" ] - - if exitCode2 <> 0 then - fail stderr2 - - let baseRev = stdout2.Trim() - let exitCode3, _, stderr3 = captureProcess repoRoot "git" [ "worktree"; "add"; "--detach"; worktreePath; baseRev ] - - if exitCode3 <> 0 then - fail stderr3 - - if FileInfo(patchPath).Length > 0L then - let exitCode4, _, stderr4 = captureProcess worktreePath "git" [ "apply"; patchPath ] - - if exitCode4 <> 0 then - fail stderr4 - - for relativePath in untrackedFiles do - copyFileIntoWorktree repoRoot worktreePath relativePath - -let fullyQualifiedTestName mutation = - let declaringType = mutation.DeclaringType.Replace('+', '.') - $"{declaringType}.{mutation.TestName}" - -let testFilter mutation = - $"FullyQualifiedName={fullyQualifiedTestName mutation}" - -let runMutation options project worktreePath mutation = - let targetFile = Path.Combine(worktreePath, mutation.File.Replace('/', Path.DirectorySeparatorChar)) - - if not (File.Exists targetFile) then - fail $"Target file does not exist in worktree: {targetFile}" - - let originalText = File.ReadAllText targetFile - let mutatedText = replaceOccurrenceOnLine mutation originalText - File.WriteAllText(targetFile, mutatedText) - - printfn "==> %s: %s" mutation.Id mutation.TestName - - let buildExitCode = - runProcess worktreePath "dotnet" (buildArgs options.Configuration options.BuildArgs project.RelativeProjectPath) - - let outcome = - if buildExitCode <> 0 then - printfn "BUILD FAILED %s" mutation.Id - BuildFailed - else - let testExitCode = - runProcess - worktreePath - "dotnet" - [ "test" - project.RelativeProjectPath - "--configuration" - options.Configuration - "--filter" - testFilter mutation - "--no-build" - "--nologo" ] - - if testExitCode = 0 then - printfn "SURVIVED %s" mutation.Id - Survived - else - printfn "KILLED %s" mutation.Id - Killed - - File.WriteAllText(targetFile, originalText) - outcome - [] -let main argv = - try - let options = parseArgs (argv |> Array.toList) - let project = loadProjectInfo options.ProjectPath - let assemblyPath = targetPathForProject repoRoot project.AbsoluteProjectPath options.Configuration - let mutations = mutationCases options project assemblyPath - - if Array.isEmpty mutations then - fail "No mutation cases were discovered in the test assembly." - - match options.Command with - | Validate -> - let validationErrors = mutations |> Array.toList |> collectValidationErrors repoRoot - - if validationErrors.IsEmpty then - printfn "Validated %d mutation(s): all still apply syntactically." mutations.Length - 0 - else - printValidationErrors validationErrors - 1 - | List -> - mutations - |> Array.iter (fun mutation -> - printfn "%s\t%s\t%s:%d" mutation.Id mutation.TestName mutation.File mutation.Line) - - 0 - | Show id -> - let mutation = findMutation id mutations - printMutation mutation - 0 - | Run ids -> - let requested = - match ids with - | [] -> mutations |> Array.toList - | _ -> ids |> List.map (fun id -> findMutation id mutations) - - let validationErrors = collectValidationErrors repoRoot requested - - if not validationErrors.IsEmpty then - printValidationErrors validationErrors - 1 - else - - let tempRoot = Path.Combine(Path.GetTempPath(), $"fscheck-mutants.{Guid.NewGuid():N}") - let worktreePath = Path.Combine(tempRoot, "worktree") - let patchPath = Path.Combine(tempRoot, "current.patch") - - try - createWorktree patchPath worktreePath - - let outcomes = - requested |> List.map (runMutation options project worktreePath) - - let survivors = outcomes |> List.filter ((=) Survived) |> List.length - let buildFailures = outcomes |> List.filter ((=) BuildFailed) |> List.length - - if survivors = 0 && buildFailures = 0 then - printfn "All requested mutants were killed." - 0 - else - fail $"{survivors} mutant(s) survived. {buildFailures} mutant(s) failed to build." - finally - cleanup tempRoot worktreePath - with - | UserError message -> - eprintfn "%s" message - 1 +let main argv = 0