mutannot/mutannot.fsx

#!/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 ()