From f7e7daf3252b017c49a71e14ecff6a907009ebb5 Mon Sep 17 00:00:00 2001 From: Sven van Heugten Date: Tue, 28 Apr 2026 08:23:17 +0200 Subject: [PATCH] Package --- Mutannot/Mutannot.fsproj | 12 ++ Mutannot/Program.fs | 454 +++++++++++++++++++++++++++++++++++++++ Mutannot/deps.nix | 8 + flake.lock | 27 +++ flake.nix | 57 +++++ 5 files changed, 558 insertions(+) create mode 100644 Mutannot/Mutannot.fsproj create mode 100644 Mutannot/Program.fs create mode 100644 Mutannot/deps.nix create mode 100644 flake.lock create mode 100644 flake.nix diff --git a/Mutannot/Mutannot.fsproj b/Mutannot/Mutannot.fsproj new file mode 100644 index 0000000..3329a09 --- /dev/null +++ b/Mutannot/Mutannot.fsproj @@ -0,0 +1,12 @@ + + + Exe + net10.0 + mutannot + false + + + + + + diff --git a/Mutannot/Program.fs b/Mutannot/Program.fs new file mode 100644 index 0000000..6f8d0e9 --- /dev/null +++ b/Mutannot/Program.fs @@ -0,0 +1,454 @@ +open System +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 = + | 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] [--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 + | "--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 installAssemblyResolver (assemblyPath: string) = + let assemblyDir = Path.GetDirectoryName assemblyPath + + AppDomain.CurrentDomain.add_AssemblyResolve ( + ResolveEventHandler(fun _ args -> + let name = AssemblyName(args.Name).Name + ".dll" + let candidate = Path.Combine(assemblyDir, name) + + if File.Exists candidate then + Assembly.LoadFrom candidate + else + null) + ) + +let mutationCases options project assemblyPath = + ensureBuilt options project assemblyPath + installAssemblyResolver assemblyPath + + let asm = Assembly.LoadFrom assemblyPath + + asm.GetTypes() + |> Array.collect (fun t -> + t.GetMethods(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static ||| BindingFlags.Instance) + |> Array.collect (fun m -> + m.GetCustomAttributesData() + |> Seq.filter (fun attr -> attr.AttributeType.FullName = "Mutannot.MutationCaseAttribute") + |> Seq.map (fun attr -> + let args = attr.ConstructorArguments + + if args.Count <> 5 then + failwithf "Unexpected MutationCaseAttribute shape on %s.%s" t.FullName m.Name + + let declaringType = + match t.FullName with + | null -> t.Name + | name -> name + + { Id = unbox args[0].Value + File = unbox args[1].Value + Line = unbox args[2].Value + Find = unbox args[3].Value + Replace = unbox args[4].Value + 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 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 + | 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 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 diff --git a/Mutannot/deps.nix b/Mutannot/deps.nix new file mode 100644 index 0000000..60de7f1 --- /dev/null +++ b/Mutannot/deps.nix @@ -0,0 +1,8 @@ +{ fetchNuGet }: +[ + (fetchNuGet { + pname = "FSharp.Core"; + version = "10.1.201"; + sha256 = "sha256-NzxdRJgL+5RQpUm8Y6Mc0w7sakxqThv6qHpP+u0x5x0="; + }) +] diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..6908e25 --- /dev/null +++ b/flake.lock @@ -0,0 +1,27 @@ +{ + "nodes": { + "nixpkgs": { + "locked": { + "lastModified": 1776877367, + "narHash": "sha256-EHq1/OX139R1RvBzOJ0aMRT3xnWyqtHBRUBuO1gFzjI=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "0726a0ecb6d4e08f6adced58726b95db924cef57", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..16f31af --- /dev/null +++ b/flake.nix @@ -0,0 +1,57 @@ +{ + inputs = { + nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; + }; + + outputs = + { self, nixpkgs }: + let + systems = [ + "x86_64-linux" + "aarch64-linux" + "x86_64-darwin" + "aarch64-darwin" + ]; + forEachSystem = + f: nixpkgs.lib.genAttrs systems (system: f system (import nixpkgs { inherit system; })); + in + { + formatter = forEachSystem (_system: pkgs: pkgs.nixfmt-rfc-style); + + packages = forEachSystem ( + _system: pkgs: + let + mutannot = pkgs.buildDotnetModule { + pname = "mutannot"; + version = "0.1.0"; + src = ./Mutannot; + projectFile = "Mutannot.fsproj"; + nugetDeps = ./Mutannot/deps.nix; + executables = [ "mutannot" ]; + dotnet-sdk = pkgs.dotnet-sdk_10; + dotnet-runtime = pkgs.dotnet-sdk_10; + useDotnetFromEnv = true; + + meta = { + mainProgram = "mutannot"; + }; + }; + in + { + default = mutannot; + mutannot = mutannot; + } + ); + + devShells = forEachSystem ( + _system: pkgs: { + default = pkgs.mkShell { + packages = [ + pkgs.git + pkgs.dotnet-sdk_10 + ]; + }; + } + ); + }; +}