Coverage.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Parent-side runner for the coverage phase of mutation testing.
--
-- For each declared suite the driver invokes this runner once: it asks
-- the suite executable to enumerate its leaf tests, then spawns one
-- coverage child per test concurrently to collect coverage maps, and
-- merges the results into @manifest-augmented.json@.
module Test.Syd.Mutation.Driver.Coverage
  ( runCoverageMode,
    annotateRecord,
    controlCoveringTests,
    controlCoveringTestLimit,
  )
where

import Control.Concurrent (newQSem, signalQSem, waitQSem)
import Control.Concurrent.Async (mapConcurrently)
import Control.Exception (bracket_)
import qualified Control.Exception as Exception
import qualified Data.ByteString.Lazy as LB
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8Lenient)
import GHC.Conc (getNumCapabilities)
import Path
import Path.IO (withSystemTempDir)
import System.Exit (ExitCode (..), exitWith)
import System.IO (BufferMode (LineBuffering), hFlush, hSetBuffering, stderr)
import System.Process.Typed (proc, readProcessStdout_, runProcess)
import Test.Syd.Mutation.AugmentedManifest
  ( AugmentedManifest (..),
    AugmentedMutationGroup (..),
    AugmentedMutationRecord (..),
    defaultTimeoutMicros,
    fromMutationRecord,
    mergeAugmentedManifests,
    readAugmentedManifestFileIfExists,
    writeAugmentedManifestFile,
  )
import Test.Syd.Mutation.Manifest
  ( MutationGroup (..),
    MutationManifest (..),
    MutationRecord (..),
    isControlOperator,
    readManifestDir,
  )
import Test.Syd.Mutation.Runtime (MutationId, renderMutationId)
import Test.Syd.Mutation.TestBaselineMap
  ( TestBaselineMap (..),
    readTestBaselineMapDirIfExists,
    readTestBaselineMapFile,
    writeTestBaselineMapDir,
  )
import Test.Syd.Mutation.TestCoverageMap (TestCoverageMap (..), readTestCoverageMapFile)
import Test.Syd.Mutation.TestId (TestId, parseTestIdFilterArg, renderTestId)
import Test.Syd.MutationMode.Common
  ( CoverageFailFast (..),
    CoverageProgressEvent (..),
    CoverageProgressPhase (..),
    CoverageProgressSkipReason (..),
    CoverageProgressTestEvent (..),
    renderCoverageProgressEvent,
    retryingIO,
  )
import Text.Colour (TerminalCapabilities (..), chunk, fore, hPutChunksUtf8With, red, unlinesChunks, yellow)

-- | Parent process: enumerate leaf tests by asking the suite executable
-- to list them, spawn one coverage child per test (up to @coverageJobs@
-- concurrently), merge the resulting 'TestCoverageMap's, and write or
-- merge into @manifest-augmented.json@.
--
-- When @manifest-augmented.json@ already exists (from a prior suite's
-- coverage pass), this run's results are merged in so that multiple
-- suites can be run sequentially.
runCoverageMode ::
  -- | Whether to abort the coverage run on a baseline test failure.
  Bool ->
  -- | Mutation manifest directories.
  [Path Abs Dir] ->
  -- | Augmented-manifest directory.
  Path Abs Dir ->
  -- | Maximum coverage-child concurrency.  'Nothing' means
  -- 'getNumCapabilities'.
  Maybe Word ->
  -- | Retry budget for a failing coverage child.
  Word ->
  -- | Name of this suite (used as the covering-tests key).
  Text ->
  -- | Path to the suite executable to invoke as a coverage child.
  Path Abs File ->
  IO ()
