packages feed

sydtest-mutation-plugin (empty) → 0.4.4.0

raw patch · 30 files changed

+4787/−0 lines, 30 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, directory, filepath, ghc, ghc-boot, mtl, opt-env-conf, opt-env-conf-test, path, path-io, safe-coloured-text, sydtest, sydtest-mutation-plugin, sydtest-mutation-runtime, template-haskell, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,197 @@+# Changelog++## [0.4.4.0] - 2026-06-20++### Fixed++* Expressions of unlifted or representation-polymorphic type are no longer+  instrumented.  `ifMutation`'s type variable has kind `Type`, so wrapping an+  `Int#`-typed expression (e.g. in Alex/Happy-generated lexers) built+  ill-kinded `ifMutation @Int#` Core that Core Lint rejects and that+  miscompiles without it.++## [0.4.3.0] - 2026-06-20++### Fixed++* `MaybeOp` and `ConstNothing` no longer emit a bare `Nothing :: forall a.+  Maybe a`.  The un-instantiated `forall` made the surrounding `ifMutation`+  wrapper ill-typed Core, which — with Core Lint off — miscompiled the+  instrumented site and, for some element types, segfaulted at runtime.  The+  element type is now applied, mirroring how `ConstEmptyList` threads its+  element type.++## [0.4.2.0] - 2026-06-19++### Added++* A `TupleSwap` mutation operator: for a boxed tuple whose two components have+  the same type, it emits one mutant per same-typed pair that swaps that pair.+  It is the tuple-syntax counterpart to `SwitchFunctionArguments`, which only+  sees application spines and never the `ExplicitTuple` node.  Tuple sections+  (which carry a missing component and are really functions), pairs with+  identical source text (whose swap is a no-op), and unboxed tuples (whose+  unlifted kind the lifted `ifMutation` wrapper cannot carry) are skipped.++## [0.4.1.0] - 2026-06-19++### Fixed++* Mutants whose replacement text contains a `/` are now activated (and so+  killable) instead of always surviving.  A `MutationId` renders and parses as+  `/`-separated parts, so its parts must contain no `/`, yet the id embedded the+  replacement string (raw source text) as a part.  A `SwitchFunctionArguments`+  swap of e.g. `stripPrefix "/nix/store/" t` has replacement text+  `t "/nix/store/"`, which contains a `/`.  The compiled `ifMutation` carried+  that id intact, but the driver renders the id into `MUTATION_ACTIVE` and the+  runtime parses it back by splitting on `/`: the embedded `/` split into extra+  parts, the parsed id never equalled the compiled one, and the mutation was+  never made active.  It therefore survived even when a test killed it, while+  same-site operators with a `/`-free replacement (e.g. `ConstNothing`'s+  `Nothing`) were killed normally.  (The coverage phase still recorded the+  intact id, so the mutant showed up as `survived`, not `uncovered`.)  The id+  is now the structural key `[module, operator, line, colStart, colEnd,+  altIndex]`; none of those parts can contain a `/`, and the index already+  disambiguates alternatives at one span.  The replacement text remains in the+  manifest's `replacement` field for humans.++## [0.4.0.0] - 2026-06-17++### Added++* A `RemoveClause` mutation operator: for a function binding with two or more+  equations, it emits one mutant per equation that removes that equation.+  Because a clause is a binding-level `Match` rather than an expression, the+  removal is implemented by prepending an `ifMutation mid False True` guard to+  the clause: when the mutation is active every guard of the clause fails, so+  the clause matches no input and control falls through to the next equation+  (or to a non-exhaustive `MatchFail` for the last matching clause).  The guard+  sits after the clause's patterns, so coverage is attributed only to tests+  that actually reach the clause.  Disable it like any other operator via+  `disabled-mutations`, a module `{-# ANN #-}`, or+  `operators.RemoveClause.enable: false`.++* A `SwitchFunctionArguments` mutation operator: at a prefix function (or+  constructor) application, for every pair of value arguments that have the+  same type, it emits a mutant that swaps those two arguments.  Only the+  maximal application spine is mutated, and pairs whose arguments have+  identical source text are skipped (swapping them would be a no-op).++  Symmetric functions make this operator produce equivalent (unkillable)+  mutants, so it reads a `skip-calls-to` list of function names from its+  per-operator config and skips swapping the arguments of any call to a+  listed function:++  ```yaml+  operators:+    SwitchFunctionArguments:+      skip-calls-to: [max, Data.Set.union]+  ```++* Mutations now carry an optional `mitigation` hint and the enclosing+  `binding` name in the manifest.  `SwitchFunctionArguments` sets a mitigation+  message pointing at `skip-calls-to`; the binding name lets the run report+  print the exact `{-# ANN <binding> ("DisableMutation: <Operator>" ...) #-}`+  annotation for each surviving mutation.++## [0.3.0.0] - 2026-06-09++### Added++* Per-operator configuration under the `operators` config object:++  ```yaml+  operators:+    ConstEmptyList:+      skip-strings: true+    Arith:+      enable: false+  ```++  Every operator takes an `enable` toggle (`enable: false` disables it, the+  same as listing it in `disabled-mutations`).  Each operator reads its own+  remaining keys, exposed as an opaque `operatorConfigExtra :: Map Text Value`.+  The `ConstEmptyList` operator interprets two such keys: `skip-strings`+  (do not target `[Char]`/`String` expressions at all — keeps genuine `[a]`,+  `a /= Char`, list mutations) and `skip-literal-strings` (skip only+  syntactic string literals).++### Changed++* `InstrumentEnv` and `runInstrument` now carry the per-operator+  configuration (`Map Text OperatorConfig`) rather than individual flags.+* The `OptParse` settings expose `OperatorConfig`, `operatorsConfigDisabled`,+  and `operatorExtraFlag`; the old `OperatorsConfig`/`ConstEmptyListConfig`+  types are gone.++## [0.2.1.0] - 2026-06-08++### Fixed++* The instrumenter no longer mutates compiler-generated code.  Stock- and+  anyclass-derived instance methods (whose `MatchGroup` carries a `Generated`+  origin) and the dictionary/evidence `VarBind`s the typechecker materialises+  for an instance (e.g. `$dShow`, `$dEnum`) were being instrumented, with+  source spans pointing at the `deriving` clause or the instance head.  That+  produced nonsense diffs like `deriving (Show, (\_ _ -> False), ...)` and+  `instance (\_ -> []) where`, and the resulting mutants — living in generated+  code rather than the user's own source — could never be killed by a test, so+  they surfaced as permanently uncovered mutations.  Such bindings are now+  skipped.++## [0.2.0.0] - 2026-06-04++### Added++* Three const-function mutation operators that replace an expression of+  type `arg1 -> ... -> argN -> T` (with `N >= 0`) by a constant function+  returning `T`'s distinguished trivial value: `ConstNothing` for `Maybe a`,+  `ConstEmptyList` for `[a]`, and an expanded `ConstBool` for `Bool`+  (subsuming the previous arity-0-only `ConstBool` behaviour).  At arity 0+  the mutant is the bare trivial value; at arity `N >= 1` it is a typed+  `(\_ ... _ -> v)` lambda synthesized in the GhcTc AST.  Maybe and List+  thereby gain coverage that the syntactic-only `MaybeOp` and `ListLit`+  miss — calls like `lookup k m` and `concat xs` are now mutated to+  `Nothing` and `[]` respectively.+* A coloured human-readable `<Module>.txt` rendering of every manifest is+  now written alongside the existing canonical `<Module>.json`.  Same+  header + unified-diff layout as the runtime's surviving-mutation+  report, opening with a `N mutations in M groups` count line so empty+  manifests are not mistakeable for rendering accidents.+* `ReplaceOuterSpan RealSrcSpan Text` constructor on `SrcSpanDelta` for+  operators that want to replace a wider outer span than the matched+  expression's own.  Used by the const-family operators when the matched+  expression sits at the operator-token position of an infix application+  to rewrite the whole `OpApp` source span in prefix form (e.g.+  `n < 0` becomes `(\_ _ -> True) (n) (0)`) instead of text-splicing a+  lambda into the operator slot and producing nonsense source.++### Changed++* `applyTokenReplace` now collapses multi-line spans correctly (a latent+  bug that surfaced once arity-`>=1` operators started emitting multi-line+  replacements).+* The walker tracks `HsApp` function-position depth on `InstrumentEnv`,+  resetting on the argument side.  Const-family operators consult it to+  skip arity-`N` firings (`N >= 1`) at sites where the matched expression+  is already saturated by `N` enclosing applications, because the+  arity-`N` mutant evaluates to what the arity-0 mutation on the+  outermost saturated expression already produces.++## [0.1.1.0] - 2026-05-25++### Changed++* Mutations whose desugared form is non-exhaustive (e.g. a `RemoveCase`+  that drops the only alternative covering a constructor) are now+  auto-killed at instrument time, since the compiler's incomplete-patterns+  warning would catch them anyway.++## [0.1.0.0] - 2026-05-22++### Added++* A `DisableMutationsFor <name>` (or `DisableMutationFor <name>`) annotation+  whose target names no local binding in the annotated function's body is now+  a compile error.  Such an annotation disables no mutations, so the plugin+  asks for its removal.
+ LICENSE.md view
@@ -0,0 +1,5 @@+# Sydtest License++Copyright (c) 2025 Tom Sydney Kerckhove++See the Sydtest License at https://github.com/NorfairKing/sydtest/blob/master/sydtest/LICENSE.md for the full license text.
+ src/Test/Syd/Mutation/Plugin.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Syd.Mutation.Plugin (plugin) where++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.Data (Data, cast, gmapQ)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.List (isPrefixOf, stripPrefix)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import GHC+import GHC.Data.FastString (unpackFS)+import GHC.Driver.Env (Hsc, HscEnv (..))+import GHC.Driver.Plugins+import GHC.Driver.Session (WarningFlag (..), wopt_unset)+import GHC.Serialized (deserializeWithData)+import GHC.Tc.Types+import GHC.Types.Annotations (AnnTarget (..), findAnns)+import Path+import System.IO.Unsafe (unsafePerformIO)+import Test.Syd.Mutation.Manifest (MutationGroup (..), MutationManifest (..), writeManifestFile)+import Test.Syd.Mutation.Manifest.Render (writeManifestTxtFile)+import Test.Syd.Mutation.Plugin.Instrument+import Test.Syd.Mutation.Plugin.Operators (allOperators)+import Test.Syd.Mutation.Plugin.OptParse+  ( Settings (..),+    operatorsConfigDisabled,+    resolveSettings,+  )++data DisabledMutation+  = DisableAll+  | DisableNamed String+  deriving (Eq)++-- | Parse a list of @{-# ANN #-}@ string payloads into disabled-mutation specs.+--+-- Recognised formats:+--   @"DisableMutations"@              — disable all mutations on this scope+--   @"DisableMutations: Arith, BoolLit"@ — disable the listed mutation types+--   @"DisableMutation: Arith"@        — disable exactly one named mutation type+--+-- Spaces after the colon and after each comma are optional.+parseMutationAnnStrings :: [String] -> [DisabledMutation]+parseMutationAnnStrings = concatMap parse+  where+    parse s+      | s == "DisableMutations" = [DisableAll]+      | Just rest <- stripPrefix "DisableMutations:" s =+          map (DisableNamed . trim) (splitOnComma rest)+      | Just rest <- stripPrefix "DisableMutation:" s =+          [DisableNamed (trim rest)]+      | otherwise = []++trim :: String -> String+trim = dropWhile (== ' ')++splitOnComma :: String -> [String]+splitOnComma s = case break (== ',') s of+  (w, []) -> [w]+  (w, _ : rest) -> w : splitOnComma rest++plugin :: Plugin+plugin =+  defaultPlugin+    { -- We instrument at the typechecked stage (GhcTc) so that mutations can+      -- be type-directed (e.g. replace any expression of type 'Maybe a' with+      -- 'Nothing', or only mutate '+' when the operands are numeric).+      typeCheckResultAction = mutationTypeCheckAction,+      -- Add an import of Test.Syd.Mutation.Plugin.Runtime at the parsed stage so that+      -- ifMutation and MutationId are in tcg_rdr_env for the typecheck action.+      parsedResultAction = mutationAddRuntimeImport,+      -- Suppress -Wunused-imports for the injected import of Test.Syd.Mutation.Plugin.Runtime.+      driverPlugin = \_ hscEnv ->+        pure+          hscEnv+            { hsc_dflags =+                foldl+                  wopt_unset+                  (hsc_dflags hscEnv)+                  [ Opt_WarnUnusedImports,+                    -- Guard instrumentation wraps conditions in ifMutation, making the+                    -- exhaustiveness checker conservatively warn about patterns it can+                    -- no longer prove complete.+                    Opt_WarnIncompletePatterns,+                    Opt_WarnIncompleteUniPatterns+                  ]+            },+      -- Recompile only when plugin flags change. We previously used+      -- 'impurePlugin' (always force recompile), but that prevents the+      -- two-step build in nix/addManifest.nix from working: the postBuild+      -- step that compiles test-suites/executables re-invokes 'Setup build'+      -- with the same plugin flags, and with 'impurePlugin' GHC would+      -- recompile the already-instrumented library un-instrumented (the+      -- env-var kill switch tells the plugin to instrument nothing).+      -- 'flagRecompile' fingerprints only the plugin's CLI options, so the+      -- library is not recompiled when the flags are identical between the+      -- two invocations. Source-level changes still trigger recompile via+      -- GHC's normal mechanism.+      pluginRecompile = flagRecompile+    }++-- | Inject @import Test.Syd.Mutation.Plugin.Runtime ()@ into every instrumented module.+-- This ensures sydtest-mutation-plugin is registered as used (it is already in+-- build-depends as the plugin package), and satisfies -Wunused-packages.+--+-- Also, when @--skip-th-splices@ is set, walk the parsed AST to collect+-- 'RealSrcSpan's covering every 'HsUntypedSplice', 'HsTypedSplice', and+-- declaration-level 'SpliceD'.  These are stored in a process-global IORef+-- keyed by module name and consulted by 'recordMutation' (via the+-- 'instrumentEnvSpliceSpans' field of 'InstrumentEnv') to drop mutations whose own+-- span is contained inside any splice span.+--+-- Why parse-time: many top-level splices (e.g. @mkYesodData@,+-- @mkPersist [persistLowerCase| ... |]@) are evaluated during renaming and+-- their results are spliced into the typechecker as if they were original+-- code, so the typechecked AST no longer carries an 'ExpandedThingTc'+-- wrapper we could pattern-match on.  The original splice nodes are still+-- present in the parsed AST.+mutationAddRuntimeImport ::+  [CommandLineOption] ->+  ModSummary ->+  ParsedResult ->+  Hsc ParsedResult+mutationAddRuntimeImport opts ms pr = do+  let mn = moduleNameString (moduleName (ms_mod ms))+  Settings+    { settingExceptions = exceptions,+      settingSkipThSplices = skipThSplices+    } <-+    liftIO $ resolveSettings opts+  if "Paths_" `isPrefixOf` mn || mn `elem` exceptions+    then pure pr+    else do+      let pm = parsedResultModule pr+          lm = hpm_module pm+          -- Look for a module-level+          -- {-# ANN module ("DisableMutations" :: String) #-} in the parsed+          -- AST.  When present, this module will be skipped in the+          -- typecheck phase, so there's no point in walking its AST here to+          -- collect splice spans.  Keep the runtime-import injection+          -- regardless, so -Wunused-packages stays happy on the+          -- sydtest-mutation-plugin dep.+          disabled = hasDisableMutationsAnn (unLoc lm)+      liftIO $+        when (skipThSplices && not disabled) $ do+          let spliceRanges = collectSpliceSpans lm+          atomicModifyIORef' spliceSpansMap (\m -> (Map.insert mn spliceRanges m, ()))+      let runtimeImport = noLocA (simpleImportDecl (mkModuleName "Test.Syd.Mutation.Plugin.Runtime"))+          lm' = fmap (\m -> m {hsmodImports = runtimeImport : hsmodImports m}) lm+      pure pr {parsedResultModule = pm {hpm_module = lm'}}++-- | Recognise @{-# ANN module ("DisableMutations" :: String) #-}@ at the+-- top level of the parsed module.  Only looks at module-level annotations+-- (ignores @ANN someFunction ...@) so it mirrors the typecheck-phase+-- check that uses 'tcg_ann_env' with 'ModuleTarget'.+hasDisableMutationsAnn :: HsModule GhcPs -> Bool+hasDisableMutationsAnn m = any isDisableMutationsDecl (hsmodDecls m)+  where+    isDisableMutationsDecl :: LHsDecl GhcPs -> Bool+    isDisableMutationsDecl (L _ d) = case d of+      AnnD _ (HsAnnotation _ ModuleAnnProvenance {} expr) ->+        annExprIsDisableMutations expr+      _ -> False++    -- The payload of {-# ANN module ("DisableMutations" :: String) #-}+    -- parses as @ExprWithTySig _ "DisableMutations" String@; strip+    -- parentheses and type signatures to find the underlying string.+    annExprIsDisableMutations :: LHsExpr GhcPs -> Bool+    annExprIsDisableMutations le = case unLoc (stripExpr le) of+      HsLit _ (HsString _ s) -> unpackFS s == "DisableMutations"+      _ -> False++    stripExpr :: LHsExpr GhcPs -> LHsExpr GhcPs+    stripExpr le = case unLoc le of+      HsPar _ inner -> stripExpr inner+      ExprWithTySig _ inner _ -> stripExpr inner+      _ -> le++-- | Per-module splice spans collected by 'mutationAddRuntimeImport' when+-- @--skip-th-splices@ is set, read back by 'mutationTypeCheckAction' and+-- threaded through 'InstrumentEnv'.  Lives in a process-global IORef+-- because 'Hsc' and 'TcM' don't share state cleanly across compilation+-- units, and GHC may compile many modules in one process.  Switched from+-- 'stm-containers' to 'IORef'+'atomicModifyIORef'' to avoid loading the+-- 'stm' package into the GHC-as-host process, which has been observed to+-- hang the plugin during the parsed-result action on real-world libraries+-- (e.g. safe-coloured-text).+{-# NOINLINE spliceSpansMap #-}+spliceSpansMap :: IORef (Map String [RealSrcSpan])+spliceSpansMap = unsafePerformIO (newIORef Map.empty)++-- | Generic traversal that collects 'RealSrcSpan's of all parsed-AST+-- splice and quasi-quote nodes.  Uses 'Data' generics so we don't have+-- to enumerate every constructor of the AST.+collectSpliceSpans :: (Data a) => a -> [RealSrcSpan]+collectSpliceSpans x = here ++ concat (gmapQ collectSpliceSpans x)+  where+    here :: [RealSrcSpan]+    here =+      case (cast x :: Maybe (LHsExpr GhcPs)) of+        Just le | isSpliceLExpr le -> realSpan (getLocA le)+        _ -> case (cast x :: Maybe (LHsDecl GhcPs)) of+          Just ld | isSpliceLDecl ld -> realSpan (getLocA ld)+          _ -> []+    realSpan (RealSrcSpan rss _) = [rss]+    realSpan _ = []++isSpliceLExpr :: LHsExpr GhcPs -> Bool+isSpliceLExpr (L _ e) = case e of+  HsUntypedSplice _ _ -> True+  HsTypedSplice _ _ -> True+  _ -> False++isSpliceLDecl :: LHsDecl GhcPs -> Bool+isSpliceLDecl (L _ d) = case d of+  SpliceD _ _ -> True+  _ -> False++mutationTypeCheckAction ::+  [CommandLineOption] ->+  ModSummary ->+  TcGblEnv ->+  TcM TcGblEnv+mutationTypeCheckAction opts ms tcGblEnv = do+  let mn = moduleNameString (moduleName (tcg_mod tcGblEnv))+  Settings+    { settingExceptions = exceptions,+      settingDisabledMutations = disabledFromConfig,+      settingIgnore = ignore,+      settingSkipThSplices = skipThSplices,+      settingOperators = operatorsConfig,+      settingDebug = debug,+      settingSkipInstrumentation = skipInstrumentation,+      settingManifestDir = manifestDir+    } <-+    liftIO $ resolveSettings opts+  -- Operators turned off via @operators.<Name>.enable: false@ are disabled+  -- exactly as if listed in @disabled-mutations@.  Operator-specific options+  -- ride along in each operator's config entry and are read by the operator.+  let disabledFromOperatorsConfig = operatorsConfigDisabled operatorsConfig+  if "Paths_" `isPrefixOf` mn || mn `elem` exceptions || skipInstrumentation+    then pure tcGblEnv+    else do+      let annEnv = tcg_ann_env tcGblEnv+      let modAnns = findAnns deserializeWithData annEnv (ModuleTarget (tcg_mod tcGblEnv)) :: [String]+      let disabledFromModAnns = parseMutationAnnStrings modAnns+      -- A "disable-mutations" annotation with no names means disable all+      -- mutations for this module.  Skip both the AST walk and the splice-+      -- span lookup; the module's compiled artefacts are returned unchanged.+      if DisableAll `elem` disabledFromModAnns+        then do+          liftIO $ putStrLn $ "mutation: skipping " ++ mn ++ " (DisableMutations)"+          pure tcGblEnv+        else do+          let disabledNames = disabledFromConfig ++ disabledFromOperatorsConfig ++ [n | DisableNamed n <- disabledFromModAnns]+          liftIO $ putStrLn $ "mutation: instrumenting " ++ mn+          let mSrcPath = ml_hs_file (ms_location ms)+          spliceSpans <-+            if skipThSplices+              then liftIO $ Map.findWithDefault [] mn <$> readIORef spliceSpansMap+              else pure []+          (binds', groups) <-+            runInstrument tcGblEnv allOperators annEnv disabledNames mSrcPath debug skipThSplices operatorsConfig spliceSpans ignore $+              instrumentModule (tcg_binds tcGblEnv)+          let totalMutations = sum [length rs | MutationGroup rs <- groups]+          liftIO $ do+            putStrLn $ "added " ++ show totalMutations ++ " mutations in " ++ show (length groups) ++ " groups"+            case manifestDir of+              Nothing -> pure ()+              Just dir -> writeModuleManifest dir mn groups+          pure tcGblEnv {tcg_binds = binds'}++-- | Write the manifest for one module to @<dir>/<ModuleName>.json@ and a+-- coloured human-readable rendering to @<dir>/<ModuleName>.txt@.  Each+-- module gets its own pair of files, so no locking is needed.+--+-- The @.txt@ is what reviewers diff during code review; it uses the same+-- header + unified-diff layout as the runtime's surviving-mutation report.+writeModuleManifest :: Path Abs Dir -> String -> [MutationGroup] -> IO ()+writeModuleManifest dir mn groups = do+  let manifest = MutationManifest groups+  writeManifestFile dir mn manifest+  writeManifestTxtFile dir mn manifest
+ src/Test/Syd/Mutation/Plugin/Instrument.hs view
@@ -0,0 +1,1653 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Test.Syd.Mutation.Plugin.Instrument+  ( MutationRecord (..),+    MutationOperator (..),+    MutationOperatorKind (..),+    MutationAlt (..),+    ClauseAlt (..),+    wrapWithIfMutation,+    SrcSpanDelta (..),+    InstrumentEnv (..),+    OpAppCtx (..),+    InstrM,+    liftTcM,+    runInstrument,+    instrumentModule,+    applySpanRemoval,+    applySwapSpans,+    parseFunMutationAnns,+    FunMutationAnns (..),+    LocalDisable (..),+    deadDisableTargets,+  )+where++import Control.Monad (filterM, foldM, forM_)+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Writer.Strict+import qualified Data.ByteString as SB+import Data.List (stripPrefix)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+-- 'typeKind' is hidden because 'GHC' re-exports the GHCi-eval 'typeKind' from+-- 'GHC.Runtime.Eval', which clashes with the 'GHC.Core.Type.typeKind' used below.+import GHC hiding (typeKind)+import GHC.Builtin.Types (charTy, manyDataConTy, mkListTy)+import GHC.Core.Predicate (isEvVar)+import GHC.Core.TyCo.Rep (Scaled (..))+import GHC.Core.Type (isLiftedTypeKind, typeKind)+import GHC.Data.Bag (mapBagM)+import GHC.Data.FastString (mkFastString)+import GHC.Driver.Env (HscEnv (..))+import GHC.Driver.Session (WarningFlag (..), wopt_set)+import GHC.Hs.Syn.Type (lhsExprType)+import GHC.HsToCore (deSugarExpr)+import GHC.Serialized (deserializeWithData)+import GHC.Tc.Errors.Types (mkTcRnUnknownMessage)+import GHC.Tc.Types+import GHC.Tc.Utils.Env (tcLookupDataCon, tcLookupId)+import GHC.Tc.Utils.Monad (addErrAt, getTopEnv, newUnique)+import GHC.Types.Annotations (AnnEnv, AnnTarget (..), findAnns)+import GHC.Types.Basic (DoPmc (..), GenReason (..), Origin (..), isGenerated)+import GHC.Types.Error (isEmptyMessages, mkPlainError, noHints)+import GHC.Types.Id (idName, mkSysLocal)+import GHC.Types.Name (getOccString)+import GHC.Types.Name.Occurrence (lookupOccEnv, mkDataOcc, mkVarOcc)+import GHC.Types.Name.Reader (GlobalRdrEnv, greName)+import GHC.Types.SourceText (SourceText (NoSourceText))+import GHC.Types.SrcLoc (combineRealSrcSpans)+import GHC.Utils.Outputable (text)+import Path+import Path.IO (forgivingAbsence, resolveFile')+import Test.Syd.Mutation.Manifest (MutationGroup (..), MutationRecord (..), controlOperatorName)+import Test.Syd.Mutation.Plugin.Operator.Util (headNameMatches)+import Test.Syd.Mutation.Plugin.OptParse (OperatorConfig)+import Test.Syd.Mutation.Runtime (MutationId (..))++-- ---------------------------------------------------------------------------+-- Source delta++-- | Describes the source-level change a mutation makes, for display purposes.+data SrcSpanDelta+  = -- | Replace the matched expression's span text with this exact text.+    TokenReplace Text+  | -- | Replace the text at a specific sub-span (within the matched+    -- expression) with this exact text. Used for operator-token swaps+    -- (e.g. @+@ → @-@), where the matched expression covers the whole+    -- operator application but the textual change is only the operator+    -- token itself.+    TokenReplaceAt RealSrcSpan Text+  | -- | Remove these source line ranges from within the outer expression's span.+    SpanRemoval [RealSrcSpan]+  | -- | Prepend this text at the start of the matched expression's span.+    PrependText Text+  | -- | Wrap the matched expression's span text with a prefix and suffix.+    -- Useful when the prefix alone would re-parse with the wrong precedence+    -- (e.g. @not n < 0@ parses as @(not n) < 0@, so we want @not (n < 0)@).+    WrapWithText Text Text+  | -- | Replace an arbitrary outer span (wider than the matched expression's+    -- own span) with the given text.  Used by the const-family operators+    -- when the matched expression sits at the operator position of an infix+    -- application: text-splicing the operator token alone would produce+    -- nonsense source (e.g. replacing @||@ with @\\_ _ -> True@ in+    -- @not a || b@), so we replace the whole @OpApp@ span with a prefix-form+    -- rewrite instead.+    ReplaceOuterSpan RealSrcSpan Text+  | -- | Swap the source text at two sub-spans (both within the matched+    -- expression's span) with each other, leaving everything else+    -- untouched.  Used by the 'SwitchFunctionArguments' operator to swap two+    -- equal-typed arguments of a function application.+    SwapSpans RealSrcSpan RealSrcSpan+  | -- | No textual change at all: the mutated lines equal the source lines.+    -- Used by control (no-op) mutations, which are a deliberate non-diff.+    NoDelta++-- ---------------------------------------------------------------------------+-- Operator++-- | A single mutation alternative produced by an operator at one site.+--+-- An operator returns a list of these (one per distinct mutation to generate+-- at the site).  Each gets its own 'MutationId' and is wrapped independently+-- as a nested 'ifMutation' call; 'tryMutateWith' validates each by desugaring+-- and silently drops any that produce diagnostics (e.g. overflowed literals).+data MutationAlt = MutationAlt+  { -- | The result type of the matched expression (used to type the+    -- @ifMutation@ wrapper).+    mutAltType :: Type,+    -- | The mutated replacement expression.+    mutAltExpr :: LHsExpr GhcTc,+    -- | Human-readable description of the original code, for the manifest.+    mutAltOriginal :: String,+    -- | Human-readable description of the replacement, for the manifest.+    mutAltReplacement :: String,+    -- | How the source text changes, for the manifest preview.+    mutAltDelta :: SrcSpanDelta,+    -- | Optional hint about how this mutation can be mitigated other than by+    -- killing it (e.g. that it is an equivalent mutant and which config key+    -- suppresses it).  'Nothing' for most operators.+    mutAltMitigation :: Maybe Text+  }++-- | A single mutation operator: its name and description (shared by every+-- kind) together with the kind-specific way it finds and makes mutations.+data MutationOperator = MutationOperator+  { -- | The operator's name, used as the key in config and reports.+    operatorName :: String,+    operatorDescription :: String,+    -- | What the operator mutates, and how it finds candidates.+    operatorKind :: MutationOperatorKind+  }++-- | The kinds of mutation operator, distinguished by the AST level they mutate.+-- Each carries a match function that, given a node, returns the mutation+-- alternatives to generate at it, or 'Nothing' if the node is not a candidate.+data MutationOperatorKind+  = -- | Mutates a single typechecked expression in place, wrapped as+    -- @ifMutation \@ty mutant original@.  All of the original operators are of+    -- this kind.  The matched expression has already had its children+    -- recursively instrumented by the time the match function is called, so the+    -- operator only needs to inspect the top-level shape.  The action runs in+    -- 'InstrM' so it can look up replacement operator ids via 'TcM' when needed+    -- (e.g. swapping @(+)@ for @(-)@).+    ExpressionOperator (LHsExpr GhcTc -> Maybe (InstrM [MutationAlt]))+  | -- | Mutates a function binding's set of clauses (its 'MatchGroup') rather+    -- than a single expression.  A function-declaration mutation cannot be+    -- expressed through the expression-level @ifMutation@ swap because a clause+    -- is not an 'LHsExpr'; see 'ClauseAlt' for how its mutants are applied.+    FunctionDeclarationOperator (MatchGroup GhcTc (LHsExpr GhcTc) -> Maybe (InstrM [ClauseAlt]))++-- | A single clause-level mutation alternative produced by a+-- 'FunctionDeclarationOperator' at one function binding.+--+-- Unlike an expression 'MutationAlt' — whose mutant is a self-contained+-- replacement expression the framework wraps in @ifMutation@ — a clause mutant+-- generally has to refer to its own 'MutationId' (e.g. to gate a clause on+-- @ifMutation mid False True@).  So instead of a ready-made AST, a 'ClauseAlt'+-- carries 'clauseAltApply': given the 'MutationId' the framework assigned and+-- the match group built so far, it returns the match group with this mutation+-- layered in.  The framework folds 'clauseAltApply' over every alternative, so+-- all of a binding's clause mutations coexist in one compiled match group, each+-- selectable at runtime by its own id — the clause-level analogue of the nested+-- @ifMutation@ wrappers on the expression side.+data ClauseAlt = ClauseAlt+  { -- | Source span of the affected clause, used to build the 'MutationId' and+    -- the manifest record.+    clauseAltSpan :: SrcSpan,+    -- | Human-readable description of the original code, for the manifest.+    clauseAltOriginal :: String,+    -- | Human-readable description of the replacement, for the manifest.+    clauseAltReplacement :: String,+    -- | How the source text changes, for the manifest preview.+    clauseAltDelta :: SrcSpanDelta,+    -- | Optional mitigation hint.+    clauseAltMitigation :: Maybe Text,+    -- | Layer this mutation (identified by the given 'MutationId') into the+    -- match group built so far.  Must preserve the number and order of clauses+    -- so later alternatives still address the right clause by position.+    clauseAltApply :: MutationId -> MatchGroup GhcTc (LHsExpr GhcTc) -> InstrM (MatchGroup GhcTc (LHsExpr GhcTc))+  }++-- ---------------------------------------------------------------------------+-- Monad++data InstrumentEnv = InstrumentEnv+  { instrumentEnvModule :: Module,+    -- | Source name ('OccName' string) of the enclosing top-level binding we+    -- are currently instrumenting, if any.  Set on entry to each top-level+    -- 'FunBind' \/ 'VarBind' \/ 'AbsBinds' (but not for nested local bindings,+    -- which keep the top-level name).  Recorded in each mutation so the report+    -- can suggest the exact @{-# ANN \<binding\> ... #-}@ disable annotation.+    instrumentEnvCurrentBinding :: Maybe String,+    -- | The module's 'GlobalRdrEnv', used by operators to look up replacement ids.+    instrumentEnvRdrEnv :: GlobalRdrEnv,+    -- | Id for Test.Syd.Mutation.Runtime.ifMutation, looked up once per module.+    instrumentEnvIfMutationId :: Id,+    -- | DataCon for Test.Syd.Mutation.Runtime.MutationId, looked up once per module.+    instrumentEnvMutationIdCon :: DataCon,+    -- | Operators to try.  Both kinds live in one list; the expression walker+    -- uses the 'ExpressionOperator's and the binding walker the+    -- 'FunctionDeclarationOperator's.+    instrumentEnvOperators :: [MutationOperator],+    -- | Annotation environment for reading {-# ANN #-} annotations.+    instrumentEnvAnnEnv :: AnnEnv,+    -- | Mutation type names disabled at module or global scope.+    instrumentEnvDisabledMutations :: [String],+    -- | Source file (relative path) and pre-read lines, read once per module.+    instrumentEnvSourceFile :: Maybe (Path Rel File, [Text]),+    -- | Print each mutation site as it is recorded (enabled by --debug plugin opt).+    instrumentEnvDebug :: Bool,+    -- | When True, do not instrument the expanded body of TH splices and+    -- quasi-quotes.  Detected two ways: (a) matching+    -- @XExpr (ExpandedThingTc orig _)@ where @orig@ is an 'OrigExpr'+    -- wrapping a splice node — covers operator-style expansions; (b)+    -- checking whether a mutation's 'RealSrcSpan' lies inside any span in+    -- 'instrumentEnvSpliceSpans' — covers top-level splices like @mkYesodData@+    -- and quasi-quotes that are evaluated at rename time and leave no+    -- 'ExpandedThingTc' wrapper in the typechecked AST.  Enabled by+    -- @--skip-th-splices@.+    instrumentEnvSkipThSplices :: Bool,+    -- | Per-operator configuration (keyed by operator name) from the+    -- @operators@ config object.  Operators read their own entry's+    -- 'operatorConfigExtra' to interpret their options.+    instrumentEnvOperatorsConfig :: Map Text OperatorConfig,+    -- | Splice 'RealSrcSpan's collected from the parsed AST (one entry per+    -- @$(...)@, @[name|...|]@, or 'SpliceD').  Only populated when+    -- 'instrumentEnvSkipThSplices' is True; used by 'recordMutation' to drop+    -- mutations whose own span is contained in any splice span.+    instrumentEnvSpliceSpans :: [RealSrcSpan],+    -- | Unqualified identifier names whose calls are ignored: any expression+    -- whose syntactic head is one of these is left untouched by+    -- 'instrumentLExpr' (no operators tried, no recursion into children).+    -- Populated from the @ignore@ YAML config field.  Used to silence noisy+    -- mutations on calls like @logDebug "..."@ where dropping or mutating+    -- the call almost never affects observable behaviour, producing+    -- surviving mutants that are pure noise.+    instrumentEnvIgnore :: [String],+    -- | True when instrumenting a guard expression (BodyStmt inside a GRHS).+    -- Used by ConstBool to suppress the e->False alternative, which would make+    -- the guard non-exhaustive and throw an exception that tests can't catch.+    instrumentEnvInGuard :: Bool,+    -- | Per-local-binding mutation disables that apply inside the currently+    -- enclosing top-level binding. Keyed by the local binding's source-level+    -- name (its 'OccName' string).  Populated by 'withFunBindEnv' when an+    -- outer @{-# ANN funName ("DisableMutationsFor inner..." :: String) #-}@+    -- annotation is present, and consumed by 'instrumentBind' when entering+    -- a matching local 'FunBind' or 'VarBind'.  Cleared at the start of each+    -- top-level binding so disables don't leak across them.+    instrumentEnvLocalDisables :: Map String LocalDisable,+    -- | True when we are currently instrumenting a local binding inside a+    -- @let@ or @where@.  Gates 'withLocalDisable' so it never matches the+    -- top-level binding itself — which would happen at @XHsBindsLR+    -- AbsBinds@, whose inner 'FunBind' has the same source name as its poly+    -- export and would otherwise spuriously consume a 'DisableMutationsFor'+    -- entry intended for an identically named local.+    instrumentEnvInLocalLet :: Bool,+    -- | When 'Just', we are currently walking the typechecker's expansion+    -- of a source-level @OpApp@ (an infix operator application like+    -- @not a || b@).  The walker stashes the original 'OpApp' source spans+    -- and operand text here so const-family operators that fire on the+    -- bare operator (or a partial application carrying the operator's span)+    -- can emit a 'ReplaceOuterSpan' delta that rewrites the whole infix+    -- expression in prefix form, instead of text-splicing a non-operator+    -- replacement into the operator-token slot and producing nonsense+    -- source.  Cleared (set back to 'Nothing') when the walker leaves the+    -- expansion.+    instrumentEnvOpAppCtx :: Maybe OpAppCtx,+    -- | How many enclosing 'HsApp' function-position layers we are inside.+    --+    -- Incremented when the walker descends into the function side ('f') of+    -- an @HsApp f a@; reset to 0 when descending into the argument side+    -- ('a') or any non-application sub-expression (lambda body, case+    -- scrutinee, let body, list element, ...).  Preserved through+    -- 'HsPar', 'WrapExpr', and 'ExpandedThingTc' wrappers, which do not+    -- disrupt the "I am the function head" relationship.+    --+    -- The const-family operators ('ConstNothing' / 'ConstEmptyList' /+    -- 'ConstBool') consult this to skip arity-\>=1 mutations at sites where+    -- the matched expression is already saturated by enclosing+    -- applications: an arity-N const-fn mutant @\\_ ... _ -> v@ inserted+    -- under @N@ levels of 'HsApp' is dominated by the arity-0 mutation on+    -- the outermost saturated expression (both reduce to @v@), so emitting+    -- both is pure noise.+    instrumentEnvAppDepth :: Int+  }++-- | Original source information for an enclosing infix @OpApp@ — captured+-- when the walker enters the typechecker's expansion of one.  See+-- 'instrumentEnvOpAppCtx'.+data OpAppCtx = OpAppCtx+  { -- | The full source span of the @OpApp@ (from the start of LHS to the+    -- end of RHS).  Used as the outer span when rewriting the preview.+    opAppOuterSpan :: RealSrcSpan,+    -- | The source span of the operator token itself.  An operator at this+    -- exact span is the bare-operator mutation site.+    opAppOpSpan :: RealSrcSpan,+    -- | The exact source text of the LHS operand.+    opAppLhsText :: Text,+    -- | The exact source text of the RHS operand.+    opAppRhsText :: Text+  }++-- | The 'StateT' state threaded through instrumentation.+data InstrState = InstrState+  { -- | Names of 'DisableMutationsFor' targets that 'applyLocalDisables' has+    -- matched against a real local binding within the body currently being+    -- walked.  'withFunBindEnv' brackets each declaring binding by resetting+    -- this to empty, walking the body, and reading it back: any declared+    -- target still absent named a binding that does not exist, so the+    -- annotation is dead and we raise a compile error (see+    -- 'deadDisableTargets').  Bracketing per declaring binding keeps the+    -- bookkeeping correct even when several bindings disable the same local+    -- name (e.g. an @inner@ in each), which a single threaded set could not.+    instrConsumedDisables :: !(Set String),+    -- | Count of real mutations recorded since the last control (no-op)+    -- mutation was inserted.  When it reaches 'controlInterval', the next+    -- expression-level mutation site also emits a control and this resets.+    -- Counts module-wide (the plugin runs per module), across all operators.+    instrSinceControl :: !Int,+    -- | Monotonic sequence number for control mutations in this module, used+    -- as the disambiguating last component of each control's 'MutationId' so+    -- two controls at the same source span never collide.+    instrControlSeq :: !Int+  }++emptyInstrState :: InstrState+emptyInstrState =+  InstrState+    { instrConsumedDisables = Set.empty,+      instrSinceControl = 0,+      instrControlSeq = 0+    }++-- | How many real mutations to record between each inserted control (no-op)+-- mutation.  Fixed, not configurable.  Sparse on purpose: a control samples the+-- harness for false kills, and even a handful across a run catches a systemic+-- flaky\/nondeterministic suite - more just adds overhead and report noise.+--+-- There is no per-module floor: a module (compilation unit) with fewer than+-- 'controlInterval' real mutations gets no control.  Any real mutation-testing+-- target has far more than this many mutations overall, so a run always ends up+-- with controls; only toy builds get none, and those do not need the canary.+controlInterval :: Int+controlInterval = 12++type InstrM = WriterT [MutationGroup] (StateT InstrState (ReaderT InstrumentEnv TcM))++liftTcM :: TcM a -> InstrM a+liftTcM = lift . lift . lift++-- ---------------------------------------------------------------------------+-- Entry point++-- | Look up the Ids we need from the module's GlobalRdrEnv (populated by the+-- injected @import Test.Syd.Mutation.Plugin.Runtime@ from the parsed-stage plugin),+-- then run the instrumentation.+runInstrument ::+  TcGblEnv ->+  [MutationOperator] ->+  -- | Annotation environment for reading {-# ANN #-} annotations.+  AnnEnv ->+  -- | Mutation type names disabled globally or at module scope.+  [String] ->+  -- | Source file path for this module (used to read context lines once).+  Maybe FilePath ->+  -- | Print each mutation site as it is recorded.+  Bool ->+  -- | Skip TH splices and quasi-quotes.+  Bool ->+  -- | Per-operator configuration, keyed by operator name.+  Map Text OperatorConfig ->+  -- | Splice spans collected at parse time, used to filter mutations.+  [RealSrcSpan] ->+  -- | Unqualified identifier names whose call expressions are ignored: no+  -- mutations are produced for them or anything inside their argument+  -- subtrees.+  [String] ->+  InstrM a ->+  TcM (a, [MutationGroup])+runInstrument tcGblEnv operators annEnv disabledMutations mSrcPath debug skipThSplices operatorsConfig spliceSpans ignore action = do+  let rdrEnv = tcg_rdr_env tcGblEnv+      modul = tcg_mod tcGblEnv+  ifMutId <- lookupRdrEnvId rdrEnv "ifMutation"+  mutIdCon <- lookupRdrEnvDataCon rdrEnv "MutationId"+  mSrcFile <- liftIO $ case mSrcPath >>= parseRelFile of+    Nothing -> pure Nothing+    Just relFile -> do+      absFile <- resolveFile' (fromRelFile relFile)+      mbs <- forgivingAbsence (SB.readFile (fromAbsFile absFile))+      pure $ fmap (\bs -> (relFile, T.lines (TE.decodeUtf8Lenient bs))) mbs+  let activeOperators = filter (\op -> operatorName op `notElem` disabledMutations) operators+  flip+    runReaderT+    InstrumentEnv+      { instrumentEnvModule = modul,+        instrumentEnvCurrentBinding = Nothing,+        instrumentEnvRdrEnv = rdrEnv,+        instrumentEnvIfMutationId = ifMutId,+        instrumentEnvMutationIdCon = mutIdCon,+        instrumentEnvOperators = activeOperators,+        instrumentEnvAnnEnv = annEnv,+        instrumentEnvDisabledMutations = disabledMutations,+        instrumentEnvSourceFile = mSrcFile,+        instrumentEnvDebug = debug,+        instrumentEnvSkipThSplices = skipThSplices,+        instrumentEnvOperatorsConfig = operatorsConfig,+        instrumentEnvSpliceSpans = spliceSpans,+        instrumentEnvIgnore = ignore,+        instrumentEnvInGuard = False,+        instrumentEnvAppDepth = 0,+        instrumentEnvLocalDisables = Map.empty,+        instrumentEnvInLocalLet = False,+        instrumentEnvOpAppCtx = Nothing+      }+    $ evalStateT (runWriterT action) emptyInstrState++-- | Look up a value Id from the module's GlobalRdrEnv by OccName.+-- The name must be in scope via the injected import of Test.Syd.Mutation.Plugin.Runtime.+lookupRdrEnvId :: GlobalRdrEnv -> String -> TcM Id+lookupRdrEnvId rdrEnv occStr =+  case lookupOccEnv rdrEnv (mkVarOcc occStr) of+    Just (gre : _) -> tcLookupId (greName gre)+    _ ->+      liftIO $+        ioError $+          userError $+            "mutation: " ++ occStr ++ " not in scope (is Test.Syd.Mutation.Plugin.Runtime imported?)"++-- | Look up a DataCon from the module's GlobalRdrEnv by OccName.+lookupRdrEnvDataCon :: GlobalRdrEnv -> String -> TcM DataCon+lookupRdrEnvDataCon rdrEnv occStr =+  case lookupOccEnv rdrEnv (mkDataOcc occStr) of+    Just (gre : _) -> tcLookupDataCon (greName gre)+    _ ->+      liftIO $+        ioError $+          userError $+            "mutation: " ++ occStr ++ " not in scope (is Test.Syd.Mutation.Plugin.Runtime imported?)"++instrumentModule :: LHsBinds GhcTc -> InstrM (LHsBinds GhcTc)+instrumentModule = instrumentBinds++-- ---------------------------------------------------------------------------+-- Bind walkers++instrumentBinds :: LHsBinds GhcTc -> InstrM (LHsBinds GhcTc)+instrumentBinds = mapBagM (traverse instrumentBind)++instrumentBind :: HsBind GhcTc -> InstrM (HsBind GhcTc)+instrumentBind = \case+  -- Skip compiler-generated bindings entirely.  Stock/anyclass-derived+  -- instance methods and the default-method copies GHC fills into an explicit+  -- instance both land in 'tcg_binds' as 'FunBind's whose 'MatchGroup' carries+  -- a 'Generated' 'Origin', with source spans pointing at the @deriving@ clause+  -- or the instance head.  Instrumenting them is meaningless: the diffs are+  -- nonsense (e.g. @deriving (Show, (\\_ _ -> False), ...)@ or @(\\_ -> [])@+  -- replacing a whole instance head) and the mutants can never be killed by a+  -- test of the user's own source, so they are pure noise in the report.+  --+  -- User-written instance methods (e.g. an explicit @validate = ...@) keep a+  -- 'FromSource' origin and are still instrumented.  Note we must NOT apply+  -- this filter in 'instrumentMatchGroup', because the renamer's @do@-block+  -- expansion produces 'Generated' lambda 'MatchGroup's whose bodies are the+  -- user's own code and do need instrumenting.+  b@(FunBind _ _ mg) | isGenerated (matchGroupOrigin mg) -> pure b+  FunBind x name mg -> do+    let funName = idName (unLoc name)+    -- 'withLocalDisable' is a no-op outside an enclosing local-let scope (the+    -- 'instrumentEnvInLocalLet' flag is false at module top-level), so it only fires+    -- on truly local bindings.  Inside, 'withFunBindEnv' sees no annotations+    -- (locals can't be ANN'd) and leaves the disable map intact.+    -- Instrument the clause bodies first, then (for a multi-clause binding)+    -- layer the RemoveClause mutations on top.  Doing clause removal here in+    -- 'instrumentBind' rather than in the shared 'instrumentMatchGroup' scopes+    -- it to function equations only: the 'MatchGroup's of @\\case@ lambdas and+    -- @case@ expressions also flow through 'instrumentMatchGroup' but must not+    -- gain removal guards (case alternatives are 'RemoveCase'\'s job).+    mg' <- withCurrentBinding funName (withLocalDisable funName (withFunBindEnv funName (instrumentMatchGroup mg >>= applyFunctionDeclarationOperators)))+    pure (FunBind x name mg')+  PatBind x pat mult rhs -> PatBind x pat mult <$> instrumentGRHSs rhs+  -- Skip evidence bindings.  The typechecker materialises the dictionaries an+  -- instance needs as @VarBind@s (e.g. @$dShow@, @$dEnum@) whose source spans+  -- point at the @deriving@ clause or the instance head and whose right-hand+  -- sides reference the (list- and bool-returning) method components of the+  -- dictionary.  Instrumenting them produces the same nonsense mutants as the+  -- derived methods themselves (@deriving (Show, (\\_ -> []), ...)@), so leave+  -- evidence alone.  User-written @x = e@ bindings are never evidence, so they+  -- are still instrumented.+  b@(VarBind _ var _) | isEvVar var -> pure b+  VarBind x var rhs -> VarBind x var <$> withCurrentBinding (idName var) (withLocalDisable (idName var) (instrumentLExpr rhs))+  PatSynBind x psb -> pure (PatSynBind x psb)+  -- At GhcTc, XHsBindsLR carries an AbsBinds (see XXHsBindsLR instance).+  -- {-# ANN f #-} annotations attach to the poly Id (abe_poly), but the inner+  -- FunBinds carry mono Ids.  Apply poly-name annotations here so they cover+  -- the inner binds, which withFunBindEnv would otherwise miss.+  XHsBindsLR ab@AbsBinds {abs_binds, abs_exports} -> do+    let polyNames = map (idName . abe_poly) abs_exports+    binds' <- foldr withFunBindEnv (mapBagM (traverse instrumentBind) abs_binds) polyNames+    pure (XHsBindsLR ab {abs_binds = binds'})++-- | Record @name@ as the enclosing top-level binding for the wrapped action,+-- so mutations inside it carry the binding name for the report's disable-hint.+--+-- A no-op once we are inside a local @let@ \/ @where@+-- ('instrumentEnvInLocalLet' is True): a nested binding keeps the enclosing+-- top-level name, which is the one a @{-# ANN ... #-}@ would target.+withCurrentBinding :: Name -> InstrM a -> InstrM a+withCurrentBinding name action = do+  inLocal <- asks instrumentEnvInLocalLet+  if inLocal+    then action+    else local (\env -> env {instrumentEnvCurrentBinding = Just (getOccString name)}) action++-- | If @bindName@'s source-level name is a key in 'instrumentEnvLocalDisables',+-- narrow 'instrumentEnvOperators' for the wrapped action and remove the entry from+-- the map (so the same disable doesn't re-fire on a shadowed inner binding).+--+-- This is the lookup half of @DisableMutationsFor <name>@: the outer+-- top-level binding's 'withFunBindEnv' installed the map; this is where+-- the local binding's RHS instrumentation consults it.+--+-- No-op when 'instrumentEnvInLocalLet' is False — the matching only applies inside a+-- @let@ or @where@, not to the top-level binding itself (whose inner FunBind+-- shares a source name with its poly export).+withLocalDisable :: Name -> InstrM a -> InstrM a+withLocalDisable bindName action = do+  InstrumentEnv {instrumentEnvInLocalLet} <- ask+  if instrumentEnvInLocalLet+    then applyLocalDisables [getOccString bindName] action+    else action++-- | Like 'withLocalDisable' but takes a list of 'Id's (typically the binders+-- of a @do@-block 'BindStmt' pattern) and matches any of them.+--+-- Always checks regardless of 'instrumentEnvInLocalLet': @<-@-bound names cannot+-- collide with the enclosing top-level binding the way the+-- @XHsBindsLR AbsBinds@ inner 'FunBind' can, so the gate is unnecessary+-- here.+withLocalDisableMany :: [Id] -> InstrM a -> InstrM a+withLocalDisableMany ids =+  applyLocalDisables (map (getOccString . idName) ids)++-- | Common implementation: look up any of @occs@ in 'instrumentEnvLocalDisables',+-- narrow operators by the merged disable list, and remove all matched+-- entries from the map for the wrapped action.+applyLocalDisables :: [String] -> InstrM a -> InstrM a+applyLocalDisables occs action = do+  InstrumentEnv {instrumentEnvLocalDisables, instrumentEnvOperators} <- ask+  let matches = [(occ, d) | occ <- occs, Just d <- [Map.lookup occ instrumentEnvLocalDisables]]+  case matches of+    [] -> action+    _ -> do+      modify' (\s -> s {instrConsumedDisables = Set.union (Set.fromList (map fst matches)) (instrConsumedDisables s)})+      let disableAll = any ((== DisableAllOps) . snd) matches+          namedDisables = concat [ns | (_, DisableOps ns) <- matches]+          operators' =+            if disableAll+              then []+              else filter (\op -> operatorName op `notElem` namedDisables) instrumentEnvOperators+          remaining = foldr (Map.delete . fst) instrumentEnvLocalDisables matches+      local+        ( \env ->+            env+              { instrumentEnvOperators = operators',+                instrumentEnvLocalDisables = remaining+              }+        )+        action++-- | The 'DisableMutationsFor' targets that never matched a local binding.+--+-- @declared@ is the local-disable map a top-level binding's annotations+-- installed (keyed by target name); @consumed@ is the set of target names that+-- 'applyLocalDisables' actually matched against a real local binding while+-- walking that binding's body.  A declared target absent from @consumed@ named+-- a binding that does not exist (e.g. a typo or a since-renamed local), so the+-- annotation disables nothing and should be removed.+deadDisableTargets :: Map String LocalDisable -> Set String -> [String]+deadDisableTargets declared consumed =+  filter (`Set.notMember` consumed) (Map.keys declared)++-- | Run an instrumentation action with the operator list filtered by any+-- {-# ANN funName ("DisableMutations..." :: String) #-} annotations on the+-- given top-level name.+--+-- Also reads any @DisableMutationsFor <localName>...@ annotations on the+-- same top-level name and installs them in 'instrumentEnvLocalDisables' so that+-- 'instrumentBind' can scope them down to the right local binding.+--+-- @ANN@ targets only resolve for top-level names, so for local bindings+-- 'findAnns' returns @[]@; in that case this is the identity on the+-- environment (the existing 'instrumentEnvLocalDisables' from the enclosing+-- top-level binding is preserved).+withFunBindEnv :: Name -> InstrM a -> InstrM a+withFunBindEnv funName action = do+  InstrumentEnv {instrumentEnvAnnEnv, instrumentEnvOperators, instrumentEnvLocalDisables} <- ask+  let funAnns = findAnns deserializeWithData instrumentEnvAnnEnv (NamedTarget funName) :: [String]+      FunMutationAnns selfDisable localDisables = parseFunMutationAnns funAnns+      operators' = case selfDisable of+        DisableAllOps -> []+        DisableOps disabled -> filter (\op -> operatorName op `notElem` disabled) instrumentEnvOperators+      -- Only replace instrumentEnvLocalDisables when this binding actually contributes+      -- entries.  Local bindings have no ANN entries, so they return an empty+      -- map and we must keep the enclosing top-level binding's map intact.+      localDisables' =+        if Map.null localDisables+          then instrumentEnvLocalDisables+          else localDisables+  if Map.null localDisables+    then+      -- This binding contributes no 'DisableMutationsFor' targets, so it leaves+      -- the consumed-targets state alone: a local binding consumed inside it+      -- must still count for whichever outer binding declared the target.+      local (\env -> env {instrumentEnvOperators = operators'}) action+    else do+      -- This binding declares targets, so bracket the consumed-targets state:+      -- reset it to empty, walk the body, then read back exactly what this+      -- binding's body consumed.  A single threaded set would be wrong here,+      -- since several bindings can disable the same local name (e.g. an @inner@+      -- in each), and the first consumption would mask the others.+      saved <- gets instrConsumedDisables+      modify' (\s -> s {instrConsumedDisables = Set.empty})+      result <-+        local+          ( \env ->+              env+                { instrumentEnvOperators = operators',+                  instrumentEnvLocalDisables = localDisables'+                }+          )+          action+      consumed <- gets instrConsumedDisables+      -- Restore the enclosing scope's consumption, plus what this body added,+      -- so an outer declaring binding still sees targets consumed in here.+      modify' (\s -> s {instrConsumedDisables = saved `Set.union` consumed})+      -- Any declared target that was never consumed named a binding that does+      -- not exist, so the annotation disables nothing: raise a compile error+      -- asking for its removal.+      forM_ (deadDisableTargets localDisables consumed) $ \target ->+        liftTcM $+          addErrAt (nameSrcSpan funName) $+            mkTcRnUnknownMessage $+              mkPlainError noHints $+                text $+                  "Mutation DisableMutationsFor annotation on `"+                    ++ getOccString funName+                    ++ "` targets `"+                    ++ target+                    ++ "`, which is not a local binding in its body. "+                    ++ "It disables no mutations; remove it."+      pure result++-- | Parsed result of all mutation-related @{-# ANN funName ... #-}@+-- annotations on a single top-level binding.+data FunMutationAnns = FunMutationAnns+  { -- | What to do with mutations inside the binding itself.+    famSelfDisable :: !LocalDisable,+    -- | Disables targeted at specific local bindings within this top-level+    -- binding's body, keyed by the local binding's user-visible name.+    famLocalDisables :: !(Map String LocalDisable)+  }+  deriving (Eq, Show)++-- | What a single annotation disables on a scope.+data LocalDisable+  = -- | Disable all operators on this scope.+    DisableAllOps+  | -- | Disable exactly the listed operator names on this scope. An empty+    -- list means no disables apply at this scope.+    DisableOps [String]+  deriving (Eq, Show)++-- | Parse a list of @{-# ANN funName #-}@ string payloads.+--+-- Recognised forms (whitespace after the colon and commas is tolerated):+--+--   * @DisableMutations@                            — disable all operators on the binding.+--   * @DisableMutations: A, B@                      — disable the listed operators on the binding.+--   * @DisableMutation: A@                          — disable the single named operator on the binding.+--   * @DisableMutationsFor <name>@                  — disable all operators inside the+--                                                    local binding named @\<name\>@.+--   * @DisableMutationsFor <name>: A, B@            — disable the listed operators inside @\<name\>@.+--   * @DisableMutationFor <name>: A@                — disable the single named operator inside @\<name\>@.+--+-- @\<name\>@ matches the source-level identifier of a local binding inside+-- the annotated top-level function's body. Unrecognised strings are ignored.+parseFunMutationAnns :: [String] -> FunMutationAnns+parseFunMutationAnns =+  foldr combine (FunMutationAnns (DisableOps []) Map.empty) . concatMap parseOne+  where+    combine (Self d) (FunMutationAnns s ls) = FunMutationAnns (mergeDisable s d) ls+    combine (Local n d) (FunMutationAnns s ls) =+      FunMutationAnns s (Map.insertWith mergeDisable n d ls)++    parseOne :: String -> [ParsedAnn]+    parseOne s+      -- Try the "...For <name>" forms first so they don't get swallowed by+      -- the shorter prefixes.+      | Just rest <- stripPrefix "DisableMutationsFor " s =+          [Local n d | (n, d) <- splitForPayload rest DisableAllOps]+      | Just rest <- stripPrefix "DisableMutationFor " s =+          [Local n d | (n, d) <- splitForPayload rest (DisableOps [])]+      | s == "DisableMutations" = [Self DisableAllOps]+      | Just rest <- stripPrefix "DisableMutations:" s =+          [Self (DisableOps (map trim (splitOnComma rest)))]+      | Just rest <- stripPrefix "DisableMutation:" s =+          [Self (DisableOps [trim rest])]+      | otherwise = []++    -- After "DisableMutationsFor " (or "DisableMutationFor "), the rest is+    -- either "<name>"            (no colon → default disable)+    --        "<name>: A, B, ..."  (colon → DisableOps with named operators).+    -- For DisableMutationsFor without a colon, default = DisableAllOps.+    -- For DisableMutationFor without a colon, default = DisableOps [] (no-op),+    -- but we accept it for symmetry.+    splitForPayload :: String -> LocalDisable -> [(String, LocalDisable)]+    splitForPayload rest defaultDisable =+      case break (== ':') (trim rest) of+        (name, []) ->+          let n = trimTrailing name+           in [(n, defaultDisable) | not (null n)]+        (name, _ : opsRest) ->+          let n = trimTrailing name+              ops = map trim (splitOnComma opsRest)+           in [(n, DisableOps ops) | not (null n)]++    mergeDisable :: LocalDisable -> LocalDisable -> LocalDisable+    mergeDisable DisableAllOps _ = DisableAllOps+    mergeDisable _ DisableAllOps = DisableAllOps+    mergeDisable (DisableOps a) (DisableOps b) = DisableOps (a ++ b)++    trim = dropWhile (== ' ')+    trimTrailing = reverse . dropWhile (== ' ') . reverse . trim++data ParsedAnn+  = Self LocalDisable+  | Local String LocalDisable++splitOnComma :: String -> [String]+splitOnComma s = case break (== ',') s of+  (w, []) -> [w]+  (w, _ : rest) -> w : splitOnComma rest++-- | The 'Origin' (source vs compiler-generated) recorded on a typechecked+-- 'MatchGroup'.  Used by 'instrumentBind' to skip derived and default-method+-- bindings.+matchGroupOrigin :: MatchGroup GhcTc (LHsExpr GhcTc) -> Origin+matchGroupOrigin (MG x _) = mg_origin x++instrumentMatchGroup ::+  MatchGroup GhcTc (LHsExpr GhcTc) ->+  InstrM (MatchGroup GhcTc (LHsExpr GhcTc))+instrumentMatchGroup = \case+  MG x alts -> MG x <$> traverse (mapM (traverse instrumentMatch)) alts++instrumentMatch ::+  Match GhcTc (LHsExpr GhcTc) ->+  InstrM (Match GhcTc (LHsExpr GhcTc))+instrumentMatch = \case+  Match x ctx pats body -> Match x ctx pats <$> instrumentGRHSs body++-- | Try every 'FunctionDeclarationOperator' in turn on one function binding's+-- (already-instrumented) match group, layering each operator's mutations in.+--+-- The expression-level analogue is 'tryMutateWith'; the difference is that a+-- clause mutant is applied via 'clauseAltApply' (it has to refer to its own+-- 'MutationId') rather than wrapped in an @ifMutation@ around a ready-made+-- expression.+applyFunctionDeclarationOperators ::+  MatchGroup GhcTc (LHsExpr GhcTc) ->+  InstrM (MatchGroup GhcTc (LHsExpr GhcTc))+applyFunctionDeclarationOperators mg0 = do+  operators <- asks instrumentEnvOperators+  foldM applyFunctionDeclarationOperator mg0 operators++-- | Try one operator on a function binding.  Expression operators are ignored+-- here (they fire on expressions, in 'applyOperator').+applyFunctionDeclarationOperator ::+  MatchGroup GhcTc (LHsExpr GhcTc) ->+  MutationOperator ->+  InstrM (MatchGroup GhcTc (LHsExpr GhcTc))+applyFunctionDeclarationOperator mg op = case operatorKind op of+  ExpressionOperator _ -> pure mg+  FunctionDeclarationOperator match -> case match mg of+    Nothing -> pure mg+    Just action -> do+      alts <- action+      case alts of+        [] -> pure mg+        _ -> applyClauseAlts (operatorName op) mg alts++-- | Record each clause alternative and fold its 'clauseAltApply' into the match+-- group, so all of a binding's clause mutations coexist and each is selectable+-- at runtime by its own id.  The clause-level analogue of 'applyAlts'.+applyClauseAlts ::+  String ->+  MatchGroup GhcTc (LHsExpr GhcTc) ->+  [ClauseAlt] ->+  InstrM (MatchGroup GhcTc (LHsExpr GhcTc))+applyClauseAlts opName mg0 alts = do+  (mg', records) <- go 1 mg0 alts+  tell [MutationGroup records]+  -- Clause mutations count towards the control cadence too (so the interval+  -- reflects all real mutations), but a control is only ever inserted at an+  -- expression site, by 'applyAlts' - there is no single expression to wrap+  -- here.+  bumpSinceControl (length records)+  pure mg'+  where+    go _ mg [] = pure (mg, [])+    go altIndex mg (alt : rest) = do+      (mid, mRec) <-+        recordMutationAt+          (clauseAltSpan alt)+          opName+          (clauseAltOriginal alt)+          (clauseAltReplacement alt)+          (clauseAltDelta alt)+          (clauseAltMitigation alt)+          altIndex+      -- A filtered-out alternative (TH splice / 'UnhelpfulSpan') yields no+      -- record and is left unapplied, exactly as on the expression side.+      mg' <- maybe (pure mg) (const (clauseAltApply alt mid mg)) mRec+      (mg'', records) <- go (altIndex + 1) mg' rest+      pure (mg'', maybe records (: records) mRec)++instrumentGRHSs ::+  GRHSs GhcTc (LHsExpr GhcTc) ->+  InstrM (GRHSs GhcTc (LHsExpr GhcTc))+instrumentGRHSs = \case+  GRHSs x rhs localBinds ->+    GRHSs x <$> mapM (traverse instrumentGRHS) rhs <*> instrumentLocalBinds localBinds++instrumentGRHS ::+  GRHS GhcTc (LHsExpr GhcTc) ->+  InstrM (GRHS GhcTc (LHsExpr GhcTc))+instrumentGRHS = \case+  GRHS x guards body ->+    GRHS x+      <$> mapM instrumentStmt guards+      <*> instrumentLExpr body++instrumentLocalBinds :: HsLocalBinds GhcTc -> InstrM (HsLocalBinds GhcTc)+instrumentLocalBinds = \case+  HsValBinds x valBinds ->+    HsValBinds x+      <$> local (\env -> env {instrumentEnvInLocalLet = True}) (instrumentValBinds valBinds)+  lbs -> pure lbs++instrumentValBinds :: HsValBinds GhcTc -> InstrM (HsValBinds GhcTc)+instrumentValBinds = \case+  ValBinds x binds sigs ->+    ValBinds x <$> mapBagM (traverse instrumentBind) binds <*> pure sigs+  XValBindsLR (NValBinds binds sigs) ->+    XValBindsLR . flip NValBinds sigs+      <$> mapM (\(f, bag) -> (f,) <$> mapBagM (traverse instrumentBind) bag) binds++-- ---------------------------------------------------------------------------+-- Expression walkers++instrumentLExpr :: LHsExpr GhcTc -> InstrM (LHsExpr GhcTc)+instrumentLExpr le = do+  -- 'ignore' filter: if this expression's syntactic head is one of the+  -- configured names (e.g. "logDebug"), return it unchanged and do NOT+  -- recurse into children.  This silences mutations both on the call itself+  -- (the RemoveAction operator would otherwise turn @do { logDebug "x"; k }@+  -- into @do { k }@) and on every sub-expression of the arguments (so the+  -- string literal, an inner @show n@, etc. are also left alone).+  --+  -- 'headNameMatches' peels through HsApp/HsAppType/WrapExpr/HsPar wrappers to+  -- find the head identifier and matches a configured name either bare (e.g.+  -- "logDebug", matching any module) or fully qualified by the function's+  -- defining module or the module it is imported through (e.g.+  -- "Control.Monad.Logger.logDebug").+  expressionToIgnore <- asks instrumentEnvIgnore+  rdrEnv <- asks instrumentEnvRdrEnv+  if headNameMatches rdrEnv expressionToIgnore le+    then pure le+    else instrumentLExprGo le++instrumentLExprGo :: LHsExpr GhcTc -> InstrM (LHsExpr GhcTc)+instrumentLExprGo le = do+  -- ORDERING INVARIANT: instrument children before applying operators, but+  -- pass the ORIGINAL (pre-child-instrumentation) expression to the operators+  -- for matching and mutant construction.+  --+  -- Why this ordering matters+  -- -------------------------+  -- Each operator produces one or more mutant alternatives.  Those mutants+  -- are embedded as the "mutated" branch of an ifMutation call:+  --+  --   ifMutation id <mutant> <fallthrough>+  --+  -- If mutant alternatives were built from already-instrumented children, any+  -- child that appears in multiple mutant alternatives would be DUPLICATED in+  -- the AST.  The ListLit operator is the worst case: given a 6-element list+  --+  --   [e1, e2, e3, e4, e5, e6]+  --+  -- it generates three mutants (empty, drop-first, drop-last), so the final+  -- expression contains the list four times total.  If the elements are+  -- already instrumented, each ei' is itself a nested ifMutation tree, and+  -- elements e2..e5 each appear in three of the four copies.  With N elements+  -- each carrying K layers of ifMutation wrapping, the AST grows as O(N * K).+  --+  -- This blowup compounds across operators: ConstBool fires on every+  -- Bool-typed expression, wrapping even individual list elements in two more+  -- ifMutation layers before ListLit sees them.  For Text.Colour.Chunk, which+  -- has `and [isNothing f1, ..., isNothing f6]` and+  -- `catMaybes [e1, ..., e5]`, the duplicate-subtree explosion previously+  -- caused GHC to exceed 16 GB of heap even at -O0.+  --+  -- The fix: operators receive the original `le` (children not yet+  -- instrumented) and produce mutants whose sub-expressions are plain,+  -- undecorated AST nodes.  The fallthrough branch — the "run normally" path+  -- through all ifMutation guards — is `le'` (children fully instrumented),+  -- so every nested mutation site is still reachable when that specific+  -- mutation is not active.  This is semantically correct: a mutation is a+  -- change at one specific site; when that mutation is active we execute the+  -- mutant directly without needing to recurse into it for other mutations.+  le' <- traverse (instrumentExpr (getLocA le)) le+  InstrumentEnv {instrumentEnvOperators} <- ask+  tryMutateWith instrumentEnvOperators le le'++instrumentExpr :: SrcSpan -> HsExpr GhcTc -> InstrM (HsExpr GhcTc)+instrumentExpr _sp = \case+  -- Track HsApp function-position depth so const-family operators can skip+  -- arity-\>=1 mutations at saturated sites.  The function side ('f') sees+  -- depth+1 (it is one more level of "head of an application" than its+  -- parent); the argument side ('a') resets to 0 (a is its own root+  -- expression).+  HsApp x f a ->+    HsApp x+      <$> local (\env -> env {instrumentEnvAppDepth = instrumentEnvAppDepth env + 1}) (instrumentLExpr f)+      <*> local (\env -> env {instrumentEnvAppDepth = 0}) (instrumentLExpr a)+  HsLam x lv mg -> HsLam x lv <$> instrumentMatchGroup mg+  HsCase x scrut mg -> HsCase x <$> instrumentLExpr scrut <*> instrumentMatchGroup mg+  HsIf x c t e -> HsIf x <$> instrumentLExpr c <*> instrumentLExpr t <*> instrumentLExpr e+  HsLet x binds body -> HsLet x <$> instrumentLocalBinds binds <*> instrumentLExpr body+  HsDo x ctx stmts -> HsDo x ctx <$> traverse (mapM instrumentStmt) stmts+  ExplicitList x es -> ExplicitList x <$> mapM instrumentLExpr es+  HsPar x e -> HsPar x <$> instrumentLExpr e+  NegApp x e se -> NegApp x <$> instrumentLExpr e <*> pure se+  OpApp x l op r -> OpApp x <$> instrumentLExpr l <*> pure op <*> instrumentLExpr r+  ExplicitTuple x args bx -> ExplicitTuple x <$> mapM instrumentTupArg args <*> pure bx+  RecordCon x con flds -> RecordCon x con <$> instrumentRecordBinds flds+  -- XExpr nodes appear after typechecking for operator expansion etc.+  -- We instrument the expanded expression (what the desugarer sees), except+  -- when 'instrumentEnvSkipThSplices' is set and the original (pre-expansion) node+  -- was a TH splice or quasi-quote — those expansions are macro-generated+  -- code whose source location points at the splice site, so any mutations+  -- recorded inside would be unhelpful (every covering test would have to+  -- exercise the splice's expanded form, and the diff in the report would+  -- not line up with the source file).+  XExpr (ExpandedThingTc orig expanded) -> do+    skipSplices <- asks instrumentEnvSkipThSplices+    if skipSplices && isSpliceThing orig+      then pure (XExpr (ExpandedThingTc orig expanded))+      else case origBindStmtBinders orig of+        -- The expansion of @do { p <- rhs; rest }@ is @(>>=) rhs (\\p -> rest)@.+        -- Walk the expanded expression manually so we can apply the+        -- 'DisableMutationsFor' scope only to @rhs@ (the first argument of+        -- @(>>=)@), not to the continuation lambda's body — that body+        -- contains further expanded BindStmts whose RHS expressions belong+        -- to other names entirely.+        Just binders -> XExpr . ExpandedThingTc orig <$> instrumentBindExpansion binders expanded+        Nothing -> do+          -- If the expansion originated from a source-level @OpApp@ (an infix+          -- operator application like @not a || b@), stash the original+          -- spans and operand text in 'instrumentEnvOpAppCtx' for the+          -- duration of the inner walk so const-family operators that fire+          -- on the bare operator can rewrite their preview to prefix form.+          ctx <- mkOpAppCtx orig+          let updateEnv env = case ctx of+                Just c -> env {instrumentEnvOpAppCtx = Just c}+                Nothing -> env+          XExpr . ExpandedThingTc orig <$> local updateEnv (instrumentExpr _sp expanded)+  XExpr (WrapExpr (HsWrap co e)) ->+    XExpr . WrapExpr . HsWrap co <$> instrumentExpr _sp e+  e -> pure e++-- | True when an 'HsThingRn' wraps the unexpanded form of a TH splice or+-- quasi-quote.  GHC stores the pre-expansion node in 'ExpandedThingTc' so we+-- can recognise these without falling back to source-line heuristics.+isSpliceThing :: HsThingRn -> Bool+isSpliceThing = \case+  OrigExpr e -> isSpliceHsExpr e+  _ -> False++-- | If the original (pre-expansion) thing was a 'BindStmt' in a @do@-block,+-- return its pattern's binders.  GHC 9.10+ expands @do@-blocks in the+-- renamer so the typechecked AST sees @(>>=) e (\\p -> rest)@ rather than+-- the original 'BindStmt'; the original is preserved here for diagnostics+-- and we reuse it to drive 'DisableMutationsFor' scoping.+origBindStmtBinders :: HsThingRn -> Maybe [Name]+origBindStmtBinders = \case+  OrigStmt (L _ (BindStmt _ pat _)) ->+    Just (collectPatBinders CollNoDictBinders pat)+  _ -> Nothing++-- | If @orig@ is an 'OpApp' originating from source-level infix syntax,+-- extract the outer, operator-token, and operand source spans plus the+-- operand source text.  Returns 'Nothing' for any non-'OpApp' original or+-- when a needed span is 'UnhelpfulSpan' or when the source file isn't+-- available (so we can't read operand text).+mkOpAppCtx :: HsThingRn -> InstrM (Maybe OpAppCtx)+mkOpAppCtx orig = case orig of+  OrigExpr (OpApp _ lLhs lOp lRhs)+    | RealSrcSpan lhsSp _ <- getLocA lLhs,+      RealSrcSpan opSp _ <- getLocA lOp,+      RealSrcSpan rhsSp _ <- getLocA lRhs -> do+        InstrumentEnv {instrumentEnvSourceFile} <- ask+        case instrumentEnvSourceFile of+          Just (_, ls) -> do+            let outerSp = combineRealSrcSpans lhsSp rhsSp+                lhsText = textInSpan ls lhsSp+                rhsText = textInSpan ls rhsSp+            pure $+              Just+                OpAppCtx+                  { opAppOuterSpan = outerSp,+                    opAppOpSpan = opSp,+                    opAppLhsText = lhsText,+                    opAppRhsText = rhsText+                  }+          Nothing -> pure Nothing+  _ -> pure Nothing++-- | Extract the source text covered by a single 'RealSrcSpan' from a list+-- of source lines.  Handles multi-line spans by concatenating intermediate+-- lines with a single space, which is enough for the prefix-form preview+-- (operands inside an @OpApp@ are typically single-line).+textInSpan :: [Text] -> RealSrcSpan -> Text+textInSpan allLines rss =+  let startLine = srcSpanStartLine rss+      endLine = srcSpanEndLine rss+      colS = srcSpanStartCol rss+      colE = srcSpanEndCol rss+      lineN i = case drop (i - 1) allLines of+        (l : _) -> l+        [] -> T.empty+   in if startLine == endLine+        then T.take (colE - colS) (T.drop (colS - 1) (lineN startLine))+        else+          let firstPart = T.drop (colS - 1) (lineN startLine)+              middleParts = map lineN [startLine + 1 .. endLine - 1]+              lastPart = T.take (colE - 1) (lineN endLine)+           in T.intercalate " " (firstPart : middleParts ++ [lastPart])++-- | Walk a typechecked @(>>=) rhs (\\pat -> rest)@ application, applying+-- 'DisableMutationsFor' scoping (drawn from @binders@) only to the @rhs@+-- argument.  The continuation lambda body is instrumented normally so its+-- own nested BindStmt expansions can fire.+--+-- Falls back to a normal walk if the expansion does not match the expected+-- shape (which would be a GHC change worth noticing).+instrumentBindExpansion :: [Name] -> HsExpr GhcTc -> InstrM (HsExpr GhcTc)+instrumentBindExpansion binders = \case+  HsApp x1 (L l1 (HsApp x2 bindOp rhs)) lam ->+    HsApp x1+      <$> ( do+              rhs' <- withLocalDisableManyNames binders (instrumentLExpr rhs)+              pure (L l1 (HsApp x2 bindOp rhs'))+          )+      <*> instrumentLExpr lam+  other -> instrumentExpr noSrcSpan other++-- | Variant of 'withLocalDisableMany' that takes 'Name's directly (we+-- already extracted them from a renamed pattern, not a typechecked one).+withLocalDisableManyNames :: [Name] -> InstrM a -> InstrM a+withLocalDisableManyNames names = applyLocalDisables (map getOccString names)++isSpliceHsExpr :: HsExpr GhcRn -> Bool+isSpliceHsExpr = \case+  HsUntypedSplice _ _ -> True+  HsTypedSplice _ _ -> True+  _ -> False++instrumentStmt :: ExprLStmt GhcTc -> InstrM (ExprLStmt GhcTc)+instrumentStmt = traverse $ \case+  LastStmt x e mb se -> LastStmt x <$> instrumentLExpr e <*> pure mb <*> pure se+  -- A 'BindStmt' binds names on the left of @<-@. If any of those names match+  -- a 'DisableMutationsFor' entry, narrow operators for the RHS expression+  -- the same way we do for @let foo = …@ bindings. The bound 'Id's come from+  -- the pattern via 'collectPatBinders' so tuple and constructor patterns+  -- like @(x, y) <- …@ work too.+  -- A 'BindStmt' binds names on the left of @<-@. If any of those names match+  -- a 'DisableMutationsFor' entry, narrow operators for the RHS expression+  -- the same way we do for @let foo = …@ bindings. The bound 'Id's come from+  -- the pattern via 'collectPatBinders' so tuple and constructor patterns+  -- like @(x, y) <- …@ work too.+  --+  -- NB: in GHC 9.10+ the renamer expands @do { p <- e; …rest }@ into+  -- @(>>=) e (\\p -> rest)@ before typechecking, so we usually never get+  -- here — the expanded form lands in 'instrumentExpr' as an+  -- @XExpr (ExpandedThingTc …)@ and is handled there.  This case still+  -- runs for list comprehensions, monad comprehensions, and any flavour+  -- where the typechecker preserves the original 'BindStmt' shape.+  BindStmt x p e -> BindStmt x p <$> withLocalDisableMany (collectPatBinders CollNoDictBinders p) (instrumentLExpr e)+  BodyStmt x e se1 se2 ->+    BodyStmt x+      <$> local (\env -> env {instrumentEnvInGuard = True}) (instrumentLExpr e)+      <*> pure se1+      <*> pure se2+  LetStmt x lbs -> LetStmt x <$> instrumentLocalBinds lbs+  s -> pure s++instrumentTupArg :: HsTupArg GhcTc -> InstrM (HsTupArg GhcTc)+instrumentTupArg = \case+  Present x e -> Present x <$> instrumentLExpr e+  Missing x -> pure (Missing x)++instrumentRecordBinds :: HsRecordBinds GhcTc -> InstrM (HsRecordBinds GhcTc)+instrumentRecordBinds = \case+  HsRecFields flds md ->+    HsRecFields+      <$> mapM (traverse (\(HsFieldBind x l e pun) -> HsFieldBind x l <$> instrumentLExpr e <*> pure pun)) flds+      <*> pure md++-- ---------------------------------------------------------------------------+-- Mutation candidates++-- | Try every operator in turn, accumulating ifMutation wrappers.+--+-- @origExpr@ has uninstrumented children; operators match against it and+-- build their mutant alternatives from it, so mutants stay cheap (see the+-- ordering-invariant note on 'instrumentLExpr').  @fallthroughExpr@ has fully+-- instrumented children and becomes the innermost "original" branch of the+-- ifMutation nesting.+tryMutateWith :: [MutationOperator] -> LHsExpr GhcTc -> LHsExpr GhcTc -> InstrM (LHsExpr GhcTc)+tryMutateWith operators origExpr fallthroughExpr+  -- @ifMutation :: forall (a :: Type). MutationId -> a -> a -> a@ requires the+  -- wrapped expression's type to have kind 'Type' (lifted, boxed).  Every+  -- operator replaces @origExpr@ with a same-typed mutant, so the @ifMutation@+  -- wrapper is instantiated at @origExpr@'s type.  Skip instrumentation entirely+  -- for expressions of unlifted or representation-polymorphic type — e.g. the+  -- @Int#@-typed sub-expressions in Alex/Happy-generated code.  Wrapping one+  -- would build ill-kinded @ifMutation \@Int#@ Core, which Core Lint rejects+  -- (and which, with Core Lint off, miscompiles the site into a runtime crash).+  | not (isLiftedTypeKind (typeKind (lhsExprType origExpr))) = pure fallthroughExpr+  | otherwise =+      foldM (\ft op -> applyOperator origExpr ft op) fallthroughExpr operators++-- | Try one operator.  @origExpr@ is matched and used for mutant construction+-- (uninstrumented children); @fallthrough@ is used as the "original" branch+-- (instrumented children).  See the ordering-invariant note on+-- 'instrumentLExpr' for why this split is necessary.+applyOperator :: LHsExpr GhcTc -> LHsExpr GhcTc -> MutationOperator -> InstrM (LHsExpr GhcTc)+applyOperator origExpr fallthrough op = case operatorKind op of+  -- Function-declaration operators do not fire on expressions; they are applied+  -- to function bindings by 'applyFunctionDeclarationOperators'.+  FunctionDeclarationOperator _ -> pure fallthrough+  ExpressionOperator match -> case match origExpr of+    Nothing -> pure fallthrough+    Just action -> do+      alts <- action+      case alts of+        -- The operator's action chose to produce no alternatives (e.g.+        -- RemoveAction declining to remove an action whose head is on the+        -- 'ignore' list).  This is a deliberate non-candidate, not a+        -- validation failure, so it must be silent.+        [] -> pure fallthrough+        _ -> do+          hscEnv <- liftTcM getTopEnv+          validated <- liftTcM $ filterM (liftIO . validateAlt hscEnv) alts+          case validated of+            [] -> do+              liftTcM $+                liftIO $+                  putStrLn $+                    "mutation: WARNING all replacements dropped for operator "+                      ++ operatorName op+                      ++ locStr (getLocA origExpr)+              pure fallthrough+            (x : xs) -> applyAlts (getLocA origExpr) (operatorName op) (x :| xs) fallthrough++-- | Desugar a mutated expression and accept it only when desugaring is silent.+--+-- Pattern-match warnings are re-enabled on the validation 'HscEnv' so the+-- desugarer's coverage checker ('pmcMatches') runs.  The plugin's driver hook+-- disables 'Opt_WarnIncompletePatterns' and 'Opt_WarnIncompleteUniPatterns'+-- on the host 'DynFlags' (see 'Test.Syd.Mutation.Plugin.plugin') because the+-- @ifMutation@ wrapper confuses the checker for the surrounding module+-- compilation.  Validation, by contrast, desugars an isolated mutated+-- sub-expression with no wrapper around it, so the checker's verdict is+-- reliable here.+--+-- Auto-killing non-exhaustive cases: a 'RemoveCase' mutation that drops the+-- only alternative covering a constructor (e.g. the @_@ wildcard in+-- @case xs of [] -> ...; [_] -> ...; _ -> ...@) leaves the case+-- non-exhaustive.  GHC emits 'DsNonExhaustivePatterns' for such a mutated+-- expression; 'isEmptyMessages' returns 'False'; the mutation is dropped.+-- Any test built with @-Werror=incomplete-patterns@ (or that exercises the+-- runtime @MatchFail@) would kill the mutant anyway, so producing it would+-- just add noise to the manifest.+validateAlt :: HscEnv -> MutationAlt -> IO Bool+validateAlt hscEnv MutationAlt {mutAltExpr = mutated} = do+  let dflags' =+        foldl+          wopt_set+          (hsc_dflags hscEnv)+          [ Opt_WarnIncompletePatterns,+            Opt_WarnIncompleteUniPatterns,+            Opt_WarnOverlappingPatterns+          ]+      hscEnv' = hscEnv {hsc_dflags = dflags'}+  (msgs, mcore) <- deSugarExpr hscEnv' mutated+  pure (isEmptyMessages msgs && isJust mcore)++locStr :: SrcSpan -> String+locStr = \case+  RealSrcSpan rss _ ->+    " at " ++ show (srcSpanStartLine rss) ++ ":" ++ show (srcSpanStartCol rss)+  UnhelpfulSpan _ -> ""++-- | True when the outer span fully contains the inner span (inclusive on+-- both ends).  Compares by (line, col) ordering so multi-line splices are+-- handled correctly.+containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool+containsSpan outer inner =+  startsAfter && endsBefore+  where+    outerStart = (srcSpanStartLine outer, srcSpanStartCol outer)+    outerEnd = (srcSpanEndLine outer, srcSpanEndCol outer)+    innerStart = (srcSpanStartLine inner, srcSpanStartCol inner)+    innerEnd = (srcSpanEndLine inner, srcSpanEndCol inner)+    startsAfter = outerStart <= innerStart+    endsBefore = innerEnd <= outerEnd++-- Nest alternatives as: ifMutation id1 mut1 (ifMutation id2 mut2 original)+--+-- The 1-based @altIndex@ is the sole disambiguator of alternatives an operator+-- emits at the same span: it is the last component of the 'MutationId', which is+-- otherwise just the module, operator and span.  (The replacement text is NOT in+-- the id, because it can contain @'/'@, the id's part separator, so the index+-- alone must keep e.g. ListLit's drop-first and drop-last on a 3-element list,+-- or SwitchFunctionArguments' several swaps at one call, from colliding.)+applyAlts :: SrcSpan -> String -> NonEmpty MutationAlt -> LHsExpr GhcTc -> InstrM (LHsExpr GhcTc)+applyAlts matchedSpan opName alts original = do+  (wrapped, records) <- go 1 alts+  -- Every applyAlts call emits exactly one mutation group, even if a+  -- specific alternative was filtered out (TH splice / UnhelpfulSpan) and+  -- produced no record.  An empty group is harmless: no scheduling work, no+  -- report entries.+  tell [MutationGroup records]+  -- Count the real mutations just emitted towards the control cadence, then+  -- (when due) insert a control no-op wrapping this site.  The matched+  -- expression's type is reused as the @ifMutation@ type - it is the same+  -- type the operator already wrapped its alternatives with, so it is always+  -- a valid @ifMutation@ type and no extra checking is needed.+  bumpSinceControl (length records)+  maybeInsertControl matchedSpan (mutAltType (NE.head alts)) wrapped+  where+    go altIndex (alt :| rest) = do+      (mid, mRec) <- recordMutation original opName alt altIndex+      (innerExpr, innerRecs) <- case rest of+        [] -> pure (original, [])+        (a : as) -> go (altIndex + 1) (a :| as)+      outer <- wrapWithIfMutation (mutAltType alt) mid (mutAltExpr alt) innerExpr+      let recs = maybe innerRecs (: innerRecs) mRec+      pure (outer, recs)++-- | Add @n@ real mutations to the running count since the last control.+bumpSinceControl :: Int -> InstrM ()+bumpSinceControl n = modify' (\s -> s {instrSinceControl = instrSinceControl s + n})++-- | When the control cadence is due (at least 'controlInterval' real mutations+-- recorded since the last control), insert a control (no-op) mutation wrapping+-- @site@ at @matchedSpan@: an @ifMutation cmid e e@ with the same expression on+-- both branches, recorded as a non-diff with the reserved 'controlOperatorName'.+--+-- A control changes no behaviour, so it is expected to survive; if it does not,+-- the mutation testing is unsound.  Returns @site@ unchanged when the cadence is+-- not due, or when the span cannot anchor a record (a TH splice or+-- 'UnhelpfulSpan'); in the latter case the counter is left high so the next+-- usable site picks it up.+maybeInsertControl :: SrcSpan -> Type -> LHsExpr GhcTc -> InstrM (LHsExpr GhcTc)+maybeInsertControl matchedSpan ty site = do+  count <- gets instrSinceControl+  if count < controlInterval+    then pure site+    else do+      seqno <- gets instrControlSeq+      (cmid, mRec) <-+        recordMutationAt matchedSpan (T.unpack controlOperatorName) "no-op" "no-op" NoDelta Nothing seqno+      case mRec of+        Nothing -> pure site+        Just rec -> do+          modify'+            ( \s ->+                s+                  { instrSinceControl = instrSinceControl s - controlInterval,+                    instrControlSeq = instrControlSeq s + 1+                  }+            )+          tell [MutationGroup [rec]]+          wrapWithNoOpControl ty cmid site++-- | Wrap @e@ as a control no-op: @(\\ctrl -> ifMutation cmid ctrl ctrl) e@.+--+-- The single-argument lambda shares @e@ across both @ifMutation@ branches, so+-- the (potentially large, mutation-laden) subtree is not duplicated - which+-- would reintroduce the O(N*K) AST blow-up the expression walker is careful to+-- avoid.  Both branches are the same bound variable, so this is a genuine+-- non-diff: @ifMutation@ returns @ctrl@ whether or not the control is active,+-- and the lambda is lazy in its argument, so evaluation is unchanged.+wrapWithNoOpControl :: Type -> MutationId -> LHsExpr GhcTc -> InstrM (LHsExpr GhcTc)+wrapWithNoOpControl ty cmid e = do+  uniq <- liftTcM newUnique+  let ctrlId = mkSysLocal (mkFastString "ctrl") uniq manyDataConTy ty+      ctrlVar = nlHsVar ctrlId+  body <- wrapWithIfMutation ty cmid ctrlVar ctrlVar+  let pat = noLocA (VarPat NoExtField (noLocA ctrlId))+      grhs = noLocA (GRHS noAnn [] body)+      grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds NoExtField)+      match = noLocA (Match [] (LamAlt LamSingle) [pat] grhss)+      mgtc =+        MatchGroupTc+          { mg_arg_tys = [Scaled manyDataConTy ty],+            mg_res_ty = ty,+            mg_origin = Generated OtherExpansion SkipPmc+          }+      mg = MG mgtc (noLocA [match])+      lam = noLocA (HsLam [] LamSingle mg)+  pure (mkHsApp lam e)++-- | Record one mutation site, returning its 'MutationId' and (when the+-- mutation is kept) the corresponding 'MutationRecord'.  Returns+-- @(MutationId [], Nothing)@ when the mutation is filtered out (TH splice or+-- 'UnhelpfulSpan'); callers should treat the empty 'MutationId' as inert.+recordMutation ::+  LHsExpr GhcTc ->+  String ->+  MutationAlt ->+  -- | 1-based index of this alternative within the operator's match.+  -- Appended to the id so alternatives with identical @replStr@ text do not+  -- collide.+  Int ->+  InstrM (MutationId, Maybe MutationRecord)+recordMutation le op MutationAlt {mutAltOriginal = origStr, mutAltReplacement = replStr, mutAltDelta = delta, mutAltMitigation = mitigation} altIndex =+  recordMutationAt (getLocA le) op origStr replStr delta mitigation altIndex++-- | The core of 'recordMutation', taking the mutation's source span and+-- description directly rather than via an 'LHsExpr' \/ 'MutationAlt'.  Used by+-- both the expression-level operator path ('recordMutation') and the+-- binding-level RemoveClause operator, which has no 'LHsExpr' to point at.+recordMutationAt ::+  SrcSpan ->+  String ->+  -- | Human-readable description of the original code, for the manifest.+  String ->+  -- | Human-readable description of the replacement, for the manifest.+  String ->+  SrcSpanDelta ->+  -- | Optional mitigation hint.+  Maybe Text ->+  -- | 1-based index of this alternative within the operator's match.+  Int ->+  InstrM (MutationId, Maybe MutationRecord)+recordMutationAt sp op origStr replStr delta mitigation altIndex = do+  InstrumentEnv {instrumentEnvModule, instrumentEnvSourceFile, instrumentEnvSkipThSplices, instrumentEnvSpliceSpans, instrumentEnvCurrentBinding} <- ask+  case sp of+    RealSrcSpan rss _+      | instrumentEnvSkipThSplices && any (`containsSpan` rss) instrumentEnvSpliceSpans ->+          -- Mutation is inside a TH splice or quasi-quote; drop it.+          pure (MutationId [], Nothing)+    RealSrcSpan rss _ -> do+      let mn = moduleNameString (moduleName instrumentEnvModule)+          lineNum = srcSpanStartLine rss+          colStart = srcSpanStartCol rss+          colEnd = srcSpanEndCol rss+          -- The id is a structural key: module, operator, span, and the+          -- alternative's index.  It must NOT embed source text (the+          -- replacement string), because a 'MutationId' renders and parses as+          -- @'/'@-separated parts (see 'Test.Syd.Mutation.Runtime'): a replStr+          -- such as @t' "/nix/store/"@ contains a @'/'@, which would make the+          -- id un-round-trippable through @MUTATION_ACTIVE@: the runtime would+          -- parse it into different parts than the compiled @ifMutation@ carries+          -- and so never activate the mutation (it would survive uncovered-+          -- style despite a killing test).  The index already disambiguates+          -- alternatives at the same span, so replStr is not needed for+          -- uniqueness; it lives in the manifest's 'mutRecReplacement' field.+          mid =+            MutationId+              [ mn,+                op,+                show lineNum,+                show colStart,+                show colEnd,+                show altIndex+              ]+          lineNumEnd = srcSpanEndLine rss+          -- The diff (source_lines / mutated_lines / context) covers the+          -- "display span": the matched expression's span normally, but+          -- widened to the outer span when the operator emitted a+          -- 'ReplaceOuterSpan'.  Keeping the diff aligned on the same span+          -- on both sides means it always parses as a single contiguous+          -- edit, never as "narrow original text vs wider mutated text".+          (displayStartLine, displayEndLine, displayColS, displayColE) =+            case delta of+              ReplaceOuterSpan outerRss _ ->+                ( srcSpanStartLine outerRss,+                  srcSpanEndLine outerRss,+                  srcSpanStartCol outerRss,+                  srcSpanEndCol outerRss+                )+              _ -> (lineNum, lineNumEnd, colStart, colEnd)+          (mSrcFile, ctxBefore, ctxAfter, spanLines, mutatedLines) =+            case instrumentEnvSourceFile of+              Nothing -> (Nothing, [], [], [], [])+              Just (relFile, ls) ->+                let startIdx = displayStartLine - 1+                    endIdx = displayEndLine - 1+                    before = reverse $ take 3 $ reverse $ take startIdx ls+                    after = take 3 $ drop (endIdx + 1) ls+                    srcSpanLines = [line | (i, line) <- zip [0 :: Int ..] ls, i >= startIdx, i <= endIdx]+                    mutLines = applyDelta ls displayStartLine displayEndLine displayColS displayColE delta srcSpanLines+                 in (Just relFile, before, after, srcSpanLines, mutLines)+      let record =+            MutationRecord+              { mutRecId = mid,+                mutRecOperator = T.pack op,+                mutRecOriginal = T.pack origStr,+                mutRecReplacement = T.pack replStr,+                mutRecModule = T.pack mn,+                mutRecLine = fromIntegral lineNum,+                mutRecEndLine = fromIntegral lineNumEnd,+                mutRecColStart = fromIntegral colStart,+                mutRecColEnd = fromIntegral colEnd,+                mutRecSourceFile = mSrcFile,+                mutRecSourceLines = spanLines,+                mutRecMutatedLines = mutatedLines,+                mutRecContextBefore = ctxBefore,+                mutRecContextAfter = ctxAfter,+                mutRecCoveringTests = Nothing,+                mutRecBinding = T.pack <$> instrumentEnvCurrentBinding,+                mutRecMitigation = mitigation+              }+      liftTcM $+        liftIO $ do+          let MutationId parts = mutRecId record+          case parts of+            (modName : _op : lineStr : colStartStr : colEndStr : _) ->+              let filePath = case mutRecSourceFile record of+                    Just p -> fromRelFile p+                    Nothing -> map (\c -> if c == '.' then '/' else c) modName ++ ".hs"+                  variantSuffix = case parts of+                    [_, _, _, _, _, altIdx] -> " #" ++ altIdx+                    _ -> ""+               in putStrLn $ "added mutation " ++ T.unpack (mutRecOperator record) ++ " at " ++ filePath ++ ":" ++ lineStr ++ ":" ++ colStartStr ++ "-" ++ colEndStr ++ variantSuffix+            _ -> putStrLn $ "added mutation " ++ show parts+      pure (mid, Just record)+    UnhelpfulSpan _ -> pure (MutationId [], Nothing)++-- | Apply a 'SrcSpanDelta' to compute the mutated lines.+applyDelta :: [Text] -> Int -> Int -> Int -> Int -> SrcSpanDelta -> [Text] -> [Text]+applyDelta allLines outerStart outerEnd colS colE delta spanLines = case delta of+  TokenReplace newText -> applyTokenReplace colS colE newText spanLines+  TokenReplaceAt subSpan newText ->+    applyTokenReplaceAt outerStart subSpan newText spanLines+  SpanRemoval rmSpans -> applySpanRemoval allLines outerStart outerEnd rmSpans+  PrependText prefix -> applyPrependText colS prefix spanLines+  WrapWithText prefix suffix -> applyWrapWithText colS colE prefix suffix spanLines+  -- 'ReplaceOuterSpan' has already widened the display span at the+  -- 'recordMutation' level, so by the time we are here the @colS@..@colE@+  -- bounds already cover the outer span and 'applyTokenReplace' does the+  -- right thing.+  ReplaceOuterSpan _ newText -> applyTokenReplace colS colE newText spanLines+  SwapSpans spanX spanY ->+    applySwapSpans allLines outerStart outerEnd colS colE spanX spanY+  -- A control (no-op) mutation makes no change, so the mutated lines are the+  -- source lines unchanged.+  NoDelta -> spanLines++-- | Render the matched expression's display span (@outerStart@..@outerEnd@,+-- columns @colS@..@colE@) with the source text at two sub-spans swapped, and+-- everything else left intact.+--+-- The two sub-spans must lie within the display span and must not overlap.+-- Like 'applyTokenReplace', a multi-line result is collapsed onto a single+-- line (intermediate lines joined with single spaces), which is enough for+-- the manifest preview.  Out-of-range line/column references resolve to+-- empty text rather than crashing, matching 'applySpanRemoval'.+applySwapSpans :: [Text] -> Int -> Int -> Int -> Int -> RealSrcSpan -> RealSrcSpan -> [Text]+applySwapSpans allLines outerStart outerEnd colS colE spanX spanY =+  let (spanA, spanB) = orderSpans spanX spanY+      lineAt n = case drop (n - 1) allLines of+        (l : _) -> l+        [] -> T.empty+      slice (l1, c1) (l2, c2)+        | l1 == l2 = T.take (c2 - c1) (T.drop (c1 - 1) (lineAt l1))+        | otherwise =+            let firstPart = T.drop (c1 - 1) (lineAt l1)+                middleParts = map lineAt [l1 + 1 .. l2 - 1]+                lastPart = T.take (c2 - 1) (lineAt l2)+             in T.intercalate " " (firstPart : middleParts ++ [lastPart])+      aStart = (srcSpanStartLine spanA, srcSpanStartCol spanA)+      aEnd = (srcSpanEndLine spanA, srcSpanEndCol spanA)+      bStart = (srcSpanStartLine spanB, srcSpanStartCol spanB)+      bEnd = (srcSpanEndLine spanB, srcSpanEndCol spanB)+      -- Everything before the matched expression on its first line, and+      -- everything after it on its last line, is preserved verbatim.+      linePrefix = T.take (colS - 1) (lineAt outerStart)+      lineSuffix = T.drop (colE - 1) (lineAt outerEnd)+      -- Text from the matched expression's start up to the earlier span,+      -- the gap between the spans, and the tail after the later span.+      prefix = slice (outerStart, colS) aStart+      midText = slice aEnd bStart+      suffix = slice bEnd (outerEnd, colE)+      aText = slice aStart aEnd+      bText = slice bStart bEnd+   in [linePrefix <> prefix <> bText <> midText <> aText <> suffix <> lineSuffix]++-- | Order two spans so the first one starts no later than the second.+orderSpans :: RealSrcSpan -> RealSrcSpan -> (RealSrcSpan, RealSrcSpan)+orderSpans s1 s2 =+  if (srcSpanStartLine s1, srcSpanStartCol s1) <= (srcSpanStartLine s2, srcSpanStartCol s2)+    then (s1, s2)+    else (s2, s1)++-- | Wrap the matched span text with @prefix@ before and @suffix@ after.+-- For multi-line spans only the prefix lands on the first line and the+-- suffix on the last line; everything in between is unchanged.+applyWrapWithText :: Int -> Int -> Text -> Text -> [Text] -> [Text]+applyWrapWithText _ _ _ _ [] = []+applyWrapWithText colS colE prefix suffix [line] =+  let before = T.take (colS - 1) line+      middle = T.drop (colS - 1) (T.take (colE - 1) line)+      after = T.drop (colE - 1) line+   in [before <> prefix <> middle <> suffix <> after]+applyWrapWithText colS colE prefix suffix (firstLine : rest) =+  let beforeF = T.take (colS - 1) firstLine+      restOfF = T.drop (colS - 1) firstLine+      firstLine' = beforeF <> prefix <> restOfF+      (middle, lastLine) = case reverse rest of+        l : ms -> (reverse ms, l)+        [] -> ([], T.empty)+      beforeL = T.take (colE - 1) lastLine+      afterL = T.drop (colE - 1) lastLine+      lastLine' = beforeL <> suffix <> afterL+   in firstLine' : middle ++ [lastLine']++-- | Replace text at the columns covered by @subSpan@, relative to the outer+-- expression's span (whose first line is @outerStart@). Only single-line+-- sub-spans are handled — multi-line operator tokens don't occur in practice.+applyTokenReplaceAt :: Int -> RealSrcSpan -> Text -> [Text] -> [Text]+applyTokenReplaceAt outerStart subSpan newText spanLines =+  let subLine = srcSpanStartLine subSpan+      idx = subLine - outerStart+   in case splitAt idx spanLines of+        (before, line : after) ->+          let line' = applySingleLineReplace (srcSpanStartCol subSpan) (srcSpanEndCol subSpan) newText line+           in before ++ line' : after+        _ -> spanLines++applySingleLineReplace :: Int -> Int -> Text -> Text -> Text+applySingleLineReplace colS colE newText line =+  T.take (colS - 1) line <> newText <> T.drop (colE - 1) line++-- | Replace text at columns colS..colE on the first line of the span.+-- GHC colEnd is exclusive (one past the last character), so T.drop (colE-1) is correct.+--+-- Multi-line spans collapse to a single line: the prefix of the first line+-- (columns 1..colS-1), then the replacement text, then the suffix of the+-- last line (columns colE.. onwards).  Intermediate lines are dropped.  This+-- matters for operators that replace whole multi-line expressions with a+-- short token — e.g. @FunctionToEmptyList@ on @execWriter $ do { ... }@.+applyTokenReplace :: Int -> Int -> Text -> [Text] -> [Text]+applyTokenReplace colS colE newText lns = case NE.nonEmpty lns of+  Nothing -> []+  Just ne ->+    let before = T.take (colS - 1) (NE.head ne)+        after = T.drop (colE - 1) (NE.last ne)+     in [before <> newText <> after]++-- | Remove lines belonging to any of the given spans from the outer span's line range.+--+-- Lines outside the range @[1 .. length allLines]@ are silently dropped: this+-- happens when GHC source spans refer to a preprocessor-generated source+-- (e.g. via @-pgmF sydtest-discover@) while @allLines@ is the original+-- on-disk @.hs@ file, which is shorter.+applySpanRemoval :: [Text] -> Int -> Int -> [RealSrcSpan] -> [Text]+applySpanRemoval allLines outerStart outerEnd rmSpans =+  let removed = Set.fromList [l | rss <- rmSpans, l <- [srcSpanStartLine rss .. srcSpanEndLine rss]]+   in [ line+      | (i, line) <- zip [1 ..] allLines,+        i >= outerStart,+        i <= outerEnd,+        Set.notMember i removed+      ]++-- | Prepend text at the column position of the start of the span.+applyPrependText :: Int -> Text -> [Text] -> [Text]+applyPrependText _ _ [] = []+applyPrependText colS prefix (line : rest) =+  let (before, after) = T.splitAt (colS - 1) line+   in (before <> prefix <> after) : rest++-- ---------------------------------------------------------------------------+-- Building the ifMutation call++-- | Wrap as:  ifMutation @ty mutId mutated original+--+-- > ifMutation :: forall a. MutationId -> a -> a -> a+wrapWithIfMutation ::+  Type ->+  MutationId ->+  LHsExpr GhcTc ->+  LHsExpr GhcTc ->+  InstrM (LHsExpr GhcTc)+wrapWithIfMutation ty mid mutatedExpr origExpr = do+  InstrumentEnv {instrumentEnvIfMutationId, instrumentEnvMutationIdCon} <- ask+  midExpr <- liftTcM $ buildMutationIdExpr instrumentEnvMutationIdCon mid+  let ifMutVar = nlHsTyApp instrumentEnvIfMutationId [ty]+      call = mkHsApp (mkHsApp (mkHsApp ifMutVar midExpr) mutatedExpr) origExpr+  pure call++-- | Build a 'MutationId' expression from a list of strings.+--+-- > MutationId ["module", "op", ...]+buildMutationIdExpr :: DataCon -> MutationId -> TcM (LHsExpr GhcTc)+buildMutationIdExpr con (MutationId parts) = do+  let strExprs = map mkHsStringExpr parts+      listExpr = noLocA (ExplicitList (mkListTy charTy) strExprs)+      conExpr = nlHsDataCon con+  pure (mkHsApp conExpr listExpr)++-- | Build a string literal expression of type 'String' (= '[Char]').+mkHsStringExpr :: String -> LHsExpr GhcTc+mkHsStringExpr s =+  noLocA (HsLit NoExtField (HsString NoSourceText (mkFastString s)))
+ src/Test/Syd/Mutation/Plugin/Operator/Arith.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE NamedFieldPuns #-}++module Test.Syd.Mutation.Plugin.Operator.Arith (theOperator) where++import Control.Monad.Reader (ask)+import qualified Data.Text as T+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..), liftTcM)+import Test.Syd.Mutation.Plugin.Operator.Util (TcOpApp (..), matchTcOpApp, mkOpReplacement)++theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "Arith",+      operatorDescription = "Replace any binary arithmetic operator with every other arithmetic operator",+      operatorKind = ExpressionOperator $ \le -> case matchTcOpApp le of+        Just tcOp@(TcOpApp {tcOpAppOcc = occ})+          | occ `elem` arithOps ->+              Just (action tcOp)+        _ -> Nothing+    }++-- | The arithmetic operators we mutate between.+--+-- @(/)@ is intentionally excluded: it requires a @Fractional@ instance, so+-- substituting it for @(+)@ on, say, an @Int@ produces an ill-typed Core+-- term. Even when the typechecker happens to accept the substitution because+-- of how the plugin reuses the surrounding type and dictionary arguments,+-- the runtime behaviour is unpredictable (the dictionary is still the+-- original @Num@ dictionary, not the @Fractional@ one @(/)@ expects).+--+-- This means @Fractional@-typed expressions will not currently produce a+-- @\"/\"@ mutation. If we want @\"/\"@ as a mutation in the future, the+-- operator needs to check that the operand type is @Fractional@ and also+-- swap in the appropriate dictionary, which is not straightforward at the+-- typechecked AST level.+arithOps :: [String]+arithOps = ["+", "-", "*"]++action ::+  TcOpApp ->+  InstrM [MutationAlt]+action TcOpApp {tcOpAppTy, tcOpAppLhs, tcOpAppOp, tcOpAppRhs, tcOpAppOcc, tcOpAppOpSrcSpan} = do+  InstrumentEnv {instrumentEnvRdrEnv} <- ask+  let replacements = filter (/= tcOpAppOcc) arithOps+      delta replOcc = case tcOpAppOpSrcSpan of+        Just rss -> TokenReplaceAt rss (T.pack replOcc)+        Nothing -> TokenReplace (T.pack replOcc)+  mapM+    ( \replOcc -> do+        repl <- liftTcM $ mkOpReplacement instrumentEnvRdrEnv tcOpAppLhs tcOpAppOp tcOpAppRhs replOcc+        pure+          MutationAlt+            { mutAltType = tcOpAppTy,+              mutAltExpr = repl,+              mutAltOriginal = tcOpAppOcc,+              mutAltReplacement = replOcc,+              mutAltDelta = delta replOcc,+              mutAltMitigation = Nothing+            }+    )+    replacements
+ src/Test/Syd/Mutation/Plugin/Operator/BoolLit.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE LambdaCase #-}++module Test.Syd.Mutation.Plugin.Operator.BoolLit (theOperator) where++import qualified Data.Text as T+import GHC+import GHC.Builtin.Types (boolTy, falseDataCon, trueDataCon)+import GHC.Types.Name (getOccString)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))++theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "BoolLit",+      operatorDescription = "Replace a boolean literal with its negation",+      operatorKind = ExpressionOperator $ fmap action . extractBoolLit+    }++-- | Extract the OccName of a boolean literal, unwrapping HsWrap and+-- ConLikeTc nodes that GHC inserts after type-checking.+extractBoolLit :: LHsExpr GhcTc -> Maybe String+extractBoolLit = \case+  L _ (HsVar _ (L _ v))+    | occ <- getOccString v, occ `elem` boolLits -> Just occ+  L _ (XExpr (ConLikeTc con _ _))+    | occ <- getOccString con, occ `elem` boolLits -> Just occ+  L _ (XExpr (WrapExpr (HsWrap _ e))) -> extractBoolLit (noLocA e)+  _ -> Nothing++boolLits :: [String]+boolLits = ["True", "False"]++action ::+  String ->+  InstrM [MutationAlt]+action origOcc =+  let repl = if origOcc == "True" then falseDataCon else trueDataCon+      replOcc = if origOcc == "True" then "False" else "True"+      replExpr = nlHsDataCon repl+   in pure+        [ MutationAlt+            { mutAltType = boolTy,+              mutAltExpr = replExpr,+              mutAltOriginal = origOcc,+              mutAltReplacement = replOcc,+              mutAltDelta = TokenReplace (T.pack replOcc),+              mutAltMitigation = Nothing+            }+        ]
+ src/Test/Syd/Mutation/Plugin/Operator/Cmp.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE NamedFieldPuns #-}++module Test.Syd.Mutation.Plugin.Operator.Cmp (theOperator) where++import Control.Monad.Reader (ask)+import qualified Data.Text as T+import GHC.Builtin.Types (boolTy)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..), liftTcM)+import Test.Syd.Mutation.Plugin.Operator.Util (TcOpApp (..), matchTcOpApp, mkOpReplacement)++theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "Cmp",+      operatorDescription = "Replace a comparison operator with another in the same class",+      operatorKind = ExpressionOperator $ \le -> case matchTcOpApp le of+        Just tcOp@(TcOpApp {tcOpAppOcc = occ})+          | not (null (replacementsFor occ)) ->+              Just (action tcOp (replacementsFor occ))+        _ -> Nothing+    }++-- | Mutation substitutions are restricted to the 'Ord' operators+-- (@<@, @<=@, @>@, @>=@), which all use an 'Ord' dictionary and so can be+-- substituted for each other while preserving the original dictionary+-- argument.+--+-- @==@/@/=@ are excluded for two reasons:+--+--   1. Crossing into the 'Ord' class would call an 'Ord' method through an+--      'Eq' dictionary (or vice versa), which crashes GHC's code generator+--      (@Prelude.!!: index too large@) at best and produces undefined+--      behaviour at worst.+--   2. Within 'Eq' itself, substituting @==@ for @/=@ on primitive types+--      like 'Int' does not actually change the runtime behaviour. The+--      class-method selector is resolved to the instance method ('eqInt' or+--      'neInt') during desugaring in a way that the post-typecheck @HsVar@+--      substitution does not influence. The mutation fires and the manifest+--      records it, but the test would not be able to distinguish the+--      original from the mutant. See task follow-up for a proper fix.+ordOps :: [String]+ordOps = ["<", "<=", ">", ">="]++-- | Operators that should be considered as alternatives for @occ@: those in+-- the same class, minus @occ@ itself. Returns @[]@ if @occ@ is not a known+-- comparison operator.+replacementsFor :: String -> [String]+replacementsFor occ+  | occ `elem` ordOps = filter (/= occ) ordOps+  | otherwise = []++action ::+  TcOpApp ->+  [String] ->+  InstrM [MutationAlt]+action TcOpApp {tcOpAppLhs, tcOpAppOp, tcOpAppRhs, tcOpAppOcc, tcOpAppOpSrcSpan} replacements = do+  InstrumentEnv {instrumentEnvRdrEnv} <- ask+  let delta replOcc = case tcOpAppOpSrcSpan of+        Just rss -> TokenReplaceAt rss (T.pack replOcc)+        Nothing -> TokenReplace (T.pack replOcc)+  mapM+    ( \replOcc -> do+        repl <- liftTcM $ mkOpReplacement instrumentEnvRdrEnv tcOpAppLhs tcOpAppOp tcOpAppRhs replOcc+        pure+          MutationAlt+            { mutAltType = boolTy,+              mutAltExpr = repl,+              mutAltOriginal = tcOpAppOcc,+              mutAltReplacement = replOcc,+              mutAltDelta = delta replOcc,+              mutAltMitigation = Nothing+            }+    )+    replacements
+ src/Test/Syd/Mutation/Plugin/Operator/ConstBool.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Plugin.Operator.ConstBool (theOperator) where++import Control.Monad.Reader (ask)+import qualified Data.Text as T+import GHC+import GHC.Builtin.Types (boolTyCon, falseDataCon, trueDataCon)+import GHC.Types.Name (getOccString)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), OpAppCtx (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (ConstFnMatch (..), arrowTy, mkConstLambda, prefixFormPreview, viewConstFnResult)++-- | Replace an expression whose type is @arg1 -> ... -> argN -> Bool@+-- (with @N >= 0@) with the constant function returning 'True' or 'False'.+--+--   * At arity 0, the mutants are bare @True@ and @False@.+--   * At arity N \>= 1, they are @\\_ ... _ -> True@ and+--     @\\_ ... _ -> False@ (typed at GhcTc via 'mkConstLambda').+--+-- Skips bare boolean literals 'True', 'False', and 'otherwise' at arity 0,+-- so the mutant set is disjoint from the original.  Inside a guard+-- expression (a 'BodyStmt' in a 'GRHS') the @False@ alternative is dropped:+-- mutating every guard to 'False' produces non-exhaustive matches that+-- throw an uncatchable 'MatchFail' at runtime.+theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "ConstBool",+      operatorDescription = "Replace a Bool-typed expression (or a function returning Bool) with a constant True or False",+      operatorKind = ExpressionOperator $ \le ->+        case viewConstFnResult 0 boolTyCon le of+          Just m+            | not (isArity0BoolLit m le) -> Just (action le m)+          _ -> Nothing+    }++-- | At arity 0, skip @True@, @False@, and @otherwise@.  Arity \>= 1 has no+-- such notion of "literal" — bare 'not' or '(&&)' are honest mutation+-- targets.+isArity0BoolLit :: ConstFnMatch -> LHsExpr GhcTc -> Bool+isArity0BoolLit ConstFnMatch {cfnArgTys} le = case cfnArgTys of+  [] -> isBoolLit le+  _ -> False++-- | Returns True for boolean literals and 'otherwise' (which equals True),+-- unwrapping HsWrap and ConLikeTc nodes that GHC inserts after type-checking.+isBoolLit :: LHsExpr GhcTc -> Bool+isBoolLit = \case+  L _ (HsVar _ (L _ v)) -> getOccString v `elem` ["True", "False", "otherwise"]+  L _ (XExpr (ConLikeTc con _ _)) -> getOccString con `elem` ["True", "False"]+  L _ (XExpr (WrapExpr (HsWrap _ e))) -> isBoolLit (noLocA e)+  _ -> False++action ::+  LHsExpr GhcTc ->+  ConstFnMatch ->+  InstrM [MutationAlt]+action le ConstFnMatch {cfnArgTys, cfnResTy} = do+  InstrumentEnv {instrumentEnvInGuard, instrumentEnvOpAppCtx, instrumentEnvAppDepth} <- ask+  let arity = length cfnArgTys+  -- See 'ConstNothing' for the dominance rule.+  if arity >= 1 && instrumentEnvAppDepth >= arity+    then pure []+    else+      let wholeTy = arrowTy cfnArgTys cfnResTy+          atOpToken = case (arity, instrumentEnvOpAppCtx, getLocA le) of+            (n, Just ctx, RealSrcSpan mSp _) | n >= 1, mSp == opAppOpSpan ctx -> Just ctx+            _ -> Nothing+          mkAlt boolCon boolName =+            let v = nlHsDataCon boolCon+                mutated = mkConstLambda cfnArgTys cfnResTy v+                delta = case atOpToken of+                  Just ctx ->+                    ReplaceOuterSpan+                      (opAppOuterSpan ctx)+                      (prefixFormPreview arity (T.pack boolName) (opAppLhsText ctx) (opAppRhsText ctx))+                  Nothing ->+                    let tokenText = case cfnArgTys of+                          [] -> T.pack boolName+                          _ ->+                            "(\\"+                              <> T.replicate arity "_ "+                              <> "-> "+                              <> T.pack boolName+                              <> ")"+                     in TokenReplace tokenText+                (origLabel, replLabel) = case cfnArgTys of+                  [] -> ("e", boolName)+                  _ -> ("f", "\\" ++ unwords (replicate arity "_") ++ " -> " ++ boolName)+             in MutationAlt+                  { mutAltType = wholeTy,+                    mutAltExpr = mutated,+                    mutAltOriginal = origLabel,+                    mutAltReplacement = replLabel,+                    mutAltDelta = delta,+                    mutAltMitigation = Nothing+                  }+          trueAlt = mkAlt trueDataCon "True"+          falseAlt = mkAlt falseDataCon "False"+          -- The guard carveout applies only at arity 0; a Bool-typed lambda is+          -- never itself the body of a 'BodyStmt' guard.+          dropFalse = instrumentEnvInGuard && null cfnArgTys+       in pure $ if dropFalse then [trueAlt] else [trueAlt, falseAlt]
+ src/Test/Syd/Mutation/Plugin/Operator/ConstEmptyList.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Plugin.Operator.ConstEmptyList (theOperator) where++import Control.Monad.Reader (asks)+import qualified Data.Map as Map+import qualified Data.Text as T+import GHC+import GHC.Builtin.Types (charTyCon, listTyCon)+import GHC.Core.Type (tyConAppTyCon_maybe)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), OpAppCtx (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (ConstFnMatch (..), arrowTy, mkConstLambda, prefixFormPreview, unwrapWrap, viewConstFnResult)+import Test.Syd.Mutation.Plugin.OptParse (OperatorConfig (..), operatorExtraFlag)++-- | Replace an expression whose type is @arg1 -> ... -> argN -> [a]@+-- (with @N >= 0@) with the constant function returning @[]@.+--+-- Same shape and rationale as 'ConstNothing'; see that module's haddock.+-- Complements 'ListLit', which targets the syntactic 'ExplicitList' form.+theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "ConstEmptyList",+      operatorDescription = "Replace a list-typed expression (or a function returning a list) with a constant []",+      operatorKind = ExpressionOperator $ \le ->+        case viewConstFnResult 0 listTyCon le of+          Just m@ConstFnMatch {cfnTyConArgs = [elTy]} -> Just (action le elTy m)+          _ -> Nothing+    }++action ::+  LHsExpr GhcTc ->+  Type ->+  ConstFnMatch ->+  InstrM [MutationAlt]+action le elTy ConstFnMatch {cfnArgTys, cfnResTy} = do+  opAppCtx <- asks instrumentEnvOpAppCtx+  appDepth <- asks instrumentEnvAppDepth+  -- This operator interprets its own config entry's extra keys.+  opsConfig <- asks instrumentEnvOperatorsConfig+  let extra = maybe Map.empty operatorConfigExtra (Map.lookup "ConstEmptyList" opsConfig)+      skipStrings = operatorExtraFlag "skip-strings" extra+      skipLiteralStrings = operatorExtraFlag "skip-literal-strings" extra+      arity = length cfnArgTys+      -- 'skip-strings' drops every @[Char]@-typed expression; the narrower+      -- 'skip-literal-strings' drops only syntactic string literals.+      skippedAsString =+        (skipStrings && isCharElemTy elTy)+          || (skipLiteralStrings && isCharElemTy elTy && isStringLiteralExpr le)+  -- See 'ConstNothing' for the dominance rule.+  if (arity >= 1 && appDepth >= arity) || skippedAsString+    then pure []+    else+      let emptyExpr = noLocA (ExplicitList elTy [])+          wholeTy = arrowTy cfnArgTys cfnResTy+          mutated = mkConstLambda cfnArgTys cfnResTy emptyExpr+          atOpToken = case (arity, opAppCtx, getLocA le) of+            (n, Just ctx, RealSrcSpan mSp _) | n >= 1, mSp == opAppOpSpan ctx -> Just ctx+            _ -> Nothing+          delta = case atOpToken of+            Just ctx ->+              ReplaceOuterSpan+                (opAppOuterSpan ctx)+                (prefixFormPreview arity "[]" (opAppLhsText ctx) (opAppRhsText ctx))+            Nothing ->+              let tokenText = case cfnArgTys of+                    [] -> "[]"+                    _ ->+                      "(\\"+                        <> T.replicate arity "_ "+                        <> "-> [])"+               in TokenReplace tokenText+          origLabel = case cfnArgTys of+            [] -> "e"+            _ -> "f"+          replLabel = case cfnArgTys of+            [] -> "[]"+            _ -> "\\" ++ unwords (replicate arity "_") ++ " -> []"+       in pure+            [ MutationAlt+                { mutAltType = wholeTy,+                  mutAltExpr = mutated,+                  mutAltOriginal = origLabel,+                  mutAltReplacement = replLabel,+                  mutAltDelta = delta,+                  mutAltMitigation = Nothing+                }+            ]++-- | Whether the list element type is 'Char' (i.e. the list is a+-- @[Char]@/'String').  Used to honour @skip-strings@.+isCharElemTy :: Type -> Bool+isCharElemTy ty = tyConAppTyCon_maybe ty == Just charTyCon++-- | Whether the expression is (syntactically) a string literal.  Strips+-- evidence/parens wrappers and recognises the @fromString \"...\"@ form+-- that @OverloadedStrings@ produces.  Used to honour+-- @skip-literal-strings@.+isStringLiteralExpr :: LHsExpr GhcTc -> Bool+isStringLiteralExpr = go . unLoc+  where+    go e = case unwrapWrap e of+      HsLit _ HsString {} -> True+      HsPar _ inner -> go (unLoc inner)+      -- @OverloadedStrings@: @fromString "..."@.+      HsApp _ _ arg -> case unwrapWrap (unLoc arg) of+        HsLit _ HsString {} -> True+        _ -> False+      _ -> False
+ src/Test/Syd/Mutation/Plugin/Operator/ConstNothing.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Plugin.Operator.ConstNothing (theOperator) where++import Control.Monad.Reader (asks)+import qualified Data.Text as T+import GHC+import GHC.Builtin.Types (maybeTyCon)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), OpAppCtx (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (ConstFnMatch (..), arrowTy, mkConstLambda, mkNothingExpr, prefixFormPreview, viewConstFnResult)++-- | Replace an expression whose type is @arg1 -> ... -> argN -> Maybe a@+-- (with @N >= 0@) with the constant function returning 'Nothing'.+--+--   * At arity 0, the mutant is just @Nothing@.+--   * At arity N \>= 1, it is @\\_ ... _ -> Nothing@ (typed at GhcTc as a+--     single 'HsLam' with N wildcard patterns).+--+-- Complements 'MaybeOp', which targets the syntactic @Just e@ form only.+-- The expression's outermost head must not be a data constructor (this op+-- never mutates @Just x@).+--+-- An arity-\>=1 firing is suppressed when 'instrumentEnvAppDepth' >= arity:+-- the matched expression is already saturated by enclosing applications,+-- so the arity-N mutant reduces to the same value the arity-0 mutation on+-- the enclosing saturated expression produces.  Emitting both is noise.+theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "ConstNothing",+      operatorDescription = "Replace a Maybe-typed expression (or a function returning Maybe) with a constant Nothing",+      operatorKind = ExpressionOperator $ \le ->+        case viewConstFnResult 0 maybeTyCon le of+          Just m -> Just (action le m)+          Nothing -> Nothing+    }++action ::+  LHsExpr GhcTc ->+  ConstFnMatch ->+  InstrM [MutationAlt]+action le ConstFnMatch {cfnArgTys, cfnResTy} = do+  opAppCtx <- asks instrumentEnvOpAppCtx+  appDepth <- asks instrumentEnvAppDepth+  let arity = length cfnArgTys+  if arity >= 1 && appDepth >= arity+    then pure []+    else+      let nothingExpr = mkNothingExpr cfnResTy+          wholeTy = arrowTy cfnArgTys cfnResTy+          mutated = mkConstLambda cfnArgTys cfnResTy nothingExpr+          atOpToken = case (arity, opAppCtx, getLocA le) of+            (n, Just ctx, RealSrcSpan mSp _) | n >= 1, mSp == opAppOpSpan ctx -> Just ctx+            _ -> Nothing+          delta = case atOpToken of+            Just ctx ->+              ReplaceOuterSpan+                (opAppOuterSpan ctx)+                (prefixFormPreview arity "Nothing" (opAppLhsText ctx) (opAppRhsText ctx))+            Nothing ->+              let tokenText = case cfnArgTys of+                    [] -> "Nothing"+                    _ ->+                      "(\\"+                        <> T.replicate arity "_ "+                        <> "-> Nothing)"+               in TokenReplace tokenText+          origLabel = case cfnArgTys of+            [] -> "e"+            _ -> "f"+          replLabel = case cfnArgTys of+            [] -> "Nothing"+            _ -> "\\" ++ unwords (replicate arity "_") ++ " -> Nothing"+       in pure+            [ MutationAlt+                { mutAltType = wholeTy,+                  mutAltExpr = mutated,+                  mutAltOriginal = origLabel,+                  mutAltReplacement = replLabel,+                  mutAltDelta = delta,+                  mutAltMitigation = Nothing+                }+            ]
+ src/Test/Syd/Mutation/Plugin/Operator/ElideCall.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Plugin.Operator.ElideCall (theOperator) where++import Control.Monad.Reader (asks)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import GHC+import GHC.Core.TyCo.Compare (eqType)+import GHC.Hs.Syn.Type (lhsExprType)+import GHC.Types.Name (getOccString)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (collectApp, headFunctionName, nameMatchCandidates, spanText)+import Test.Syd.Mutation.Plugin.OptParse (OperatorConfig (..), operatorExtraStrings)++-- | Replace a function application @f a@ with its argument @a@ whenever the+-- argument's type equals the result type of the whole application.+--+-- The application node already has the type the surrounding context expects,+-- so requiring the argument to have that same type is both necessary and+-- sufficient for the elided expression to keep type-checking.  This catches+-- calls that are supposed to /do something/ to a value of a type they also+-- return: @abs x@, @reverse xs@, @sort xs@, @succ n@, @T.strip t@, @id x@.  A+-- test that does not observe the difference between @f a@ and @a@ leaves the+-- mutant alive.+--+-- The condition makes the operator naturally selective:+--+--   * Data constructors never fire (@Just a@ has type @Maybe A /= A@, and the+--     same holds for tuples, @(:)@, and newtype constructors under nominal+--     equality), so this does not overlap 'MaybeOp' or 'ListLit'.+--   * Type and dictionary applications never fire: @f \@Int@ is an 'HsAppType',+--     not an 'HsApp', and a dictionary argument has a predicate type that+--     cannot equal the result type.+--+-- Only prefix applications are mutated.  At GhcTc an infix application @x + y@+-- is the expanded chain @(+) x y@ inside an @ExpandedThingTc@; the walker+-- recurses into that expansion with 'instrumentExpr' rather than+-- 'instrumentLExpr', so the saturated outer node is never offered to operators,+-- and the inner partial application @(+) x@ has a function result type that+-- fails the type-fit test.  Infix operators are therefore left to their own+-- operators ('Arith', 'Cmp', 'LogicOp').+--+-- Each application node is mutated independently, so for @g (f a)@ both+-- @g (f a) -> f a@ and @f a -> a@ are produced (each when its own type fits);+-- the two mutants have distinct spans, so unlike 'SwitchFunctionArguments'+-- this needs no application-depth guard against duplicates.+--+-- @id x@ is an /equivalent/ mutant — @id x@ and @x@ are the same value, so no+-- test can kill it — and so are other identity-on-this-type functions.  Calls+-- to @id@ are skipped by default; further functions can be suppressed by name+-- under the operator's @skip-calls-to@ config key:+--+-- > operators:+-- >   ElideCall:+-- >     skip-calls-to:+-- >       - fromIntegral+--+-- A name matches either bare (@fromIntegral@, matching any module) or fully+-- qualified (@GHC.Real.fromIntegral@).  A qualifier may be either the+-- function's defining module or a module it is imported through.+theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "ElideCall",+      operatorDescription = "Replace a function application with its argument when the argument's type matches the result type",+      operatorKind = ExpressionOperator $ \le -> case unLoc le of+        HsApp _ _ arg+          | eqType (lhsExprType arg) (lhsExprType le) ->+              Just (action le arg)+        _ -> Nothing+    }++action ::+  LHsExpr GhcTc ->+  LHsExpr GhcTc ->+  InstrM [MutationAlt]+action le arg = do+  srcLines <- asks (maybe [] snd . instrumentEnvSourceFile)+  opsConfig <- asks instrumentEnvOperatorsConfig+  rdrEnv <- asks instrumentEnvRdrEnv+  let extra = maybe Map.empty operatorConfigExtra (Map.lookup "ElideCall" opsConfig)+      -- @id@ is always an equivalent (unkillable) mutant, so it is skipped by+      -- default; other identity-like functions can be added by the user.+      skipCallsTo = "id" : operatorExtraStrings "skip-calls-to" extra+      (headExpr, _) = collectApp le+      skipThisCall = case headFunctionName headExpr of+        Just n -> any (`elem` skipCallsTo) (nameMatchCandidates rdrEnv n)+        Nothing -> False+  case (skipThisCall, getLocA le, getLocA arg) of+    (False, RealSrcSpan callSp _, RealSrcSpan argSp _)+      | not (null srcLines) ->+          let argText = spanText srcLines argSp+              callText = spanText srcLines callSp+           in pure+                [ MutationAlt+                    { mutAltType = lhsExprType le,+                      mutAltExpr = arg,+                      mutAltOriginal = T.unpack callText,+                      mutAltReplacement = T.unpack argText,+                      mutAltDelta = TokenReplace argText,+                      mutAltMitigation = mitigationFor headExpr+                    }+                ]+    _ -> pure []++-- | The mitigation hint recorded on every elision: if the called function is+-- an identity on this argument the mutant is equivalent (unkillable), and+-- listing the function under @skip-calls-to@ suppresses it.  'Nothing' when the+-- head is not a named function (so there is no name to suggest).+mitigationFor :: LHsExpr GhcTc -> Maybe Text+mitigationFor headExpr = do+  n <- headFunctionName headExpr+  let fn = getOccString n+  pure $+    T.pack $+      concat+        [ "If `",+          fn,+          "` is an identity on this argument this is an equivalent mutant ",+          "that no test can kill; add `",+          fn,+          "` to this operator's `skip-calls-to` config to suppress it."+        ]
+ src/Test/Syd/Mutation/Plugin/Operator/IntLit.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE LambdaCase #-}++module Test.Syd.Mutation.Plugin.Operator.IntLit (theOperator) where++import qualified Data.Text as T+import GHC+import GHC.Types.SourceText (il_value)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (mkIntLitExpr)++theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "IntLit",+      operatorDescription = "Replace an integer literal n with 0, 1, and -n",+      operatorKind = ExpressionOperator $ \case+        (L _ (HsOverLit _ (OverLit oltc@(OverLitTc {ol_type = ty}) (HsIntegral il)))) ->+          Just (action ty oltc (il_value il))+        _ -> Nothing+    }++action ::+  Type ->+  OverLitTc ->+  Integer ->+  InstrM [MutationAlt]+action ty oltc n =+  let candidates = filter (/= n) [0, 1, negate n]+   in pure $+        map+          ( \r ->+              MutationAlt+                { mutAltType = ty,+                  mutAltExpr = mkIntLitExpr r oltc,+                  mutAltOriginal = show n,+                  mutAltReplacement = show r,+                  mutAltDelta = TokenReplace (T.pack (show r)),+                  mutAltMitigation = Nothing+                }+          )+          candidates
+ src/Test/Syd/Mutation/Plugin/Operator/ListLit.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE LambdaCase #-}++module Test.Syd.Mutation.Plugin.Operator.ListLit (theOperator) where++import GHC+import GHC.Builtin.Types (mkListTy)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))++theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "ListLit",+      operatorDescription = "Shrink a list literal by removing elements or emptying it",+      operatorKind = ExpressionOperator $ \case+        (L ann (ExplicitList elTy es))+          | length es >= 2 ->+              Just (action ann elTy es)+        _ -> Nothing+    }++action ::+  SrcSpanAnnA ->+  Type ->+  [LHsExpr GhcTc] ->+  InstrM [MutationAlt]+action ann elTy es =+  let listTy = mkListTy elTy+      n = length es+      toRss e = case getLocA e of+        RealSrcSpan rss _ -> [rss]+        UnhelpfulSpan _ -> []+      mkList xs delta =+        MutationAlt+          { mutAltType = listTy,+            mutAltExpr = L ann (ExplicitList elTy xs),+            mutAltOriginal = show n ++ " elements",+            mutAltReplacement = show (length xs) ++ " elements",+            mutAltDelta = delta,+            mutAltMitigation = Nothing+          }+      -- Always produce: empty list, drop-head.+      -- Only add drop-last if it gives a different length than drop-head+      -- (i.e. n > 2; when n == 2 both give one element).+      lastE = reverse es+      repls = case es of+        [] -> []+        (firstE : restEs) ->+          mkList [] (SpanRemoval (concatMap toRss es))+            : mkList restEs (SpanRemoval (toRss firstE))+            : case lastE of+              [] -> []+              (le : _) -> [mkList (take (n - 1) es) (SpanRemoval (toRss le)) | n > 2]+   in pure repls
+ src/Test/Syd/Mutation/Plugin/Operator/LogicOp.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE NamedFieldPuns #-}++module Test.Syd.Mutation.Plugin.Operator.LogicOp (theOperator) where++import Control.Monad.Reader (ask)+import qualified Data.Text as T+import GHC.Builtin.Types (boolTy)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..), liftTcM)+import Test.Syd.Mutation.Plugin.Operator.Util (TcOpApp (..), matchTcOpApp, mkOpReplacement)++theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "LogicOp",+      operatorDescription = "Replace a boolean binary operator with the other",+      operatorKind = ExpressionOperator $ \le -> case matchTcOpApp le of+        Just tcOp@(TcOpApp {tcOpAppOcc = occ})+          | occ `elem` logicOps ->+              Just (action tcOp)+        _ -> Nothing+    }++logicOps :: [String]+logicOps = ["&&", "||"]++action ::+  TcOpApp ->+  InstrM [MutationAlt]+action TcOpApp {tcOpAppLhs, tcOpAppOp, tcOpAppRhs, tcOpAppOcc, tcOpAppOpSrcSpan} = do+  InstrumentEnv {instrumentEnvRdrEnv} <- ask+  let replacements = filter (/= tcOpAppOcc) logicOps+      delta replOcc = case tcOpAppOpSrcSpan of+        Just rss -> TokenReplaceAt rss (T.pack replOcc)+        Nothing -> TokenReplace (T.pack replOcc)+  mapM+    ( \replOcc -> do+        repl <- liftTcM $ mkOpReplacement instrumentEnvRdrEnv tcOpAppLhs tcOpAppOp tcOpAppRhs replOcc+        pure+          MutationAlt+            { mutAltType = boolTy,+              mutAltExpr = repl,+              mutAltOriginal = tcOpAppOcc,+              mutAltReplacement = replOcc,+              mutAltDelta = delta replOcc,+              mutAltMitigation = Nothing+            }+    )+    replacements
+ src/Test/Syd/Mutation/Plugin/Operator/MaybeOp.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Plugin.Operator.MaybeOp (theOperator) where++import GHC+import GHC.Hs.Syn.Type (lhsExprType)+import GHC.Types.Name (getOccString)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (mkNothingExpr)++theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "MaybeOp",+      operatorDescription = "Replace Just e with Nothing",+      operatorKind = ExpressionOperator $ \case+        le@(L _ (HsApp _ f _))+          | Just occ <- funOccName f,+            occ == "Just" ->+              Just (action le)+        _ -> Nothing+    }++-- | Extract the OccName string of the function in an application, handling+-- typechecker wrappers.  After typechecking, data constructors like @Just@+-- are rewritten from @HsVar@ to @XExpr (ConLikeTc ...)@, so we have to+-- inspect that form too — mirroring 'BoolLit.extractBoolLit'.+funOccName :: LHsExpr GhcTc -> Maybe String+funOccName = \case+  L _ (HsVar _ (L _ v)) -> Just (getOccString v)+  L _ (XExpr (ConLikeTc con _ _)) -> Just (getOccString con)+  L _ (XExpr (WrapExpr (HsWrap _ e))) -> funOccName (noLocA e)+  _ -> Nothing++action ::+  LHsExpr GhcTc ->+  InstrM [MutationAlt]+action le =+  -- lhsExprType gives Maybe a, which is the type for the ifMutation wrapper.+  -- 'mkNothingExpr' instantiates Nothing's type variable to that element type;+  -- a bare 'nlHsDataCon nothingDataCon' would be @forall a. Maybe a@ and make+  -- the surrounding @ifMutation \@ty@ wrapper ill-typed (see 'mkNothingExpr').+  let mayTy = lhsExprType le+      nothingExpr = mkNothingExpr mayTy+   in pure+        [ MutationAlt+            { mutAltType = mayTy,+              mutAltExpr = nothingExpr,+              mutAltOriginal = "Just e",+              mutAltReplacement = "Nothing",+              mutAltDelta = TokenReplace "Nothing",+              mutAltMitigation = Nothing+            }+        ]
+ src/Test/Syd/Mutation/Plugin/Operator/Negate.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Plugin.Operator.Negate (theOperator) where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ask)+import GHC+import GHC.Builtin.Types (boolTy)+import GHC.Hs.Syn.Type (lhsExprType)+import GHC.Tc.Utils.Env (tcLookupId)+import GHC.Tc.Utils.TcType (tcEqType)+import GHC.Types.Name (getOccString)+import GHC.Types.Name.Occurrence (lookupOccEnv, mkVarOcc)+import GHC.Types.Name.Reader (greName)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..), liftTcM)++theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "Negate",+      operatorDescription = "Wrap a Bool-typed expression with not",+      operatorKind = ExpressionOperator $ \le ->+        -- Don't match Bool literals or existing negations — BoolLit and the+        -- recursive instrumentation already handle those; wrapping them again+        -- would produce redundant mutations.+        case le of+          L _ (HsVar _ (L _ v))+            | getOccString v `elem` ["True", "False", "otherwise"] -> Nothing+          L _ (XExpr (ConLikeTc con _ _))+            | getOccString con `elem` ["True", "False"] -> Nothing+          _+            | tcEqType (lhsExprType le) boolTy -> Just (action le)+            | otherwise -> Nothing+    }++action ::+  LHsExpr GhcTc ->+  InstrM [MutationAlt]+action le = do+  InstrumentEnv {instrumentEnvRdrEnv} <- ask+  notId <- liftTcM $ case lookupOccEnv instrumentEnvRdrEnv (mkVarOcc "not") of+    Just (gre : _) -> tcLookupId (greName gre)+    _ -> liftIO $ ioError $ userError "mutation/Negate: 'not' not in scope"+  let notVar = noLocA (HsVar NoExtField (noLocA notId))+      negated = mkHsApp notVar le+  -- Wrap with parentheses so the rendered @mutated_lines@ keeps the right+  -- precedence: @not n < 0@ reparses as @(not n) < 0@, but the AST mutant+  -- is @not (n < 0)@. The @WrapWithText@ delta produces @not (n < 0)@.+  pure+    [ MutationAlt+        { mutAltType = boolTy,+          mutAltExpr = negated,+          mutAltOriginal = "e",+          mutAltReplacement = "not (e)",+          mutAltDelta = WrapWithText "not (" ")",+          mutAltMitigation = Nothing+        }+    ]
+ src/Test/Syd/Mutation/Plugin/Operator/RemoveAction.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE LambdaCase #-}++module Test.Syd.Mutation.Plugin.Operator.RemoveAction (theOperator) where++import Control.Monad.Reader (asks)+import GHC+import GHC.Hs.Syn.Type (lhsExprType)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (headNameMatches, opOccName)++-- | Remove one non-binding action from a do block.+--+-- At GhcTc, GHC 9.10 has already desugared @do@ blocks into chains of+-- @(>>)@ applications, so we never see an @HsDo@ node here for the typical+-- @do { tell "Hello"; tell "!" }@ shape. Instead we recognise the+-- desugared form @a >> rest@ (an 'HsApp' chain whose head is @(>>)@) and+-- produce a mutation that drops the left-hand action, yielding just+-- @rest@.+--+-- Type-safety note: @(>>) :: m a -> m b -> m b@, so dropping the left+-- operand preserves the overall type of the expression. Dropping the+-- right operand would not, so we only mutate by dropping the LHS.+theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "RemoveAction",+      operatorDescription = "Remove one non-binding action from a do block",+      operatorKind = ExpressionOperator $ \le ->+        case viewThenChain le of+          Just (lhs, rest) ->+            Just (mutateChain (lhsExprType le) lhs rest)+          Nothing -> matchRawHsDo le+    }++-- | Try to view a typechecked expression as @lhs >> rest@.+--+-- The desugared form is @HsApp _ (HsApp _ ((>>) @m @a @b $d) lhs) rest@.+-- We use 'opOccName' to walk through type and dictionary applications and+-- check that the head is indeed @(>>)@.+viewThenChain ::+  LHsExpr GhcTc ->+  Maybe (LHsExpr GhcTc, LHsExpr GhcTc)+viewThenChain le = case unLoc le of+  XExpr (ExpandedThingTc _ expanded) -> viewThenChain (L (getLoc le) expanded)+  HsApp _ outer rhs -> case unLoc outer of+    HsApp _ f lhs+      | Just ">>" <- opOccName f -> Just (lhs, rhs)+    _ -> Nothing+  _ -> Nothing++-- | Build the mutation: replace @lhs >> rest@ with just @rest@.+--+-- Suppressed when @lhs@'s syntactic head is on the @ignore@ list: removing+-- e.g. @logDebug "x"@ from @do { logDebug "x"; rest }@ is exactly the noise+-- the ignore filter exists to silence.  The filter in 'instrumentLExpr'+-- cannot catch this on its own because GHC 9.10 has expanded the do-block+-- into @(>>) lhs rest@, whose head is @(>>)@, not the ignored name — so we+-- check the removed action's head here instead.  Returning @[]@ makes+-- 'applyOperator' treat the site as a non-candidate (no warning, no mutant).+mutateChain ::+  Type ->+  LHsExpr GhcTc ->+  LHsExpr GhcTc ->+  InstrM [MutationAlt]+mutateChain ty lhs rest = do+  ignore <- asks instrumentEnvIgnore+  rdrEnv <- asks instrumentEnvRdrEnv+  let lhsIgnored = headNameMatches rdrEnv ignore lhs+  if lhsIgnored+    then pure []+    else+      let removedSpan = case getLocA lhs of+            RealSrcSpan rss _ -> [rss]+            UnhelpfulSpan _ -> []+       in pure+            [ MutationAlt+                { mutAltType = ty,+                  mutAltExpr = rest,+                  mutAltOriginal = "a >> rest",+                  mutAltReplacement = "rest",+                  mutAltDelta = SpanRemoval removedSpan,+                  mutAltMitigation = Nothing+                }+            ]++-- | Fallback: also support @HsDo@ if it ever shows up unexpanded+-- (e.g. list comprehensions, arrow notation), since the original+-- operator was written for that.+matchRawHsDo ::+  LHsExpr GhcTc ->+  Maybe (InstrM [MutationAlt])+matchRawHsDo = \case+  le@(L ann (HsDo x ctx (L lann stmts)))+    | any isRemovableStmt stmts ->+        Just (rawDoAction ann x ctx lann stmts (lhsExprType le))+  _ -> Nothing++isRemovableStmt :: ExprLStmt GhcTc -> Bool+isRemovableStmt (L _ s) = case s of+  BodyStmt {} -> True+  _ -> False++-- | The expression of a 'BodyStmt', if this statement is one.+bodyStmtExpr :: ExprLStmt GhcTc -> Maybe (LHsExpr GhcTc)+bodyStmtExpr (L _ s) = case s of+  BodyStmt _ e _ _ -> Just e+  _ -> Nothing++rawDoAction ::+  SrcSpanAnnA ->+  XDo GhcTc ->+  HsDoFlavour ->+  SrcSpanAnnL ->+  [ExprLStmt GhcTc] ->+  Type ->+  InstrM [MutationAlt]+rawDoAction ann x ctx lann stmts ty = do+  -- Do not offer to remove a statement whose head is on the 'ignore' list:+  -- removing @logDebug "x"@ and the like is the noise the ignore filter+  -- exists to silence.  Mirrors the guard in 'mutateChain' for the expanded+  -- @(>>)@ form.+  ignore <- asks instrumentEnvIgnore+  rdrEnv <- asks instrumentEnvRdrEnv+  let stmtIgnored s = maybe False (headNameMatches rdrEnv ignore) (bodyStmtExpr s)+      removable = [(i, s) | (i, s) <- zip [0 ..] stmts, isRemovableStmt s, not (stmtIgnored s)]+      n = length stmts+      mkMutation i s =+        let stmts' = take i stmts ++ drop (i + 1) stmts+            removedSpan = case getLocA s of+              RealSrcSpan rss _ -> [rss]+              UnhelpfulSpan _ -> []+         in MutationAlt+              { mutAltType = ty,+                mutAltExpr = L ann (HsDo x ctx (L lann stmts')),+                mutAltOriginal = show n ++ " statements",+                mutAltReplacement = show (n - 1) ++ " statements (removed #" ++ show (i + 1) ++ ")",+                mutAltDelta = SpanRemoval removedSpan,+                mutAltMitigation = Nothing+              }+  pure [mkMutation i s | (i, s) <- removable]
+ src/Test/Syd/Mutation/Plugin/Operator/RemoveCase.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE LambdaCase #-}++module Test.Syd.Mutation.Plugin.Operator.RemoveCase (theOperator) where++import GHC+import GHC.Hs.Syn.Type (lhsExprType)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))++theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "RemoveCase",+      operatorDescription = "Remove one alternative from a case expression",+      operatorKind = ExpressionOperator $ \case+        le@(L ann (HsCase x scrut (MG mgx (L lann alts))))+          | length alts >= 2 ->+              Just (action ann x scrut mgx lann alts (lhsExprType le))+        _ -> Nothing+    }++action ::+  SrcSpanAnnA ->+  XCase GhcTc ->+  LHsExpr GhcTc ->+  XMG GhcTc (LHsExpr GhcTc) ->+  SrcSpanAnnL ->+  [LMatch GhcTc (LHsExpr GhcTc)] ->+  Type ->+  InstrM [MutationAlt]+action ann x scrut mgx lann alts ty =+  let n = length alts+      mkMutation i alt =+        let alts' = take i alts ++ drop (i + 1) alts+            mg' = MG mgx (L lann alts')+            removedSpan = case getLocA alt of+              RealSrcSpan rss _ -> [rss]+              UnhelpfulSpan _ -> []+         in MutationAlt+              { mutAltType = ty,+                mutAltExpr = L ann (HsCase x scrut mg'),+                mutAltOriginal = show n ++ " alternatives",+                mutAltReplacement = show (n - 1) ++ " alternatives (removed #" ++ show (i + 1) ++ ")",+                mutAltDelta = SpanRemoval removedSpan,+                mutAltMitigation = Nothing+              }+   in pure [mkMutation i alt | (i, alt) <- zip [0 ..] alts]
+ src/Test/Syd/Mutation/Plugin/Operator/RemoveClause.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE LambdaCase #-}++module Test.Syd.Mutation.Plugin.Operator.RemoveClause (theOperator) where++import GHC+import GHC.Builtin.Types (boolTy, falseDataCon, trueDataCon)+import Test.Syd.Mutation.Plugin.Instrument+  ( ClauseAlt (..),+    InstrM,+    MutationOperator (..),+    MutationOperatorKind (..),+    SrcSpanDelta (..),+    wrapWithIfMutation,+  )+import Test.Syd.Mutation.Runtime (MutationId)++-- | Remove one clause (equation) from a function binding with two or more+-- clauses.+--+-- A clause is a 'Match', not an 'LHsExpr', so this cannot be expressed through+-- the expression-level @ifMutation \@ty mutant original@ swap.  Instead, the+-- clause to be removed gets a guard @ifMutation mid False True@ prepended to+-- every one of its 'GRHS's: when @mid@ is the active mutation every guard+-- evaluates to 'False', so the clause matches no input and control falls+-- through to the next equation (or, for the last matching clause, to a+-- non-exhaustive @MatchFail@ that any covering test kills immediately).  When+-- @mid@ is inactive the guard is 'True' and 'ifMutation' also performs the+-- usual coverage bookkeeping, so no new runtime primitive is needed.+--+-- Because the injected guard sits after the clause's patterns, it is only+-- evaluated when those patterns match — exactly the inputs for which removing+-- the clause could change behaviour, so coverage is attributed to the tests+-- that actually reach the clause.+--+-- Only fires on bindings with at least two clauses: removing the sole clause of+-- a function is always a non-exhaustive crash, a trivially-killed mutant that+-- would only add noise.+theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "RemoveClause",+      operatorDescription = "Remove one clause (equation) from a function binding",+      operatorKind = FunctionDeclarationOperator $ \case+        MG _ (L _ alts)+          | length alts >= 2 ->+              Just (pure (zipWith (mkAlt (length alts)) [0 ..] alts))+        _ -> Nothing+    }++-- | Build the removal alternative for clause @i@ (0-based) of @n@.+mkAlt :: Int -> Int -> LMatch GhcTc (LHsExpr GhcTc) -> ClauseAlt+mkAlt n i alt =+  ClauseAlt+    { clauseAltSpan = getLocA alt,+      clauseAltOriginal = show n ++ " clauses",+      clauseAltReplacement = show (n - 1) ++ " clauses (removed #" ++ show (i + 1) ++ ")",+      clauseAltDelta = SpanRemoval removedSpan,+      clauseAltMitigation = Nothing,+      clauseAltApply = injectRemovalGuard i+    }+  where+    removedSpan = case getLocA alt of+      RealSrcSpan rss _ -> [rss]+      UnhelpfulSpan _ -> []++-- | Prepend @ifMutation mid False True@ as a guard to every 'GRHS' of clause+-- @i@, so that whole clause is skipped when @mid@ is the active mutation.+injectRemovalGuard ::+  Int ->+  MutationId ->+  MatchGroup GhcTc (LHsExpr GhcTc) ->+  InstrM (MatchGroup GhcTc (LHsExpr GhcTc))+injectRemovalGuard i mid = \case+  MG x (L lann alts) -> do+    guardStmt <- mkRemovalGuardStmt mid+    let alts' = [if j == i then prependGuard guardStmt alt else alt | (j, alt) <- zip [0 ..] alts]+    pure (MG x (L lann alts'))++-- | Prepend a guard statement to every 'GRHS' of a clause.+prependGuard ::+  GuardLStmt GhcTc ->+  LMatch GhcTc (LHsExpr GhcTc) ->+  LMatch GhcTc (LHsExpr GhcTc)+prependGuard guardStmt = fmap $ \case+  Match mx ctx pats (GRHSs gx grhss localBinds) ->+    Match mx ctx pats (GRHSs gx (map (fmap addGuard) grhss) localBinds)+  where+    addGuard :: GRHS GhcTc (LHsExpr GhcTc) -> GRHS GhcTc (LHsExpr GhcTc)+    addGuard = \case+      GRHS gx guards body -> GRHS gx (guardStmt : guards) body++-- | The boolean guard statement @ifMutation mid False True@.+mkRemovalGuardStmt :: MutationId -> InstrM (GuardLStmt GhcTc)+mkRemovalGuardStmt mid = do+  guardExpr <- wrapWithIfMutation boolTy mid (nlHsDataCon falseDataCon) (nlHsDataCon trueDataCon)+  pure (noLocA (BodyStmt boolTy guardExpr noSyntaxExpr noSyntaxExpr))
+ src/Test/Syd/Mutation/Plugin/Operator/SwitchFunctionArguments.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Plugin.Operator.SwitchFunctionArguments (theOperator) where++import Control.Monad.Reader (asks)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import GHC+import GHC.Core.TyCo.Compare (eqType)+import GHC.Hs.Syn.Type (lhsExprType)+import GHC.Types.Name (getOccString)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (collectApp, headFunctionName, nameMatchCandidates, spanText)+import Test.Syd.Mutation.Plugin.OptParse (OperatorConfig (..), operatorExtraStrings)++-- | Swap two arguments of the same type in a prefix function application.+--+-- When a function (or data constructor) is applied to two value arguments+-- that have the same type, the call still type-checks with those two+-- arguments swapped, but usually computes something different.  For every+-- pair of equal-typed arguments at an application site we emit one mutant+-- that swaps that pair.+--+-- Only prefix applications (@f a b@, @Con a b@) are considered: infix+-- operator applications are left to their own operators (e.g. 'Arith').  Two+-- restrictions keep the output honest:+--+--   * The operator only fires on the maximal application spine (it skips+--     sites that are themselves the function side of an enclosing+--     application, detected via 'instrumentEnvAppDepth').  Without this, the+--     curried sub-application @f a@ inside @f a b@ would re-emit the same+--     swap the full spine already covers.+--   * Pairs whose two arguments have identical source text are skipped:+--     swapping them produces an identical program and an unkillable mutant.+--+-- Symmetric functions (@max@, @min@, set union, a majority predicate, ...)+-- produce /equivalent/ mutants — swapping their arguments cannot change the+-- result, so no test can ever kill the mutant.  Because symmetry is a+-- semantic property the plugin cannot detect, calls to such functions are+-- suppressed by listing the function's name under the operator's+-- @skip-calls-to@ config key:+--+-- > operators:+-- >   SwitchFunctionArguments:+-- >     skip-calls-to:+-- >       - max+-- >       - Data.Set.union+--+-- A name matches either bare (@max@, matching any module) or fully qualified+-- (@Data.Set.union@).  A qualifier may be either the function's defining+-- module or a module it is imported through, so a re-exported function works+-- under the module you import it from (@Data.Set.union@) as well as the+-- internal module it is defined in (@Data.Set.Internal.union@).+theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "SwitchFunctionArguments",+      operatorDescription = "Swap two same-typed arguments of a function application",+      operatorKind = ExpressionOperator $ \le -> case collectApp le of+        (headExpr, args)+          | pairs@(_ : _) <- sameTypePairs args ->+              Just (action le headExpr args pairs)+        _ -> Nothing+    }++action ::+  LHsExpr GhcTc ->+  LHsExpr GhcTc ->+  [LHsExpr GhcTc] ->+  [(Int, Int)] ->+  InstrM [MutationAlt]+action le headExpr args pairs = do+  -- Only fire on the outermost application spine.  Inside @f a b@, the+  -- function side @f a@ is visited with depth >= 1; emitting a swap there+  -- would duplicate one the full spine already produces.+  appDepth <- asks instrumentEnvAppDepth+  srcLines <- asks (maybe [] snd . instrumentEnvSourceFile)+  -- Suppress calls to functions the user has marked symmetric (their swaps+  -- are equivalent, unkillable mutants).  See this module's haddock.+  opsConfig <- asks instrumentEnvOperatorsConfig+  rdrEnv <- asks instrumentEnvRdrEnv+  let extra = maybe Map.empty operatorConfigExtra (Map.lookup "SwitchFunctionArguments" opsConfig)+      skipCallsTo = operatorExtraStrings "skip-calls-to" extra+      skipThisCall = case headFunctionName headExpr of+        Just n -> any (`elem` skipCallsTo) (nameMatchCandidates rdrEnv n)+        Nothing -> False+  if appDepth /= 0 || skipThisCall+    then pure []+    else+      let ty = lhsExprType le+          haveSrc = not (null srcLines)+          -- Hint shown for any surviving swap: if the called function is+          -- symmetric the mutant is equivalent and unkillable, and listing the+          -- function under 'skip-calls-to' suppresses it.+          mitigation = mitigationFor headExpr+       in pure+            [ MutationAlt+                { mutAltType = ty,+                  mutAltExpr = foldl mkHsApp headExpr (swapAt i j argI argJ args),+                  mutAltOriginal = origStr,+                  mutAltReplacement = replStr,+                  mutAltDelta = SwapSpans spanI spanJ,+                  mutAltMitigation = mitigation+                }+            | (i, j) <- pairs,+              Just argI <- [indexArg args i],+              Just argJ <- [indexArg args j],+              RealSrcSpan spanI _ <- [getLocA argI],+              let textI = spanText srcLines spanI,+              RealSrcSpan spanJ _ <- [getLocA argJ],+              let textJ = spanText srcLines spanJ,+              -- Skip no-op swaps of textually identical arguments.+              not (haveSrc && textI == textJ),+              let origStr = label haveSrc i j textI textJ,+              let replStr = label haveSrc j i textJ textI+            ]+  where+    -- Human-readable manifest summary of the two operands, in the given+    -- order.  Falls back to positional names when the source isn't available.+    label haveSrc x y tx ty'+      | haveSrc = T.unpack tx ++ " " ++ T.unpack ty'+      | otherwise = "arg" ++ show (x + 1) ++ " " ++ "arg" ++ show (y + 1)++-- | The mitigation hint recorded on every swap mutation at a call: if the+-- called function turns out to be symmetric in these arguments the mutant is+-- equivalent (unkillable), and listing the function under @skip-calls-to@+-- suppresses it.  'Nothing' when the head is not a named function (so there is+-- no name to suggest), e.g. a data constructor.+mitigationFor :: LHsExpr GhcTc -> Maybe Text+mitigationFor headExpr = do+  n <- headFunctionName headExpr+  let fn = getOccString n+  pure $+    T.pack $+      concat+        [ "If `",+          fn,+          "` is symmetric in these arguments this is an equivalent mutant ",+          "that no test can kill; add `",+          fn,+          "` to this operator's `skip-calls-to` config to suppress it."+        ]++-- | Indices @(i, j)@ with @i < j@ whose arguments have the same type.+sameTypePairs :: [LHsExpr GhcTc] -> [(Int, Int)]+sameTypePairs args =+  let typed = zip [0 ..] (map lhsExprType args)+   in [ (i, j)+      | (i, ti) <- typed,+        (j, tj) <- typed,+        i < j,+        eqType ti tj+      ]++-- | Total list indexing without 'Prelude.!!'.+indexArg :: [a] -> Int -> Maybe a+indexArg xs i = case drop i xs of+  (x : _) -> Just x+  [] -> Nothing++-- | Replace the elements at indices @i@ and @j@ with @xj@ and @xi@.+swapAt :: Int -> Int -> a -> a -> [a] -> [a]+swapAt i j xi xj xs =+  [ if k == i then xj else if k == j then xi else x+  | (k, x) <- zip [0 ..] xs+  ]
+ src/Test/Syd/Mutation/Plugin/Operator/TupleSwap.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE LambdaCase #-}++module Test.Syd.Mutation.Plugin.Operator.TupleSwap (theOperator) where++import Control.Monad.Reader (asks)+import qualified Data.Text as T+import GHC+import GHC.Core.TyCo.Compare (eqType)+import GHC.Hs.Syn.Type (lhsExprType)+import GHC.Types.Basic (Boxity (..))+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (spanText)++-- | Swap two same-typed components of a tuple.+--+-- For a tuple @(e1, ..., eN)@ whose components @ei@ and @ej@ have the same+-- type, the tuple still type-checks with those two components swapped but+-- usually denotes a different value, so we emit one mutant per same-typed pair+-- that swaps that pair.+--+-- This is the tuple-syntax counterpart to 'SwitchFunctionArguments': an+-- 'ExplicitTuple' is its own AST node, not an application spine, so that+-- operator never reaches it.  Two restrictions keep the output honest,+-- mirroring that operator:+--+--   * Only fully-saturated tuples are mutated.  A tuple /section/ like @(,b)@+--     carries a 'Missing' component and is really a function, so it is skipped.+--   * Pairs whose two components have identical source text are skipped:+--     swapping them produces an identical program and an unkillable mutant.+--+-- Only /boxed/ tuples are mutated.  An unboxed tuple's type has kind+-- @TYPE (TupleRep ...)@, not @Type@, but the @ifMutation \@ty@ wrapper the+-- plugin places around every mutant is monomorphic in a lifted @ty@.  Wrapping+-- an unboxed tuple builds an ill-kinded application that GHC miscompiles into a+-- binary that aborts at runtime, so unboxed tuples are excluded outright.+--+-- Unlike 'SwitchFunctionArguments' no application-depth guard is needed: each+-- 'ExplicitTuple' node is visited exactly once by the walker, and a nested+-- tuple is a distinct node with a distinct span, so no swap is emitted twice.+theOperator :: MutationOperator+theOperator =+  MutationOperator+    { operatorName = "TupleSwap",+      operatorDescription = "Swap two same-typed components of a tuple",+      operatorKind = ExpressionOperator $ \case+        le@(L _ (ExplicitTuple _ args Boxed))+          | Just exprs <- allPresent args,+            length exprs >= 2,+            pairs@(_ : _) <- sameTypePairs exprs ->+              Just (action le exprs pairs)+        _ -> Nothing+    }++action ::+  LHsExpr GhcTc ->+  [LHsExpr GhcTc] ->+  [(Int, Int)] ->+  InstrM [MutationAlt]+action le exprs pairs = do+  srcLines <- asks (maybe [] snd . instrumentEnvSourceFile)+  let ty = lhsExprType le+      haveSrc = not (null srcLines)+  pure+    [ MutationAlt+        { mutAltType = ty,+          mutAltExpr = rebuild i j,+          mutAltOriginal = origStr,+          mutAltReplacement = replStr,+          mutAltDelta = SwapSpans spanI spanJ,+          mutAltMitigation = Nothing+        }+    | (i, j) <- pairs,+      Just exprI <- [indexList exprs i],+      Just exprJ <- [indexList exprs j],+      RealSrcSpan spanI _ <- [getLocA exprI],+      let textI = spanText srcLines spanI,+      RealSrcSpan spanJ _ <- [getLocA exprJ],+      let textJ = spanText srcLines spanJ,+      -- Skip no-op swaps of textually identical components.+      not (haveSrc && textI == textJ),+      let origStr = label haveSrc i j textI textJ,+      let replStr = label haveSrc j i textJ textI+    ]+  where+    -- Rebuild the tuple with the components at indices @i@ and @j@ swapped,+    -- reusing the original node's extension field and boxity.+    rebuild i j = case le of+      L ann (ExplicitTuple x args boxity) ->+        L ann (ExplicitTuple x (swapAt i j args) boxity)+      _ -> le+    -- Human-readable manifest summary of the two components, in the given+    -- order.  Falls back to positional names when the source isn't available.+    label haveSrc p q tp tq+      | haveSrc = T.unpack tp ++ ", " ++ T.unpack tq+      | otherwise = "arg" ++ show (p + 1) ++ ", arg" ++ show (q + 1)++-- | The component expressions of a tuple, if every component is present (i.e.+-- it is a real tuple, not a tuple section).+allPresent :: [HsTupArg GhcTc] -> Maybe [LHsExpr GhcTc]+allPresent = traverse $ \case+  Present _ e -> Just e+  Missing _ -> Nothing++-- | Indices @(i, j)@ with @i < j@ whose components have the same type.+sameTypePairs :: [LHsExpr GhcTc] -> [(Int, Int)]+sameTypePairs exprs =+  let typed = zip [0 ..] (map lhsExprType exprs)+   in [ (i, j)+      | (i, ti) <- typed,+        (j, tj) <- typed,+        i < j,+        eqType ti tj+      ]++-- | Total list indexing without 'Prelude.!!'.+indexList :: [a] -> Int -> Maybe a+indexList xs i = case drop i xs of+  (x : _) -> Just x+  [] -> Nothing++-- | Swap the elements at indices @i@ and @j@.+swapAt :: Int -> Int -> [a] -> [a]+swapAt i j xs = case (indexList xs i, indexList xs j) of+  (Just xi, Just xj) ->+    [ if k == i then xj else if k == j then xi else x+    | (k, x) <- zip [0 ..] xs+    ]+  _ -> xs
+ src/Test/Syd/Mutation/Plugin/Operator/Util.hs view
@@ -0,0 +1,454 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Plugin.Operator.Util+  ( opOccName,+    mkOpReplacement,+    mkIntLitExpr,+    TcOpApp (..),+    matchTcOpApp,+    ConstFnMatch (..),+    viewConstFnResult,+    mkNothingExpr,+    mkConstLambda,+    arrowTy,+    prefixFormPreview,+    unwrapWrap,+    collectApp,+    headFunctionName,+    nameMatchCandidates,+    headNameMatches,+    spanText,+  )+where++import Control.Monad.IO.Class (liftIO)+import Data.List (nub)+import Data.Text (Text)+import qualified Data.Text as T+import GHC+import GHC.Builtin.Types (manyDataConTy, nothingDataCon)+import GHC.Core.DataCon (dataConWrapId)+import GHC.Core.TyCo.Rep (Scaled (..))+import GHC.Core.Type (isForAllTy, mkVisFunTyMany, splitFunTy_maybe, splitTyConApp_maybe)+import GHC.Data.Bag (bagToList)+import GHC.Hs.Syn.Type (lhsExprType)+import GHC.Tc.Types (TcM)+import GHC.Tc.Utils.Env (tcLookupId)+import GHC.Types.Basic (DoPmc (..), GenReason (..), Origin (..))+import GHC.Types.Id (idName)+import GHC.Types.Name (getOccString, nameModule_maybe)+import GHC.Types.Name.Occurrence (lookupOccEnv, mkVarOcc)+import GHC.Types.Name.Reader (GlobalRdrEnv, greName, gre_imp, importSpecModule, lookupGRE_Name)+import GHC.Types.SourceText (mkIntegralLit)+import GHC.Utils.Outputable (ppr)+import GHC.Utils.Panic (pprPanic)++-- | The 'Name' at the head of an application chain.  At GhcTc the head often+-- has type and dictionary arguments attached (e.g. @(+) \@Int $dNumInt@), so we+-- walk through 'HsApp', 'HsAppType', and 'WrapExpr' wrappers to find the+-- underlying 'HsVar'.+--+-- Also peels through @XExpr (ExpandedThingTc orig expanded)@: GHC 9.6+ expands+-- source-level @f $ x@ and similar rebindable-syntax forms into @HsApp@ chains+-- wrapped in 'ExpandedThingTc'.  Without this case, a call like @logInfo $ ...@+-- would look like a "no head" expression, and the ignore filter (which+-- dispatches on this head) would let mutations leak into the argument subtree.+--+-- Treats @($)@ specially: at GhcTc, @f $ x@ is expanded into the application+-- chain @($) f x@, but the syntactic "head" the user thinks of is @f@, not+-- @($)@.  Whenever we encounter @($) f x@ (or any further nesting of @$@s),+-- we recurse on the first argument instead of returning @($)@.+opName :: LHsExpr GhcTc -> Maybe Name+opName = \case+  L _ (HsVar _ (L _ v)) -> Just (idName v)+  L _ (XExpr (WrapExpr (HsWrap _ e))) -> opName (noLocA e)+  L _ (XExpr (ExpandedThingTc _ e)) -> opName (noLocA e)+  L _ (HsApp _ f a)+    | Just n <- opName f, getOccString n == "$" -> opName a+    | otherwise -> opName f+  L _ (HsAppType _ f _) -> opName f+  L _ (HsPar _ e) -> opName e+  _ -> Nothing++-- | The unqualified @OccName@ string of the head returned by 'opName', if any.+-- Used where only the bare operator/identifier name matters, e.g. the infix+-- operator extraction in 'matchTcOpApp' and the @(>>)@ check in 'RemoveAction'.+opOccName :: LHsExpr GhcTc -> Maybe String+opOccName = fmap getOccString . opName++-- | Does the head of @le@ (as found by 'opName') match any of the given+-- names?  Each name matches either the bare @OccName@ (e.g. @mark@, matching+-- any module) or a fully-qualified @Module.name@ form — by the defining module+-- or by an import module — via 'nameMatchCandidates'.  Used by the @ignore@+-- filter and by 'RemoveAction'.+--+-- The empty-list case short-circuits before touching the GlobalRdrEnv: the+-- @ignore@ filter calls this on every expression in the module, so when no+-- names are configured (the common case) we avoid a per-expression GRE lookup.+headNameMatches :: GlobalRdrEnv -> [String] -> LHsExpr GhcTc -> Bool+headNameMatches _ [] _ = False+headNameMatches rdrEnv names le =+  any ((`elem` names) . T.unpack) (maybe [] (nameMatchCandidates rdrEnv) (opName le))++-- | A view of a binary infix operator application as it appears in the+-- typechecked AST.  At GhcTc, GHC always expands the source-level @OpApp@ into+-- @HsApp (HsApp op lhs) rhs@ wrapped in @XExpr (ExpandedThingTc (OrigExpr orig)+-- expanded)@.  Operators that want to match infix uses (Arith, Cmp, LogicOp)+-- should use 'matchTcOpApp' rather than pattern-matching on @OpApp@ directly,+-- which would always fail.+data TcOpApp = TcOpApp+  { -- | The result type of the operator application.+    tcOpAppTy :: Type,+    -- | The left operand (typechecked).+    tcOpAppLhs :: LHsExpr GhcTc,+    -- | The operator expression (typechecked, with type and dictionary args+    -- still attached).  Used as the substitution target for+    -- 'mkOpReplacement'.+    tcOpAppOp :: LHsExpr GhcTc,+    -- | The right operand (typechecked).+    tcOpAppRhs :: LHsExpr GhcTc,+    -- | The operator's @OccName@ string (e.g. \"+\", \"==\").+    tcOpAppOcc :: String,+    -- | The source 'RealSrcSpan' of the operator token (as written by the+    -- user), if available.  Recovered from the renamed @OrigExpr@ inside+    -- @ExpandedThingTc@; will be @Nothing@ if the operator originated outside+    -- a syntactic infix application.+    tcOpAppOpSrcSpan :: Maybe RealSrcSpan+  }++-- | Match a typechecked binary infix operator application.  Recognises both+-- the post-typecheck expanded form (@ExpandedThingTc@ wrapping an @HsApp@+-- chain) and a raw @OpApp@ as a fallback.+matchTcOpApp :: LHsExpr GhcTc -> Maybe TcOpApp+matchTcOpApp le = case unLoc le of+  -- Post-typecheck expanded form: @ExpandedThingTc (OrigExpr (OpApp _ l op r))+  --                                                (HsApp _ (HsApp _ tcOp tcL) tcR)@.+  XExpr (ExpandedThingTc orig expanded)+    | Just (tcOp, tcL, tcR) <- viewHsApp2 expanded,+      Just occ <- opOccName tcOp ->+        Just (TcOpApp (lhsExprType tcL) tcL tcOp tcR occ (origOpSrcSpan orig))+  -- Fallback for any compiler version that keeps OpApp at GhcTc.+  OpApp _ lhs op rhs+    | Just occ <- opOccName op ->+        Just (TcOpApp (lhsExprType lhs) lhs op rhs occ (rnOpSrcSpan op))+  _ -> Nothing++-- | Get the source 'RealSrcSpan' of the operator from the renamed origin of+-- an @ExpandedThingTc@ wrapper, if it was an infix application.+origOpSrcSpan :: HsThingRn -> Maybe RealSrcSpan+origOpSrcSpan = \case+  OrigExpr (OpApp _ _ op _) -> rnOpSrcSpan op+  _ -> Nothing++-- | Get the 'RealSrcSpan' of an operator expression (renamed or typechecked).+rnOpSrcSpan :: GenLocated SrcSpanAnnA e -> Maybe RealSrcSpan+rnOpSrcSpan (L l _) = case locA l of+  RealSrcSpan rss _ -> Just rss+  UnhelpfulSpan _ -> Nothing++-- | Decompose a 2-argument application: @HsApp _ (HsApp _ f a) b@ → @(f, a, b)@.+-- Skips through 'WrapExpr' wrappers.+viewHsApp2 :: HsExpr GhcTc -> Maybe (LHsExpr GhcTc, LHsExpr GhcTc, LHsExpr GhcTc)+viewHsApp2 e0 = case unwrapWrap e0 of+  HsApp _ outer rhs -> case unwrapWrap (unLoc outer) of+    HsApp _ f lhs -> Just (f, lhs, rhs)+    _ -> Nothing+  _ -> Nothing++-- | Skip outermost 'WrapExpr' layers.+unwrapWrap :: HsExpr GhcTc -> HsExpr GhcTc+unwrapWrap = \case+  XExpr (WrapExpr (HsWrap _ inner)) -> unwrapWrap inner+  e -> e++-- | Build the mutated infix application by substituting the operator id.+--+-- @origOp@ is the typechecked operator expression (an @HsVar@ wrapped in type+-- and dictionary applications).  We replace the innermost 'HsVar' id with the+-- replacement operator's id, then reconstruct the application as+-- @HsApp _ (HsApp _ origOp[op := replOp] lhs) rhs@.+mkOpReplacement ::+  GlobalRdrEnv ->+  LHsExpr GhcTc ->+  LHsExpr GhcTc ->+  LHsExpr GhcTc ->+  String ->+  TcM (LHsExpr GhcTc)+mkOpReplacement rdrEnv l origOp r replOccStr = do+  replId <- case lookupOccEnv rdrEnv (mkVarOcc replOccStr) of+    Just (gre : _) -> tcLookupId (greName gre)+    _ ->+      liftIO $+        ioError $+          userError $+            "mutation: replacement operator " ++ replOccStr ++ " not in scope"+  let replOp = substOpId replId origOp+      inner = mkHsApp replOp l+      outer = mkHsApp inner r+  pure outer+  where+    -- Replace the innermost HsVar id in the op expression, preserving the+    -- surrounding 'HsApp', 'HsAppType', 'HsPar', and 'WrapExpr' wrappers that+    -- carry the typechecker's type and dictionary applications. Mirrors the+    -- structure 'opOccName' walks: substOpId must reach the same 'HsVar' that+    -- 'opOccName' would have returned the OccName for.+    substOpId :: Id -> LHsExpr GhcTc -> LHsExpr GhcTc+    substOpId newId = \case+      L ann (HsVar x (L l' _)) -> L ann (HsVar x (L l' newId))+      L ann (XExpr (WrapExpr (HsWrap w e))) ->+        L ann (XExpr (WrapExpr (HsWrap w (unLoc (substOpId newId (noLocA e))))))+      L ann (HsApp x f a) -> L ann (HsApp x (substOpId newId f) a)+      L ann (HsAppType x f t) -> L ann (HsAppType x (substOpId newId f) t)+      L ann (HsPar x e) -> L ann (HsPar x (substOpId newId e))+      other -> other++-- | Build a replacement integer literal expression without any validation.+mkIntLitExpr :: Integer -> OverLitTc -> LHsExpr GhcTc+mkIntLitExpr n oltc =+  let iln = mkIntegralLit n+      witnessN = substIntegerInWitness n (ol_witness oltc)+      oltcN = oltc {ol_witness = witnessN}+   in noLocA (HsOverLit NoExtField (OverLit oltcN (HsIntegral iln)))++-- | Substitute the integer value in a @fromInteger dict (HsInteger _ n _)@ witness.+substIntegerInWitness :: Integer -> HsExpr GhcTc -> HsExpr GhcTc+substIntegerInWitness n = \case+  HsApp x f arg -> HsApp x f (fmap (substIntegerInWitness n) arg)+  HsLit x (HsInteger src _ ty) -> HsLit x (HsInteger src n ty)+  XExpr (WrapExpr (HsWrap w e)) -> XExpr (WrapExpr (HsWrap w (substIntegerInWitness n e)))+  e -> e++-- | Result of matching an expression for the @Const…@ family of operators:+-- peel arrows on @le@'s type until the head TyCon matches a target, with+-- the argument types of the arrows that were peeled.+data ConstFnMatch = ConstFnMatch+  { -- | Argument types of the arrows that were peeled, in order.  Empty for+    -- arity 0 (the expression itself already has the target type).+    cfnArgTys :: [Type],+    -- | The result type (the target TyCon applied to its arguments).+    cfnResTy :: Type,+    -- | The result type's TyCon arguments, e.g. @[a]@ for @[a] -> Maybe a@.+    cfnTyConArgs :: [Type]+  }++-- | If @le@'s type matches @arg1 -> ... -> argN -> targetTyCon tcArgs@ with+-- @N >= minArity@, return the peeled arrow argument types, the final result+-- type, and the target TyCon's arguments.  Used by the @Const…@ family.+--+-- Returns 'Nothing' when:+--+--   * @le@'s outermost head is a data constructor (e.g. @Just x@, @x : xs@) —+--     those have their own dedicated operators ('MaybeOp', 'ListLit') and+--     would duplicate them,+--   * the expression's type has a forall or class constraint (we can't+--     synthesise a constant under one without building a typed dictionary or+--     type lambda),+--   * after peeling arrows, the result type does not split as+--     @targetTyCon args@,+--   * the arity (number of arrows peeled) is less than @minArity@.+viewConstFnResult :: Int -> TyCon -> LHsExpr GhcTc -> Maybe ConstFnMatch+viewConstFnResult minArity targetTyCon le = do+  () <- nonConstructorHead le+  let ty = lhsExprType le+  if isForAllTy ty+    then Nothing+    else do+      let (argTys, resTy) = peelArrows ty+      if length argTys < minArity+        then Nothing+        else do+          (tc, tcArgs) <- splitTyConApp_maybe resTy+          if tc == targetTyCon+            then Just (ConstFnMatch argTys resTy tcArgs)+            else Nothing++-- | Build a @Nothing@ expression of the given (monomorphic) @Maybe elemTy@+-- type, with its type variable instantiated to @elemTy@.+--+-- 'nlHsDataCon nothingDataCon' on its own is @Nothing :: forall a. Maybe a@:+-- the un-instantiated @forall@ makes the @ifMutation \@ty@ wrapper the+-- framework builds around it ill-typed (its argument is expected at @Maybe+-- elemTy@ but is @forall a. Maybe a@).  GHC's Core Lint rejects that; with+-- Core Lint off the desugared program miscompiles the whole instrumented site+-- and segfaults at runtime (entering a null closure via @stg_ap_0_fast@).+-- Applying the element type keeps the Core well-typed — mirroring how+-- 'ConstEmptyList' threads its element type through @ExplicitList elTy []@.+mkNothingExpr :: Type -> LHsExpr GhcTc+mkNothingExpr mayTy = case splitTyConApp_maybe mayTy of+  Just (_, [elemTy]) -> nlHsTyApp (dataConWrapId nothingDataCon) [elemTy]+  -- Callers only ever pass a saturated @Maybe elemTy@ (MaybeOp matched a+  -- @Just e@; ConstNothing already checked the result tycon is @Maybe@).  Fail+  -- loudly on any other type rather than silently emitting the un-instantiated+  -- @Nothing :: forall a. Maybe a@, whose ill-typed Core is the very bug this+  -- helper exists to avoid.+  _ -> pprPanic "mkNothingExpr: expected a saturated 'Maybe elemTy' type" (ppr mayTy)++-- | Peel as many @arg -> rest@ arrows as possible from the type, returning+-- the argument types and the final result type.  Stops at any+-- non-arrow type (including constrained types).+peelArrows :: Type -> ([Type], Type)+peelArrows = go []+  where+    go acc ty = case splitFunTy_maybe ty of+      Just (_af, _mult, argTy, resTy) -> go (argTy : acc) resTy+      Nothing -> (reverse acc, ty)++-- | Reject expressions whose outermost head is a data constructor at GhcTc+-- ('ConLikeTc' / a 'HsConLikeOut'-style node).  Peels through 'HsApp',+-- 'HsAppType', 'HsPar', 'WrapExpr', and 'ExpandedThingTc' wrappers.+nonConstructorHead :: LHsExpr GhcTc -> Maybe ()+nonConstructorHead = go+  where+    go h = case unLoc h of+      XExpr (ConLikeTc {}) -> Nothing+      HsApp _ f _ -> go f+      HsAppType _ f _ -> go f+      HsPar _ e -> go e+      XExpr (WrapExpr (HsWrap _ e)) -> go (L (getLoc h) e)+      XExpr (ExpandedThingTc _ e) -> go (L (getLoc h) e)+      _ -> Just ()++-- | Build @\\_ _ ... _ -> v@ at GhcTc.  @v@ must already have type @resTy@;+-- the resulting lambda has type @arg1 -> ... -> argN -> resTy@.+--+-- For arity 0 (empty @argTys@) this is the identity on @v@.+--+-- Used by the @Const…@ family of operators to produce a constant-function+-- mutant without depending on @Prelude.const@ being in scope.  All+-- annotation/origin fields are filled with neutral defaults so the desugarer+-- accepts the result and the pattern-match checker does not complain about+-- the wildcards.+mkConstLambda ::+  -- | Argument types, in source order: @[arg1, arg2, ..., argN]@.+  [Type] ->+  -- | Result type of @v@.+  Type ->+  -- | The bare value to wrap.+  LHsExpr GhcTc ->+  LHsExpr GhcTc+mkConstLambda [] _ body = body+mkConstLambda argTys resTy body =+  let pats = map (\ty -> noLocA (WildPat ty)) argTys+      grhs = noLocA (GRHS noAnn [] body)+      grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds NoExtField)+      ctxt = LamAlt LamSingle+      match = noLocA (Match [] ctxt pats grhss)+      mgtc =+        MatchGroupTc+          { mg_arg_tys = map (Scaled manyDataConTy) argTys,+            mg_res_ty = resTy,+            mg_origin = Generated OtherExpansion SkipPmc+          }+      mg = MG mgtc (noLocA [match])+   in noLocA (HsLam [] LamSingle mg)++-- | Build an arrow type @arg1 -> ... -> argN -> resTy@ with default (Many)+-- multiplicity.+arrowTy :: [Type] -> Type -> Type+arrowTy as resTy = foldr mkVisFunTyMany resTy as++-- | Build a prefix-form preview text for an arity-N constant-function+-- mutation that sits at an infix operator position.+--+-- Given operand source text and a mutant rendering, produces text that+-- replaces the whole enclosing @OpApp@ source span in prefix form:+--+--   arity 2:  @(\\_ _ -> v) (lhsText) (rhsText)@+--   arity 1:  @(\\_ -> v) (rhsText)@           — the partial app+--                                              consumed the LHS already.+--+-- The result reparses as a normal Haskell expression and has the same+-- runtime semantics as the AST mutation, so the manifest diff is honest.+prefixFormPreview ::+  -- | Arity of the constant function being inserted.+  Int ->+  -- | Source text of the constant body (e.g. @"True"@, @"Nothing"@, @"[]"@).+  Text ->+  -- | Source text of the LHS operand of the infix @OpApp@.+  Text ->+  -- | Source text of the RHS operand of the infix @OpApp@.+  Text ->+  Text+prefixFormPreview arity vText lhsText rhsText =+  let lam =+        "(\\"+          <> T.replicate arity "_ "+          <> "-> "+          <> vText+          <> ")"+   in case arity of+        2 -> lam <> " (" <> lhsText <> ") (" <> rhsText <> ")"+        1 -> lam <> " (" <> rhsText <> ")"+        _ -> lam++-- | The value arguments of a prefix application, in source order, together+-- with the function at the head.+--+-- The head is returned intact, retaining the type- and dictionary-application+-- wrappers the typechecker attached to it, so reapplying it to (possibly+-- mutated) arguments stays well-typed.+--+-- We deliberately do /not/ peel an enclosing 'HsPar': the parenthesis node+-- @(f a b)@ and the inner application @f a b@ are visited as separate+-- expressions by the walker (which recurses into an 'HsPar' with+-- 'instrumentLExpr', re-running every operator).  Peeling here would make an+-- operator fire on both nodes.  Stopping at the 'HsPar' means only the inner+-- application produces the mutation.+collectApp :: LHsExpr GhcTc -> (LHsExpr GhcTc, [LHsExpr GhcTc])+collectApp = go []+  where+    go acc le = case unLoc le of+      HsApp _ f a -> go (a : acc) f+      _ -> (le, acc)++-- | The 'Name' of the function (or constructor) at the head of an+-- application, peeling the type- and dictionary-application wrappers the+-- typechecker leaves around the 'HsVar'.  'Nothing' for heads that are not a+-- plain variable (e.g. a lambda or a data constructor at 'ConLikeTc').+headFunctionName :: LHsExpr GhcTc -> Maybe Name+headFunctionName = go+  where+    go le = case unLoc le of+      HsVar _ (L _ v) -> Just (idName v)+      XExpr (WrapExpr (HsWrap _ e)) -> go (noLocA e)+      HsAppType _ f _ -> go f+      HsPar _ e -> go e+      _ -> Nothing++-- | The strings a @skip-calls-to@ or @ignore@ entry may use to refer to a+-- name: the bare occurrence (@union@), the fully-qualified form using the+-- name's /defining/ module (@Data.Set.Internal.union@), and the+-- fully-qualified forms using each module the name is /imported through/ at+-- this use site (@Data.Set.union@).  Including the import modules lets a user+-- qualify a re-exported function by the module they actually import it from,+-- not only by the internal module it happens to be defined in.+nameMatchCandidates :: GlobalRdrEnv -> Name -> [Text]+nameMatchCandidates rdrEnv n =+  let occ = T.pack (getOccString n)+      definingMods = maybe [] (\m -> [moduleName m]) (nameModule_maybe n)+      importMods = case lookupGRE_Name rdrEnv n of+        Just gre -> map importSpecModule (bagToList (gre_imp gre))+        Nothing -> []+      qualify m = T.pack (moduleNameString m) <> "." <> occ+   in occ : map qualify (nub (definingMods ++ importMods))++-- | The exact source text covered by a 'RealSrcSpan'.  Multi-line spans are+-- joined with single spaces, which is enough for the no-op comparison and the+-- manifest summary.+spanText :: [Text] -> RealSrcSpan -> Text+spanText allLines rss =+  let startLine = srcSpanStartLine rss+      endLine = srcSpanEndLine rss+      colS = srcSpanStartCol rss+      colE = srcSpanEndCol rss+      lineN i = case drop (i - 1) allLines of+        (l : _) -> l+        [] -> T.empty+   in if startLine == endLine+        then T.take (colE - colS) (T.drop (colS - 1) (lineN startLine))+        else+          let firstPart = T.drop (colS - 1) (lineN startLine)+              middleParts = map lineN [startLine + 1 .. endLine - 1]+              lastPart = T.take (colE - 1) (lineN endLine)+           in T.intercalate " " (firstPart : middleParts ++ [lastPart])
+ src/Test/Syd/Mutation/Plugin/Operators.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Registry of all mutation operators.+--+-- To add a new operator:+--   1. Create @Test.Syd.Mutation.Plugin.Operator.<Name>@ exporting+--      @theOperator :: MutationOperator@.+--   2. Add one @import qualified@ line for it below.+--+-- The @allOperators@ list is assembled automatically from the operator+-- directory at compile time; only the import needs to be added by hand.+module Test.Syd.Mutation.Plugin.Operators (allOperators) where++import Test.Syd.Mutation.Plugin.Instrument (MutationOperator)+import qualified Test.Syd.Mutation.Plugin.Operator.Arith+import qualified Test.Syd.Mutation.Plugin.Operator.BoolLit+import qualified Test.Syd.Mutation.Plugin.Operator.Cmp+import qualified Test.Syd.Mutation.Plugin.Operator.ConstBool+import qualified Test.Syd.Mutation.Plugin.Operator.ConstEmptyList+import qualified Test.Syd.Mutation.Plugin.Operator.ConstNothing+import qualified Test.Syd.Mutation.Plugin.Operator.ElideCall+import qualified Test.Syd.Mutation.Plugin.Operator.IntLit+import qualified Test.Syd.Mutation.Plugin.Operator.ListLit+import qualified Test.Syd.Mutation.Plugin.Operator.LogicOp+import qualified Test.Syd.Mutation.Plugin.Operator.MaybeOp+import qualified Test.Syd.Mutation.Plugin.Operator.Negate+import qualified Test.Syd.Mutation.Plugin.Operator.RemoveAction+import qualified Test.Syd.Mutation.Plugin.Operator.RemoveCase+import qualified Test.Syd.Mutation.Plugin.Operator.RemoveClause+import qualified Test.Syd.Mutation.Plugin.Operator.SwitchFunctionArguments+import qualified Test.Syd.Mutation.Plugin.Operator.TupleSwap+import Test.Syd.Mutation.Plugin.Operators.TH (collectOperators)++allOperators :: [MutationOperator]+allOperators = $(collectOperators)
+ src/Test/Syd/Mutation/Plugin/Operators/TH.hs view
@@ -0,0 +1,36 @@+module Test.Syd.Mutation.Plugin.Operators.TH (collectOperators) where++import Control.Monad (forM)+import Data.List (isPrefixOf, isSuffixOf, sort)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (addDependentFile)+import System.Directory (listDirectory)+import System.FilePath (dropExtension, takeFileName)++-- | Scan the @Operator/@ sibling directory at splice time and produce a list+-- expression of all @theOperator@ values found there.+--+-- Each operator module must be imported (qualified) in the calling module so+-- GHC can resolve the names.  The TH splice builds the list automatically so+-- that only the import line needs to be added when a new operator is created —+-- the @allOperators@ value updates itself.+collectOperators :: Q Exp+collectOperators = do+  loc <- location+  let thisFile = loc_filename loc+      -- .../Plugin/Operators/TH.hs -> .../Plugin/Operator/+      pluginDir = reverse $ dropWhile (/= '/') $ reverse $ reverse $ dropWhile (/= '/') $ reverse thisFile+      operatorDir = pluginDir ++ "Operator"+  files <- runIO $ do+    entries <- listDirectory operatorDir+    -- Exclude helper modules that don't export theOperator (e.g. Util.hs).+    let operatorFiles f =+          not ("." `isPrefixOf` f)+            && ".hs" `isSuffixOf` f+            && f /= "Util.hs"+    pure $ sort $ filter operatorFiles entries+  mapM_ (addDependentFile . (\f -> operatorDir ++ "/" ++ f)) files+  operatorExprs <- forM files $ \file -> do+    let modName = "Test.Syd.Mutation.Plugin.Operator." ++ dropExtension (takeFileName file)+    varE (mkName (modName ++ ".theOperator"))+  listE (map pure operatorExprs)
+ src/Test/Syd/Mutation/Plugin/OptParse.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Syd.Mutation.Plugin.OptParse+  ( Settings (..),+    OperatorConfig (..),+    operatorsConfigDisabled,+    operatorExtraFlag,+    operatorExtraStrings,+    defaultSettings,+    parseSettings,+    resolveSettings,+  )+where++import Data.Aeson (Object, Value (..))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Foldable (toList)+import Data.List.NonEmpty (NonEmpty)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import OptEnvConf+import qualified OptEnvConf.Args as Args+import qualified OptEnvConf.EnvMap as EnvMap+import OptEnvConf.Error (ParseError, renderErrors)+import Path+import System.Environment (getEnvironment)+import qualified Text.Colour as Colour++-- | Plugin settings.  One coherent record covering every input source:+--+-- * @--<name>=VALUE@ flags supplied by GHC's plugin-option mechanism,+-- * @MUTATION_PLUGIN_<NAME>@ environment variables,+-- * keys in the YAML file referenced by @--config=PATH@.+--+-- See 'settingsParser' for the source breakdown of each field.+data Settings = Settings+  { -- | Manifest output directory (one JSON file per module written here).+    -- Optional — when absent, the plugin instruments but does not write a+    -- manifest (useful in coverage-only runs).+    settingManifestDir :: !(Maybe (Path Abs Dir)),+    -- | Runtime kill switch: when true, the plugin loads but instruments+    -- nothing.  Set by the Nix two-stage build for the post-library build+    -- phase (see @nix/addManifest.nix@).+    settingSkipInstrumentation :: !Bool,+    -- | Module names to skip during instrumentation.+    settingExceptions :: ![String],+    -- | Mutation operator names disabled globally.+    settingDisabledMutations :: ![String],+    -- | Identifier names whose calls (and argument subtrees) the plugin+    -- leaves untouched.  Each name matches either bare (e.g. @logDebug@,+    -- matching any module) or fully qualified (e.g.+    -- @Control.Monad.Logger.logDebug@); a qualifier may be either the+    -- function's defining module or a module it is imported through.  See+    -- 'Test.Syd.Mutation.Plugin.Instrument' for how this is consumed.+    settingIgnore :: ![String],+    -- | Skip mutations inside TH splices and quasi-quotes.+    settingSkipThSplices :: !Bool,+    -- | Per-operator configuration, keyed by operator name, read from the+    -- @operators@ config object.+    settingOperators :: !(Map Text OperatorConfig),+    -- | Print each mutation site as it is recorded.+    settingDebug :: !Bool+  }+  deriving (Show, Eq, Generic)++-- | Configuration for a single mutation operator, read from one entry of+-- the @operators@ config object:+--+-- > operators:+-- >   ConstEmptyList:+-- >     enable: true+-- >     skip-strings: true+-- >   Arith:+-- >     enable: false+--+-- @enable@ is common to every operator; the remaining keys are an opaque+-- 'operatorConfigExtra' blob that each operator interprets itself (e.g.+-- @ConstEmptyList@ reads @skip-strings@).  An operator absent from the+-- config behaves as @enable: true@ with no extra.+data OperatorConfig = OperatorConfig+  { -- | Whether the operator runs.  @enable: false@ disables it exactly as+    -- if its name were in @disabled-mutations@.+    operatorConfigEnable :: !Bool,+    -- | Operator-specific config keys (everything under the operator other+    -- than @enable@), interpreted by the operator.+    operatorConfigExtra :: !(Map Text Value)+  }+  deriving (Show, Eq, Generic)++-- | Names of operators that 'OperatorConfig' explicitly disables.+operatorsConfigDisabled :: Map Text OperatorConfig -> [String]+operatorsConfigDisabled m =+  [T.unpack opName | (opName, cfg) <- Map.toList m, not (operatorConfigEnable cfg)]++-- | Read a boolean flag from an operator's 'operatorConfigExtra', defaulting+-- to 'False'.  A small helper for operators interpreting their own config.+operatorExtraFlag :: Text -> Map Text Value -> Bool+operatorExtraFlag k m = case Map.lookup k m of+  Just (Bool b) -> b+  _ -> False++-- | Read a list-of-strings key from an operator's 'operatorConfigExtra',+-- defaulting to the empty list.  Accepts a YAML/JSON array of strings; any+-- non-string elements are ignored.  Used by operators that take a list of+-- function names (e.g. 'SwitchFunctionArguments' reads @skip-calls-to@).+operatorExtraStrings :: Text -> Map Text Value -> [Text]+operatorExtraStrings k m = case Map.lookup k m of+  Just (Array arr) -> [t | String t <- toList arr]+  _ -> []++-- | Decode the raw @operators@ config object into a per-operator map.+decodeOperatorsConfig :: Object -> Map Text OperatorConfig+decodeOperatorsConfig obj =+  Map.fromList+    [(Key.toText k, decodeOperatorConfig v) | (k, v) <- KeyMap.toList obj]+  where+    decodeOperatorConfig :: Value -> OperatorConfig+    decodeOperatorConfig = \case+      Object o ->+        OperatorConfig+          { operatorConfigEnable = case KeyMap.lookup "enable" o of+              Just (Bool b) -> b+              _ -> True,+            operatorConfigExtra =+              Map.fromList+                [(Key.toText k, val) | (k, val) <- KeyMap.toList o, k /= "enable"]+          }+      _ -> OperatorConfig {operatorConfigEnable = True, operatorConfigExtra = Map.empty}++-- | The settings the plugin uses when no @--config=PATH@ is passed and+-- no environment variables are set.  Equivalent to running the parser+-- with empty args, empty env, and no config object.+defaultSettings :: Settings+defaultSettings =+  Settings+    { settingManifestDir = Nothing,+      settingSkipInstrumentation = False,+      settingExceptions = [],+      settingDisabledMutations = [],+      settingIgnore = [],+      settingSkipThSplices = True,+      settingOperators = Map.empty,+      settingDebug = False+    }++-- | Resolve plugin settings from GHC's plugin opts and the process+-- environment.  Reads any YAML referenced by @--config=PATH@.  Errors+-- out with a rendered opt-env-conf error message on parse failure —+-- better than silently using defaults.+resolveSettings :: [String] -> IO Settings+resolveSettings opts = do+  envPairs <- getEnvironment+  let args = Args.parseArgs opts+      envMap = EnvMap.parse envPairs+  result <- runParserOn allCapabilities Nothing (settingsParser :: Parser Settings) args envMap Nothing+  case result of+    Right s -> pure s+    Left errs ->+      ioError $+        userError $+          "mutation: failed to parse plugin settings:\n"+            ++ renderParseErrors errs++renderParseErrors :: NonEmpty ParseError -> String+renderParseErrors =+  T.unpack . Colour.renderChunksText Colour.WithoutColours . renderErrors++instance HasParser Settings where+  settingsParser = withLocalYamlConfig parseSettings++-- | Field-by-field parser.  Does not include 'withYamlConfig', so callers+-- (and tests) can supply the conf object directly.+parseSettings :: Parser Settings+parseSettings =+  subEnv_ "mutation_plugin" $ do+    settingManifestDir <-+      optional $+        directoryPathSetting+          [ help "Manifest output directory (one JSON file per instrumented module)",+            option,+            long "manifest",+            env "MANIFEST_DIR",+            metavar "DIR"+          ]+    settingSkipInstrumentation <-+      setting+        [ help "When set, load the plugin but instrument nothing.  Used by the Nix two-stage build.",+          switch True,+          long "skip",+          reader exists,+          env "SKIP",+          metavar "ANY",+          value False+        ]+    settingExceptions <-+      setting+        [ help "Module names to skip during instrumentation",+          reader $ eitherReader (Right . splitComma),+          option,+          long "exceptions",+          env "EXCEPTIONS",+          conf "exceptions",+          metavar "NAME,NAME,...",+          value []+        ]+    settingDisabledMutations <-+      setting+        [ help "Mutation operator names to disable globally",+          reader $ eitherReader (Right . splitComma),+          option,+          long "disabled-mutations",+          env "DISABLED_MUTATIONS",+          conf "disabled-mutations",+          metavar "NAME,NAME,...",+          value []+        ]+    settingIgnore <-+      setting+        [ help "Unqualified identifier names whose calls (and argument subtrees) are left untouched",+          reader $ eitherReader (Right . splitComma),+          option,+          long "ignore",+          env "IGNORE",+          conf "ignore",+          metavar "NAME,NAME,...",+          value []+        ]+    settingSkipThSplices <-+      yesNoSwitch+        [ help "Skip mutations inside Template Haskell splices and quasi-quotes",+          long "skip-th-splices",+          env "SKIP_TH_SPLICES",+          conf "skip-th-splices",+          value True+        ]+    settingOperators <-+      maybe Map.empty decodeOperatorsConfig+        <$> optional+          ( setting+              [ help "Per-operator config object: operators.<Name>.{enable, <operator-specific keys>}",+                conf "operators"+              ]+          )+    settingDebug <-+      yesNoSwitch+        [ help "Print each mutation site as it is recorded",+          long "debug",+          env "DEBUG",+          conf "debug",+          value False+        ]+    pure Settings {..}++splitComma :: String -> [String]+splitComma s = case break (== ',') s of+  (w, []) -> [w]+  (w, _ : rest) -> w : splitComma rest
+ src/Test/Syd/Mutation/Plugin/Runtime.hs view
@@ -0,0 +1,3 @@+module Test.Syd.Mutation.Plugin.Runtime (ifMutation, MutationId (..)) where++import Test.Syd.Mutation.Runtime (MutationId (..), ifMutation)
+ sydtest-mutation-plugin.cabal view
@@ -0,0 +1,97 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.3.+--+-- see: https://github.com/sol/hpack++name:           sydtest-mutation-plugin+version:        0.4.4.0+synopsis:       GHC plugin that instruments code for sydtest's mutation testing+description:    A GHC source plugin that instruments code under test with the coverage and mutation hooks that sydtest's mutation testing infrastructure needs. See https://github.com/NorfairKing/sydtest#readme for more information.+category:       Testing+homepage:       https://github.com/NorfairKing/sydtest#readme+bug-reports:    https://github.com/NorfairKing/sydtest/issues+author:         Tom Sydney Kerckhove+maintainer:     syd@cs-syd.eu+license:        OtherLicense+license-file:   LICENSE.md+build-type:     Simple+extra-source-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/NorfairKing/sydtest++library+  exposed-modules:+      Test.Syd.Mutation.Plugin+      Test.Syd.Mutation.Plugin.Instrument+      Test.Syd.Mutation.Plugin.Operator.Arith+      Test.Syd.Mutation.Plugin.Operator.BoolLit+      Test.Syd.Mutation.Plugin.Operator.Cmp+      Test.Syd.Mutation.Plugin.Operator.ConstBool+      Test.Syd.Mutation.Plugin.Operator.ConstEmptyList+      Test.Syd.Mutation.Plugin.Operator.ConstNothing+      Test.Syd.Mutation.Plugin.Operator.ElideCall+      Test.Syd.Mutation.Plugin.Operator.IntLit+      Test.Syd.Mutation.Plugin.Operator.ListLit+      Test.Syd.Mutation.Plugin.Operator.LogicOp+      Test.Syd.Mutation.Plugin.Operator.MaybeOp+      Test.Syd.Mutation.Plugin.Operator.Negate+      Test.Syd.Mutation.Plugin.Operator.RemoveAction+      Test.Syd.Mutation.Plugin.Operator.RemoveCase+      Test.Syd.Mutation.Plugin.Operator.RemoveClause+      Test.Syd.Mutation.Plugin.Operator.SwitchFunctionArguments+      Test.Syd.Mutation.Plugin.Operator.TupleSwap+      Test.Syd.Mutation.Plugin.Operator.Util+      Test.Syd.Mutation.Plugin.Operators+      Test.Syd.Mutation.Plugin.Operators.TH+      Test.Syd.Mutation.Plugin.OptParse+      Test.Syd.Mutation.Plugin.Runtime+  other-modules:+      Paths_sydtest_mutation_plugin+  hs-source-dirs:+      src+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , containers+    , directory+    , filepath+    , ghc+    , ghc-boot+    , mtl+    , opt-env-conf+    , path+    , path-io+    , safe-coloured-text+    , sydtest-mutation-runtime >=0.1+    , template-haskell+    , text+  default-language: Haskell2010++test-suite sydtest-mutation-plugin-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Test.Syd.Mutation.Plugin.InstrumentSpec+      Test.Syd.Mutation.Plugin.OptParseSpec+      Paths_sydtest_mutation_plugin+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:+      sydtest-discover:sydtest-discover+  build-depends:+      aeson+    , base >=4.7 && <5+    , containers+    , ghc+    , opt-env-conf-test+    , path+    , sydtest+    , sydtest-mutation-plugin+    , text+  default-language: Haskell2010
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
+ test/Test/Syd/Mutation/Plugin/InstrumentSpec.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Plugin.InstrumentSpec (spec) where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import GHC.Data.FastString (mkFastString)+import GHC.Types.SrcLoc+import Test.Syd+import Test.Syd.Mutation.Plugin.Instrument++mkSpan :: Int -> Int -> Int -> Int -> RealSrcSpan+mkSpan startLine startCol endLine endCol =+  mkRealSrcSpan+    (mkRealSrcLoc (mkFastString "test.hs") startLine startCol)+    (mkRealSrcLoc (mkFastString "test.hs") endLine endCol)++spec :: Spec+spec = do+  describe "parseFunMutationAnns" $ do+    it "parses no annotations as no self-disable and no local disables" $+      parseFunMutationAnns []+        `shouldBe` FunMutationAnns (DisableOps []) Map.empty++    it "parses DisableMutations as self DisableAllOps" $+      parseFunMutationAnns ["DisableMutations"]+        `shouldBe` FunMutationAnns DisableAllOps Map.empty++    it "parses DisableMutations: A, B as self DisableOps [A,B]" $+      parseFunMutationAnns ["DisableMutations: BoolLit, ConstBool"]+        `shouldBe` FunMutationAnns (DisableOps ["BoolLit", "ConstBool"]) Map.empty++    it "parses DisableMutation: A as self DisableOps [A]" $+      parseFunMutationAnns ["DisableMutation: BoolLit"]+        `shouldBe` FunMutationAnns (DisableOps ["BoolLit"]) Map.empty++    it "parses DisableMutationsFor <name> as a local DisableAllOps entry" $+      parseFunMutationAnns ["DisableMutationsFor innerVar"]+        `shouldBe` FunMutationAnns+          (DisableOps [])+          (Map.singleton "innerVar" DisableAllOps)++    it "parses DisableMutationsFor <name>: A, B as a local DisableOps entry" $+      parseFunMutationAnns ["DisableMutationsFor innerVar: BoolLit, ConstBool"]+        `shouldBe` FunMutationAnns+          (DisableOps [])+          (Map.singleton "innerVar" (DisableOps ["BoolLit", "ConstBool"]))++    it "parses DisableMutationFor <name>: A as a local DisableOps [A] entry" $+      parseFunMutationAnns ["DisableMutationFor innerVar: BoolLit"]+        `shouldBe` FunMutationAnns+          (DisableOps [])+          (Map.singleton "innerVar" (DisableOps ["BoolLit"]))++    it "combines a self disable with a local disable" $+      parseFunMutationAnns+        [ "DisableMutations: BoolLit",+          "DisableMutationsFor innerVar: ConstBool"+        ]+        `shouldBe` FunMutationAnns+          (DisableOps ["BoolLit"])+          (Map.singleton "innerVar" (DisableOps ["ConstBool"]))++    it "merges two local disables for the same name into a combined DisableOps" $+      parseFunMutationAnns+        [ "DisableMutationFor innerVar: BoolLit",+          "DisableMutationFor innerVar: ConstBool"+        ]+        `shouldBe` FunMutationAnns+          (DisableOps [])+          (Map.singleton "innerVar" (DisableOps ["BoolLit", "ConstBool"]))++    it "merges a local DisableAllOps with a local DisableOps to DisableAllOps" $+      parseFunMutationAnns+        [ "DisableMutationsFor innerVar",+          "DisableMutationFor innerVar: BoolLit"+        ]+        `shouldBe` FunMutationAnns+          (DisableOps [])+          (Map.singleton "innerVar" DisableAllOps)++    it "keeps two distinct local-binding entries side by side" $+      parseFunMutationAnns+        [ "DisableMutationsFor a",+          "DisableMutationsFor b: BoolLit"+        ]+        `shouldBe` FunMutationAnns+          (DisableOps [])+          (Map.fromList [("a", DisableAllOps), ("b", DisableOps ["BoolLit"])])++    it "ignores unrelated annotation strings" $+      parseFunMutationAnns+        [ "Not a mutation annotation",+          "DisableMutationsFor innerVar: BoolLit"+        ]+        `shouldBe` FunMutationAnns+          (DisableOps [])+          (Map.singleton "innerVar" (DisableOps ["BoolLit"]))++    it "ignores a DisableMutationsFor with an empty name" $+      parseFunMutationAnns ["DisableMutationsFor "]+        `shouldBe` FunMutationAnns (DisableOps []) Map.empty++  describe "deadDisableTargets" $ do+    it "reports nothing when there are no declared targets" $+      deadDisableTargets Map.empty (Set.fromList ["a", "b"])+        `shouldBe` []++    it "reports a declared target that was never consumed" $+      deadDisableTargets+        (Map.singleton "innerVar" DisableAllOps)+        Set.empty+        `shouldBe` ["innerVar"]++    it "reports nothing when the declared target was consumed" $+      deadDisableTargets+        (Map.singleton "innerVar" DisableAllOps)+        (Set.singleton "innerVar")+        `shouldBe` []++    it "reports only the unconsumed targets" $+      deadDisableTargets+        (Map.fromList [("a", DisableAllOps), ("b", DisableOps ["BoolLit"]), ("c", DisableAllOps)])+        (Set.fromList ["b"])+        `shouldBe` ["a", "c"]++    it "ignores consumed names that were never declared" $+      deadDisableTargets+        (Map.singleton "a" DisableAllOps)+        (Set.fromList ["a", "x", "y"])+        `shouldBe` []++  describe "applySpanRemoval" $ do+    it "removes the requested lines from a multi-line outer span" $+      applySpanRemoval+        ["one", "two", "three", "four"]+        1+        4+        [mkSpan 2 1 2 4]+        `shouldBe` ["one", "three", "four"]++    it "does not crash when the outer span extends past the end of allLines" $+      -- This reproduces the crash from a -pgmF preprocessor (e.g. sydtest-discover):+      -- the on-disk source file has only 1 line, but GHC's source spans refer to+      -- the generated source which is many lines longer.+      applySpanRemoval+        ["only one on-disk line"]+        1+        13+        [mkSpan 5 1 5 10]+        `shouldBe` ["only one on-disk line"]++    it "does not crash when outerStart is past the end of allLines" $+      applySpanRemoval+        ["one", "two"]+        10+        15+        [mkSpan 12 1 12 5]+        `shouldBe` []++    it "returns an empty list when there are no lines to keep" $+      applySpanRemoval+        ["one", "two", "three"]+        1+        3+        [mkSpan 1 1 3 5]+        `shouldBe` []++    it "handles multiple removed spans" $+      applySpanRemoval+        (map T.pack ["a", "b", "c", "d", "e"])+        1+        5+        [mkSpan 2 1 2 2, mkSpan 4 1 4 2]+        `shouldBe` ["a", "c", "e"]++  describe "applySwapSpans" $ do+    it "swaps two single-line arguments of a prefix application" $+      -- "foo aaa bbb", swapping "aaa" (cols 5-8) and "bbb" (cols 9-12).+      applySwapSpans+        ["foo aaa bbb"]+        1+        1+        1+        12+        (mkSpan 1 5 1 8)+        (mkSpan 1 9 1 12)+        `shouldBe` ["foo bbb aaa"]++    it "swaps regardless of the order the spans are given in" $+      applySwapSpans+        ["foo aaa bbb"]+        1+        1+        1+        12+        (mkSpan 1 9 1 12)+        (mkSpan 1 5 1 8)+        `shouldBe` ["foo bbb aaa"]++    it "preserves text before and after the matched expression" $+      -- "  r = foo aaa bbb", the application spans cols 7-18.+      applySwapSpans+        ["  r = foo aaa bbb"]+        1+        1+        7+        18+        (mkSpan 1 11 1 14)+        (mkSpan 1 15 1 18)+        `shouldBe` ["  r = foo bbb aaa"]++    it "keeps a non-swapped middle argument in place" $+      -- "f aa bb cc", swapping the outer two ("aa" cols 3-5, "cc" cols 9-11).+      applySwapSpans+        ["f aa bb cc"]+        1+        1+        1+        11+        (mkSpan 1 3 1 5)+        (mkSpan 1 9 1 11)+        `shouldBe` ["f cc bb aa"]
+ test/Test/Syd/Mutation/Plugin/OptParseSpec.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Test.Syd.Mutation.Plugin.OptParseSpec (spec) where++import qualified Data.Aeson as JSON+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Map as Map+import OptEnvConf.Test+import Path+import Test.Syd+import Test.Syd.Mutation.Plugin.OptParse++spec :: Spec+spec = describe "Settings parser" $ do+  settingsLintSpec @Settings++  it "produces defaults from empty inputs" $+    settingsParserTest @Settings [] [] Nothing defaultSettings++  it "reads 'ignore' from --ignore=A,B" $+    settingsParserTest @Settings+      ["--ignore=logDebug,logInfo"]+      []+      Nothing+      defaultSettings {settingIgnore = ["logDebug", "logInfo"]}++  it "reads 'ignore' from MUTATION_PLUGIN_IGNORE" $+    settingsParserTest @Settings+      []+      [("MUTATION_PLUGIN_IGNORE", "logDebug,logInfo")]+      Nothing+      defaultSettings {settingIgnore = ["logDebug", "logInfo"]}++  it "reads --skip" $+    settingsParserTest @Settings+      ["--skip"]+      []+      Nothing+      defaultSettings {settingSkipInstrumentation = True}++  it "reads MUTATION_PLUGIN_MANIFEST_DIR" $ do+    dir <- parseAbsDir "/tmp/foo/"+    settingsParserTest @Settings+      []+      [("MUTATION_PLUGIN_MANIFEST_DIR", "/tmp/foo/")]+      Nothing+      defaultSettings {settingManifestDir = Just dir}++  it "reads per-operator enable and operator-specific extra from 'operators'" $ do+    -- operators:+    --   Arith: { enable: false }+    --   ConstEmptyList: { skip-strings: true }+    let operatorsObject =+          KeyMap.fromList+            [ ("Arith", JSON.Object (KeyMap.fromList [("enable", JSON.Bool False)])),+              ("ConstEmptyList", JSON.Object (KeyMap.fromList [("skip-strings", JSON.Bool True)]))+            ]+        config = KeyMap.fromList [("operators", JSON.Object operatorsObject)]+        expectedOperators =+          Map.fromList+            [ ("Arith", OperatorConfig {operatorConfigEnable = False, operatorConfigExtra = Map.empty}),+              ( "ConstEmptyList",+                OperatorConfig+                  { operatorConfigEnable = True,+                    operatorConfigExtra = Map.fromList [("skip-strings", JSON.Bool True)]+                  }+              )+            ]+    -- Test 'parseSettings' directly: 'settingsParser' wraps it in+    -- 'withLocalYamlConfig', which loads config from a file rather than the+    -- object supplied here.+    parserTest+      parseSettings+      []+      []+      (Just config)+      defaultSettings {settingOperators = expectedOperators}+    -- And the consumed views: Arith disabled, ConstEmptyList skip-strings on.+    operatorsConfigDisabled expectedOperators `shouldBe` ["Arith"]+    operatorExtraFlag "skip-strings" (operatorConfigExtra (expectedOperators Map.! "ConstEmptyList"))+      `shouldBe` True++  it "reads a list-of-strings operator key with operatorExtraStrings" $ do+    let extra = Map.fromList [("skip-calls-to", JSON.toJSON (["max", "min"] :: [String]))]+    operatorExtraStrings "skip-calls-to" extra `shouldBe` ["max", "min"]+    -- A missing key and a non-array value both yield the empty list.+    operatorExtraStrings "absent" extra `shouldBe` []+    operatorExtraStrings "skip-calls-to" (Map.fromList [("skip-calls-to", JSON.Bool True)])+      `shouldBe` []