verify-coverage-mutants.fsx -> mutannot.fsx
This commit is contained in:
parent
88db0ab12b
commit
8c7e227515
1 changed files with 1 additions and 1 deletions
302
mutannot.fsx
Executable file
302
mutannot.fsx
Executable file
|
|
@ -0,0 +1,302 @@
|
|||
#!/usr/bin/env -S dotnet fsi
|
||||
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 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 =
|
||||
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 parseArgs (args: string list) =
|
||||
let usage () =
|
||||
fail "Usage: mutannot.fsx <path/to/project.fsproj> [--configuration Debug|Release] [--build-arg <value> ...] [--no-build] [--list | --show <id> | --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 options = parseArgs (fsi.CommandLineArgs |> Array.skip 1 |> Array.toList)
|
||||
|
||||
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 project =
|
||||
loadProjectInfo options.ProjectPath
|
||||
|
||||
let targetPathForProject (workingDirectory: string) (projectPath: string) =
|
||||
let exitCode, stdout, stderr =
|
||||
captureProcess workingDirectory "dotnet" [ "msbuild"; projectPath; "--getProperty:TargetPath"; $"-property:Configuration={options.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 assemblyPath = targetPathForProject repoRoot project.AbsoluteProjectPath
|
||||
|
||||
let buildArgs projectPath =
|
||||
[ "build"; projectPath; "--configuration"; options.Configuration; "--nologo" ]
|
||||
@ options.BuildArgs
|
||||
|
||||
let ensureBuilt () =
|
||||
if not options.NoBuild then
|
||||
let exitCode = runProcess repoRoot "dotnet" (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 () =
|
||||
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 buildExitCode =
|
||||
runProcess worktreePath "dotnet" (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 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 outcomes =
|
||||
requested
|
||||
|> List.map runMutation
|
||||
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."
|
||||
else
|
||||
fail $"{survivors} mutant(s) survived. {buildFailures} mutant(s) failed to build."
|
||||
finally
|
||||
cleanup ()
|
||||
Loading…
Add table
Add a link
Reference in a new issue