runCoverageMode failFast manifestDirs augDir coverageJobs coverageRetry suiteName childExe = do
  -- LineBuffering on stderr so our writes hit the fd at line boundaries,
  -- not when the buffer happens to fill. Coverage children inherit this
  -- fd and write to it directly (bypassing our Handle's MVar lock); if
  -- our own bytes sit in a block buffer waiting to be flushed, they can
  -- interleave with whatever the children write in the meantime.
  hSetBuffering stderr LineBuffering
  allRecords@(MutationManifest groups) <- mconcat <$> mapM readManifestDir manifestDirs
  let writeEmptyAugmented = do
        existing <- readAugmentedManifestFileIfExists augDir
        writeAugmentedManifestFile augDir (fromMaybe (AugmentedManifest []) existing)
        -- Keep baseline.json present (possibly empty) so the union step and the
        -- mutation child always find a file to read.
        mergeBaselineIntoDir mempty
  if all (\(MutationGroup rs) -> null rs) groups
    then do
      emitCoverageEvent (CoverageProgressSkipped CoverageSkipNoMutations)
      writeEmptyAugmented
    else do
      leafIds <- listSuiteTestIds childExe
      let total = length leafIds
      if total == 0
        then do
          emitCoverageEvent (CoverageProgressSkipped CoverageSkipNoTests)
          writeEmptyAugmented
        else do
          n <- case coverageJobs of
            Just j | j > 0 -> pure (fromIntegral j)
            _ -> getNumCapabilities
          sem <- newQSem n
          -- A coverage child that observes a test failure (and was
          -- launched with --mutation-fail-fast) throws 'CoverageFailFast'
          -- from its worker thread.  'mapConcurrently' cancels the
          -- remaining workers and re-raises the exception, which we
          -- catch here so we can exit non-zero rather than crashing.
          childResults <-
            Exception.handle (\CoverageFailFast -> hFlush stderr >> exitWith (ExitFailure 1)) $
              mapConcurrently
                (runCoverageChild sem total)
                (zip [1 :: Int ..] leafIds)
          let (coverageMaps, baselineMaps) = unzip childResults
              TestCoverageMap coverageMap = mconcat coverageMaps
              TestBaselineMap baselineMap = mconcat baselineMaps
              mutationCoverage = invertCoverageMap coverageMap
          let newAugmented = buildAugmentedManifest mutationCoverage baselineMap allRecords
          existing <- readAugmentedManifestFileIfExists augDir
          let augmented = case existing of
                Nothing -> newAugmented
                Just prev -> mergeAugmentedManifests prev newAugmented
          writeAugmentedManifestFile augDir augmented
          -- Persist the per-test baselines next to the manifest, accumulated
          -- across suites (slowest time wins), so the mutation child can order
          -- covering tests cheapest-first.
          mergeBaselineIntoDir (mconcat baselineMaps)
  where
    mergeBaselineIntoDir :: TestBaselineMap -> IO ()
    mergeBaselineIntoDir newBaseline = do
      existing <- readTestBaselineMapDirIfExists augDir
      writeTestBaselineMapDir augDir (fromMaybe mempty existing <> newBaseline)

    runCoverageChild sem total (i, tid) =
      bracket_ (waitQSem sem) (signalQSem sem) $ do
        emitCoverageEvent $
          CoverageProgressTest
            CoverageProgressTestEvent
              { coverageProgressIndex = i,
                coverageProgressTotal = total,
                coverageProgressTestId = tid,
                coverageProgressTestPhase = CoverageProgressStarting
              }
        result <- runCoverageChildAttempt tid coverageRetry
        let TestCoverageMap m = fst result
            covered = fromMaybe Set.empty (Map.lookup tid m)
        emitCoverageEvent $
          CoverageProgressTest
            CoverageProgressTestEvent
              { coverageProgressIndex = i,
                coverageProgressTotal = total,
                coverageProgressTestId = tid,
                coverageProgressTestPhase = CoverageProgressDone (Set.size covered)
              }
        pure result

    runCoverageChildAttempt tid retriesLeft = do
      result <- retryingIO retriesLeft (logCoverageRetry tid) (runOneCoverageChild tid)
      case result of
        Right v -> pure v
        Left reason ->
          fail $
            "coverage child for "
              ++ T.unpack (renderTestId tid)
              ++ ": "
              ++ reason

    -- One coverage-child attempt: returns @Left reason@ on transient
    -- failure (non-zero exit or unreadable output), @Right (cov, base)@
    -- on success.
    --
    -- Exit code 2 is reserved by the coverage child to mean "the test
    -- itself failed under fail-fast" — that is not a transient failure,
    -- so we throw 'CoverageFailFast' to abort the run without retrying.
    runOneCoverageChild tid =
      withSystemTempDir "coverage-child" $ \tmpDir -> do
        let outputFile = fromAbsFile (tmpDir </> [relfile|coverage.json|])
            baselineFile = fromAbsFile (tmpDir </> [relfile|baseline.json|])
            failFastArg =
              if failFast
                then "--mutation-fail-fast"
                else "--no-mutation-fail-fast"
            args =
              [ "--mutation-coverage-one",
                T.unpack (renderTestId tid),
                "--mutation-coverage-output",
                outputFile,
                "--mutation-coverage-baseline-output",
                baselineFile,
                failFastArg,
                "--mutation-suite-name",
                T.unpack suiteName
              ]
            childProc = proc (fromAbsFile childExe) args
        ec <- runProcess childProc
        case ec of
          ExitFailure 2 | failFast -> do
            hPutChunksUtf8With With8BitColours stderr $
              unlinesChunks
                [ [ fore red (chunk "coverage: test failed during baseline run for "),
                    chunk (renderTestId tid),
                    chunk " — aborting (fail-fast)"
                  ]
                ]
            Exception.throwIO CoverageFailFast
          ExitFailure code -> pure $ Left ("exited with code " ++ show code)
          ExitSuccess -> do
            eMap <- readTestCoverageMapFile outputFile
            case eMap of
              Left err -> pure $ Left ("unreadable coverage map: " ++ err)
              Right coverageMap -> do
                eBaseline <- readTestBaselineMapFile baselineFile
                case eBaseline of
                  Left err -> pure $ Left ("unreadable baseline map: " ++ err)
                  Right baselineMap -> pure $ Right (coverageMap, baselineMap)

    logCoverageRetry tid reason retriesAfter =
      hPutChunksUtf8With With8BitColours stderr $
        unlinesChunks
          [ [ fore yellow (chunk "coverage: retrying "),
              chunk (renderTestId tid),
              chunk " (",
              chunk (T.pack reason),
              chunk ", ",
              chunk (T.pack (show retriesAfter)),
              chunk " retr",
              chunk (if retriesAfter == 1 then "y" else "ies"),
              chunk " left)"
            ]
          ]

    buildAugmentedManifest mutationCoverage baselineMap (MutationManifest mgroups) =
      AugmentedManifest
        [ AugmentedMutationGroup augmented
        | MutationGroup recs <- mgroups,
          let augmented = concatMap (annotateRecord suiteName mutationCoverage baselineMap) recs,
          not (null augmented)
        ]

-- | How many covering tests a control mutation is checked against.
--
-- A control is expected to survive, so its child cannot stop at a kill: it
-- runs every covering test it is given, which makes an unbounded control the
-- most expensive mutation in a run.  What it is for is noticing a suite that
-- cannot be relied on, which the number of controls answers rather than the
-- number of tests each one runs.
controlCoveringTestLimit :: Int
controlCoveringTestLimit = 10

-- | Which of a control's covering tests it is checked against.
--
-- Not the cheapest of them: the fastest tests are the least likely to be the
-- ones a suite cannot be relied on for, so taking those every time would aim
-- the canary away from what it is watching for.  A window starting where the
-- mutation's own id lands takes a different few for each control, so a run
-- samples the covering sets across them rather than the same corner of each.
--
-- Which few follows from the id alone, so the manifest a coverage run writes,
-- and the verdicts a mutation run reaches from it, stay the same on a rerun.
controlCoveringTests :: MutationId -> [TestId] -> [TestId]
controlCoveringTests mid tests =
  let total = length tests
      offset = sum (map fromEnum (renderMutationId mid)) `mod` max 1 total
   in take (min controlCoveringTestLimit total) (drop offset (cycle tests))

-- | Annotate one mutation record with the tests that cover it and the budget
-- its child gets.
--
-- A control keeps only 'controlCoveringTestLimit' of its covering tests, so its
-- budget shrinks with them.
annotateRecord ::
  -- | The name of the suite whose coverage this is.
  Text ->
  -- | Which tests cover each mutation.
  Map.Map MutationId (Set.Set TestId) ->
  -- | What each test cost on its own.
  Map.Map TestId Word ->
  MutationRecord ->
  [AugmentedMutationRecord]
annotateRecord suiteName mutationCoverage baselineMap rec =
  let costOf t = Map.findWithDefault 0 t baselineMap
      allCoveringTests =
        Set.toList $
          Map.findWithDefault Set.empty (mutRecId rec) mutationCoverage
      coveringTests
        | isControlOperator (mutRecOperator rec) =
            controlCoveringTests (mutRecId rec) allCoveringTests
        | otherwise = allCoveringTests
      -- Per-mutation timeout (microseconds) = 10 * sum of covering-test
      -- baselines, floored at 30s.  Tests with no recorded baseline
      -- contribute 0; the floor still applies.
      coveringBaselineSum :: Word
      coveringBaselineSum = sum (map costOf coveringTests)
      timeoutMicros = max defaultTimeoutMicros (10 * coveringBaselineSum)
      annotated =
        rec
          { mutRecCoveringTests =
              Just $ Map.singleton suiteName coveringTests
          }
   in case fromMutationRecord annotated of
        Nothing -> []
        Just r ->
          [r {augmentedMutationRecordTimeoutMicros = timeoutMicros}]

emitCoverageEvent :: CoverageProgressEvent -> IO ()
emitCoverageEvent ev =
  hPutChunksUtf8With With8BitColours stderr (unlinesChunks (renderCoverageProgressEvent ev))

-- | Ask the suite executable to print its leaf test IDs (one per line)
-- and parse the result.  The driver uses the @--mutation-coverage-list@
-- flag for this.
listSuiteTestIds :: Path Abs File -> IO [TestId]
listSuiteTestIds childExe = do
  let childProc = proc (fromAbsFile childExe) ["--mutation-coverage-list"]
  output <- readProcessStdout_ childProc
  let stripBOM t = case T.uncons t of
        Just ('\xFEFF', rest) -> rest
        _ -> t
      txt = stripBOM (decodeUtf8Lenient (LB.toStrict output))
      raw = filter (not . T.null) (T.lines txt)
  let parsed = [(line, parseTestIdFilterArg line) | line <- raw]
      bad = [line | (line, Nothing) <- parsed]
  case bad of
    [] -> pure [tid | (_, Just tid) <- parsed]
    _ ->
      fail $
        "sydtest-mutation-driver: failed to parse test ids from "
          ++ fromAbsFile childExe
          ++ "'s --mutation-coverage-list output; unparseable lines: "
          ++ show (map T.unpack bad)

-- | Invert a @'Map' 'TestId' ('Set' 'MutationId')@ to
-- @'Map' 'MutationId' ('Set' 'TestId')@.
invertCoverageMap :: Map.Map TestId (Set.Set MutationId) -> Map.Map MutationId (Set.Set TestId)
invertCoverageMap =
  Map.foldlWithKey'
    ( \acc tid mids ->
        Set.foldl'
          (\a mid -> Map.insertWith Set.union mid (Set.singleton tid) a)
          acc
          mids
    )
    Map.empty