Empty Program.fs

This commit is contained in:
Sven van Heugten 2026-05-12 06:36:50 +02:00
parent 79a4a9a40f
commit 3bc0c4e9e8
No known key found for this signature in database
GPG key ID: D612F88666F4F660

View file

@ -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 <path/to/project.fsproj> [--configuration Debug|Release] [--build-arg <value> ...] [--no-build] [--validate | --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
| "--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<CustomAttributeTypedArgument>) 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<CustomAttributeTypedArgument>) 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<obj>.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
"<empty line>"
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
[<EntryPoint>]
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