Initial commit

MutationCase.fs

@@ -0,0 +1,13 @@
+namespace Mutannot
+
+open System
+
+[<AttributeUsage(AttributeTargets.Method, AllowMultiple = true)>]
+type MutationCaseAttribute(id: string, file: string, line: int, find: string, replace: string) =
+    inherit Attribute()
+
+    member _.Id = id
+    member _.File = file
+    member _.Line = line
+    member _.Find = find
+    member _.Replace = replace

README.md

@@ -0,0 +1,7 @@
+# mutannot
+
+This allows you to annotate Xunit test cases with a mutation that should cause the test to fail.
+
+`verify-coverage-mutants.fsx` will apply each mutation and verify that the test actually fails.
+
+Current state: LLM-generated prototype

verify-coverage-mutants.fsx

@@ -0,0 +1,246 @@
+open System
+open System.IO
+open System.Reflection
+open System.Diagnostics
+
+type MutationCase =
+    { Id: string
+      File: string
+      Line: int
+      Find: string
+      Replace: string
+      TestName: string
+      DeclaringType: string }
+
+type Command =
+    | List
+    | Show of string
+    | Run of string list
+
+type Options =
+    { Configuration: string
+      NoBuild: bool
+      Command: Command }
+
+let projectPath = "Example.Tests"
+let targetFramework = "net10.0"
+let projectDirectory = "example-tests"
+let testProjectPath = Path.Combine(projectDirectory, "Example.Tests", "Example.Tests.fsproj")
+
+let fail message =
+    eprintfn "%s" message
+    Environment.Exit 1
+    Unchecked.defaultof<_>
+
+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 makeRelativePath (path: string) =
+    if Path.IsPathRooted path then Path.GetRelativePath(repoRoot, path) else path
+
+let parseArgs (args: string list) =
+    let rec loop configuration noBuild remaining =
+        match remaining with
+        | [] -> { Configuration = configuration; NoBuild = noBuild; Command = Run [] }
+        | "--configuration" :: value :: tail -> loop value noBuild tail
+        | "--no-build" :: tail -> loop configuration true tail
+        | "--list" :: tail when tail.IsEmpty -> { Configuration = configuration; NoBuild = noBuild; Command = List }
+        | "--show" :: id :: tail when tail.IsEmpty -> { Configuration = configuration; NoBuild = noBuild; Command = Show id }
+        | "--run" :: tail -> { Configuration = configuration; NoBuild = noBuild; Command = Run tail }
+        | value :: tail when not (value.StartsWith "--") -> { Configuration = configuration; NoBuild = noBuild; Command = Run (value :: tail) }
+        | _ -> fail "Usage: dotnet fsi verify-coverage-mutants.fsx [--configuration Debug|Release] [--no-build] [--list | --show <id> | --run [id...]]"
+    loop "Debug" false args
+
+let options = parseArgs (fsi.CommandLineArgs |> Array.skip 1 |> Array.toList)
+
+let assemblyPath =
+    Path.Combine(repoRoot, projectDirectory, "Example.Tests", "bin", options.Configuration, targetFramework, "Example.Tests.dll")
+
+let ensureBuilt () =
+    if not options.NoBuild then
+        let exitCode = runProcess repoRoot "dotnet" [ "build"; testProjectPath; "--configuration"; options.Configuration; "--nologo" ]
+        if exitCode <> 0 then fail "dotnet build failed."
+    if not (File.Exists assemblyPath) then
+        fail $"Compiled test assembly not found at {assemblyPath}."
+
+let installAssemblyResolver () =
+    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 () =
+    ensureBuilt ()
+    installAssemblyResolver ()
+    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
+                { Id = unbox<string> args[0].Value
+                  File = unbox<string> args[1].Value
+                  Line = unbox<int> args[2].Value
+                  Find = unbox<string> args[3].Value
+                  Replace = unbox<string> args[4].Value
+                  TestName = m.Name
+                  DeclaringType = t.FullName })
+            |> 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 lineNumberAt (text: string) index =
+    let mutable line = 1
+    for i in 0 .. index - 1 do
+        if text[i] = '\n' then
+            line <- line + 1
+    line
+
+let replaceNearestOccurrence (mutation: MutationCase) (text: string) =
+    let rec collect fromIndex acc =
+        let idx = text.IndexOf(mutation.Find, fromIndex, StringComparison.Ordinal)
+        if idx < 0 then List.rev acc
+        else collect (idx + 1) (idx :: acc)
+
+    let matches = collect 0 []
+    match matches with
+    | [] -> fail $"Could not find '{mutation.Find}' in {mutation.File}"
+    | _ ->
+        let chosen =
+            matches
+            |> List.minBy (fun idx -> abs (lineNumberAt text idx - mutation.Line))
+        text.Remove(chosen, mutation.Find.Length).Insert(chosen, 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 tempRoot = Path.Combine(Path.GetTempPath(), $"fscheck-mutants.{Guid.NewGuid():N}")
+let worktreePath = Path.Combine(tempRoot, "worktree")
+let patchPath = Path.Combine(tempRoot, "current.patch")
+
+let cleanup () =
+    if Directory.Exists worktreePath then
+        let _ = captureProcess repoRoot "git" [ "worktree"; "remove"; "--force"; worktreePath ]
+        ()
+    if Directory.Exists tempRoot then
+        Directory.Delete(tempRoot, true)
+
+let createWorktree () =
+    Directory.CreateDirectory(tempRoot) |> ignore
+    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
+
+let testFilter mutation = $"FullyQualifiedName~{mutation.TestName}"
+
+let runMutation (mutation: MutationCase) =
+    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 = replaceNearestOccurrence mutation originalText
+    File.WriteAllText(targetFile, mutatedText)
+
+    printfn "==> %s: %s" mutation.Id mutation.TestName
+    let exitCode = runProcess worktreePath "dotnet" [ "test"; testProjectPath; "--configuration"; options.Configuration; "--filter"; testFilter mutation; "--nologo" ]
+    File.WriteAllText(targetFile, originalText)
+
+    if exitCode = 0 then
+        printfn "SURVIVED  %s" mutation.Id
+        false
+    else
+        printfn "KILLED    %s" mutation.Id
+        true
+
+let mutations = mutationCases ()
+
+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)
+| Show id ->
+    let mutation = findMutation id mutations
+    printMutation mutation
+| Run ids ->
+    let requested =
+        match ids with
+        | [] -> mutations |> Array.toList
+        | _ -> ids |> List.map (fun id -> findMutation id mutations)
+
+    try
+        createWorktree ()
+        let killed =
+            requested
+            |> List.map runMutation
+        let survivors = killed |> List.filter not |> List.length
+        if survivors = 0 then
+            printfn "All requested mutants were killed."
+        else
+            fail $"{survivors} mutant(s) survived."
+    finally
+        cleanup ()