sydtest-mutation-plugin 0.4.6.0 → 0.5.0.0

raw patch · 9 files changed

+1301/−306 lines, 9 files

Files

• CHANGELOG.md +36/−0
• src/Test/Syd/Mutation/Plugin.hs +247/−98
• src/Test/Syd/Mutation/Plugin/Instrument.hs +572/−146
• src/Test/Syd/Mutation/Plugin/Operator/ConstConstructor.hs +6/−3
• src/Test/Syd/Mutation/Plugin/Operator/ConstEmptyList.hs +26/−3
• src/Test/Syd/Mutation/Plugin/Operator/ListLit.hs +69/−29
• sydtest-mutation-plugin.cabal +2/−1
• test/Test/Syd/Mutation/Plugin/InstrumentSpec.hs +212/−26
• test/Test/Syd/Mutation/PluginSpec.hs +131/−0

@@ -1,5 +1,30 @@ # Changelog +## [0.5.0.0] - 2026-09-11++### Added++* A mutation-disable annotation that disables nothing is now a compile error,+  whether it annotates a module, a binding, or a local binding of one.+* An annotation naming something that is not a mutation operator says so, and+  lists the operators.+* An annotation naming `Control` among the operators it disables says that a+  control is only inserted where an operator fires, so naming it takes nothing+  away.+* A `DisableMutation`-prefixed annotation string that parses as none of the+  recognised forms is an error rather than being ignored, which includes+  `DisableMutationFor <name>` with no operator after it.+* Judging a module-level disable walks the module and throws the result away,+  so a module whose instrumentation misbehaves belongs in `exceptions` rather+  than behind the annotation.++### Fixed++* `debug` now controls the per-mutation printing it documents; it was read+  into the instrumentation environment and never consulted, so every+  instrumented build printed a line per mutation.++ ## [0.4.6.0] - 2026-07-29  ### Added@@ -13,6 +38,17 @@   it.  The definition itself is still mutated: the key skips calls.  ### Fixed++* Interface pragmas are no longer ignored while instrumenting.  `-O0` implies+  `-fignore-interface-pragmas`, which drops unfoldings as interfaces are read,+  and instrumented builds are compiled at `-O0` on purpose — so the+  constructor-alias recognition below silently did nothing in exactly the+  configuration mutation testing runs in.  It only appeared to work in this+  repo's own example because the overlay adds `--ghc-options=-O2` to every+  package here, which overrode `addManifest`'s `--disable-optimization`;+  `addManifest` now passes `-O0` last so that no longer happens, and the+  example exercises the real configuration.  Reading unfoldings does not run+  the simplifier, so the compile-time blowup `-O0` avoids does not come back.  * `ConstConstructor` no longer replaces a binding that is defined as a nullary   constructor with that same constructor.  `Data.Map.empty` is `Tip`, so

@@ -1,23 +1,40 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Test.Syd.Mutation.Plugin (plugin) where+module Test.Syd.Mutation.Plugin+  ( plugin,+    ModuleMutationAnns (..),+    parseModuleMutationAnns,+    DeadModuleDisable (..),+    deadModuleDisables,+    renderDeadModuleDisable,+    deadModuleDisableSpan,+  )+where -import Control.Monad (when)+import Control.Monad (forM_) 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.List (isPrefixOf) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set import GHC-import GHC.Data.FastString (unpackFS)+import GHC.Data.FastString (mkFastString, unpackFS) import GHC.Driver.Env (Hsc, HscEnv (..)) import GHC.Driver.Plugins-import GHC.Driver.Session (WarningFlag (..), wopt_unset)+import GHC.Driver.Session (WarningFlag (..), gopt_unset, wopt_unset) import GHC.Serialized (deserializeWithData)+import GHC.Tc.Errors.Types (mkTcRnUnknownMessage) import GHC.Tc.Types+import GHC.Tc.Utils.Monad (addErrAt) import GHC.Types.Annotations (AnnTarget (..), findAnns)+import GHC.Types.Error (mkPlainError, noHints)+import GHC.Utils.Outputable (text) import Path import System.IO.Unsafe (unsafePerformIO) import Test.Syd.Mutation.Manifest (MutationGroup (..), MutationManifest (..), writeManifestFile)@@ -30,38 +47,109 @@     resolveSettings,   ) -data DisabledMutation-  = DisableAll-  | DisableNamed String-  deriving (Eq)+-- | Parsed result of all mutation-related module-level+-- @{-# ANN module ... #-}@ annotations on one module.+data ModuleMutationAnns = ModuleMutationAnns+  { -- | What the module's annotations disable across the whole module.+    mmaDisable :: !MutationDisable,+    -- | Annotation strings that announced themselves as mutation disables but+    -- are none of the forms a module accepts.  A @DisableMutationsFor <name>@+    -- is one of these: it names a local binding of the scope it annotates,+    -- and a module has none.+    mmaMalformed :: ![String]+  }+  deriving (Eq, Show) --- | 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+-- | Parse all the module-level @{-# ANN module #-}@ string payloads on one+-- module.  The binding-level counterpart is 'parseFunMutationAnns'.+parseModuleMutationAnns :: [String] -> ModuleMutationAnns+parseModuleMutationAnns = foldr combine (ModuleMutationAnns (DisableOps []) [])   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 = []+    combine :: String -> ModuleMutationAnns -> ModuleMutationAnns+    combine s soFar = case parseDisableAnn s of+      AnnSelf d -> soFar {mmaDisable = mergeDisables d (mmaDisable soFar)}+      AnnLocal _ _ -> soFar {mmaMalformed = s : mmaMalformed soFar}+      AnnMalformed _ -> soFar {mmaMalformed = s : mmaMalformed soFar}+      AnnUnrelated -> soFar -trim :: String -> String-trim = dropWhile (== ' ')+-- | A module-level mutation annotation that disables nothing.+data DeadModuleDisable+  = -- | An annotation that looks like a mutation disable but is none of the+    -- forms a module accepts.+    MalformedModuleAnnotation String+  | -- | What the module's annotations disable is inert.+    DeadModuleDisable DeadInScope+  deriving (Eq, Show) -splitOnComma :: String -> [String]-splitOnComma s = case break (== ',') s of-  (w, []) -> [w]-  (w, _ : rest) -> w : splitOnComma rest+-- | Everything a module's mutation annotations deserve to be told about.+--+-- @known@ is every operator name the plugin has and @fired@ the operators+-- that produce a mutation in the module with its module-level disables lifted+-- (but the configuration's disables still in force, so "disables nothing"+-- means "removing this annotation would not change the manifest").+deadModuleDisables :: Set String -> ModuleMutationAnns -> Set String -> [DeadModuleDisable]+deadModuleDisables known (ModuleMutationAnns disable malformed) fired =+  map MalformedModuleAnnotation malformed+    ++ map DeadModuleDisable (deadInScope known disable fired) +-- | The compile error one dead module-level annotation earns.+renderDeadModuleDisable :: Set String -> DeadModuleDisable -> String+renderDeadModuleDisable known = \case+  MalformedModuleAnnotation ann ->+    concat+      [ "Module-level mutation annotation `",+        ann,+        "` is none of the recognised module-level disable annotations, ",+        "so it disables no mutations. ",+        "Recognised forms are `DisableMutations`, `DisableMutation: <Operator>` ",+        "and `DisableMutations: <Operator>, <Operator>`."+      ]+  DeadModuleDisable dead ->+    concat+      [ "Module-level mutation disable annotation ",+        renderDeadInScope known "this module" dead+      ]++-- | Where to point a complaint about a module-level annotation.+--+-- @recorded@ pairs each module-level annotation payload the parsed AST saw+-- with the span of its pragma, so a complaint lands on the pragma it is+-- about.  @fallback@ is used when no recorded annotation accounts for the+-- complaint, which takes a payload that is not a literal string (and so is+-- invisible in the parsed AST, though 'findAnns' still sees it).+deadModuleDisableSpan :: SrcSpan -> [(String, SrcSpan)] -> DeadModuleDisable -> SrcSpan+deadModuleDisableSpan fallback recorded dead =+  let -- Every constructor is enumerated rather than defaulted, so that adding+      -- a way for an annotation to be inert forces a decision about which+      -- annotation a complaint about it points at.+      accountsFor :: DeadInScope -> MutationDisable -> Bool+      accountsFor scope disable = case disable of+        DisableAllOps -> case scope of+          ScopeDeadAll -> True+          ScopeControlOperator -> False+          ScopeDeadOperator _ -> False+          ScopeUnknownOperator _ -> False+        DisableOps ops -> case scope of+          ScopeDeadAll -> False+          ScopeControlOperator -> any namesControlOperator ops+          ScopeDeadOperator op -> op `elem` ops+          ScopeUnknownOperator op -> op `elem` ops++      accounts :: String -> Bool+      accounts payload = case dead of+        MalformedModuleAnnotation ann -> ann == payload+        DeadModuleDisable scope -> case parseDisableAnn payload of+          AnnSelf disable -> accountsFor scope disable+          -- A "...For <name>" payload and an unparsable one are themselves+          -- complained about, as malformed; neither contributes to the+          -- module's disable, so neither can account for one being inert.+          AnnLocal _ _ -> False+          AnnMalformed _ -> False+          AnnUnrelated -> False+   in case [sp | (payload, sp) <- recorded, accounts payload] of+        (sp : _) -> sp+        [] -> fallback+ plugin :: Plugin plugin =   defaultPlugin@@ -77,16 +165,28 @@         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-                  ]+                -- ConstConstructor reads the unfolding of an imported binding+                -- to tell whether it is an alias for a nullary constructor+                -- (Data.Map.empty is Tip), so that it does not offer the+                -- constructor the expression already is.  -O0 implies+                -- -fignore-interface-pragmas, which drops unfoldings as+                -- interfaces are read, and instrumented builds are compiled+                -- at -O0 on purpose -- so without this the recognition would+                -- silently do nothing in exactly the configuration mutation+                -- testing runs in.  Reading unfoldings does not run the+                -- simplifier, so the compile-time blowup -O0 avoids does not+                -- come back with them.+                (`gopt_unset` Opt_IgnoreInterfacePragmas) $+                  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@@ -106,19 +206,25 @@ -- 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.+-- Also walks the parsed AST for what only it can see, and records both in a+-- process-global IORef keyed by module name for 'mutationTypeCheckAction' to+-- read back: --+--   * When @--skip-th-splices@ is set, 'RealSrcSpan's covering every+--     'HsUntypedSplice', 'HsTypedSplice', and declaration-level 'SpliceD'.+--     'recordMutation' consults these (via the 'instrumentEnvSpliceSpans'+--     field of 'InstrumentEnv') to drop mutations whose own span is contained+--     inside any splice span.+--   * The module-level annotation payloads with the spans of their pragmas,+--     so a complaint about one can point at it.+-- -- 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.+-- present in the parsed AST.  Annotation spans are parse-time for a simpler+-- reason: 'findAnns' hands over payloads without any source location. mutationAddRuntimeImport ::   [CommandLineOption] ->   ModSummary ->@@ -136,42 +242,37 @@     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, ()))+          info =+            ModuleParseInfo+              { mpiSpliceSpans = if skipThSplices then collectSpliceSpans lm else [],+                mpiModuleAnns = moduleAnnStrings (unLoc lm)+              }+      liftIO $ atomicModifyIORef' moduleParseInfoMap (\m -> (Map.insert mn info 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)+-- | The module-level @{-# ANN module ("..." :: String) #-}@ payloads in the+-- parsed module, each with the span of its pragma.+--+-- Only looks at module-level annotations (ignores @ANN someFunction ...@) so+-- it mirrors the typecheck-phase read of 'tcg_ann_env' with a 'ModuleTarget'.+moduleAnnStrings :: HsModule GhcPs -> [(String, SrcSpan)]+moduleAnnStrings m = concatMap annString (hsmodDecls m)   where-    isDisableMutationsDecl :: LHsDecl GhcPs -> Bool-    isDisableMutationsDecl (L _ d) = case d of+    annString :: LHsDecl GhcPs -> [(String, SrcSpan)]+    annString ld = case unLoc ld of       AnnD _ (HsAnnotation _ ModuleAnnProvenance {} expr) ->-        annExprIsDisableMutations expr-      _ -> False+        [(s, getLocA ld) | Just s <- [annExprString expr]]+      _ -> []      -- 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+    annExprString :: LHsExpr GhcPs -> Maybe String+    annExprString le = case unLoc (stripExpr le) of+      HsLit _ (HsString _ s) -> Just (unpackFS s)+      _ -> Nothing      stripExpr :: LHsExpr GhcPs -> LHsExpr GhcPs     stripExpr le = case unLoc le of@@ -179,18 +280,31 @@       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+-- | What 'mutationAddRuntimeImport' saw in one parsed module that+-- 'mutationTypeCheckAction' cannot see for itself.+data ModuleParseInfo = ModuleParseInfo+  { mpiSpliceSpans :: ![RealSrcSpan],+    mpiModuleAnns :: ![(String, SrcSpan)]+  }++noModuleParseInfo :: ModuleParseInfo+noModuleParseInfo =+  ModuleParseInfo+    { mpiSpliceSpans = [],+      mpiModuleAnns = []+    }++-- | Per-module parse-stage findings, written by 'mutationAddRuntimeImport'+-- and read back by 'mutationTypeCheckAction'.  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)+{-# NOINLINE moduleParseInfoMap #-}+moduleParseInfoMap :: IORef (Map String ModuleParseInfo)+moduleParseInfoMap = 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@@ -246,25 +360,47 @@     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+      let moduleDisables = parseModuleMutationAnns modAnns+      let configDisabled = disabledFromConfig ++ disabledFromOperatorsConfig+      let mSrcPath = ml_hs_file (ms_location ms)+      parseInfo <- liftIO $ Map.findWithDefault noModuleParseInfo mn <$> readIORef moduleParseInfoMap+      let spliceSpans = if skipThSplices then mpiSpliceSpans parseInfo else []+      let walk :: InstrumentPurpose -> [String] -> TcM (LHsBinds GhcTc, [MutationGroup])+          walk purpose disabled =+            runInstrument tcGblEnv allOperators purpose annEnv disabled mSrcPath debug skipThSplices operatorsConfig spliceSpans ignore $+              instrumentModule (tcg_binds tcGblEnv)+      -- What the module-level annotations are worth: the operators that fire+      -- with only the configuration's disables in force.  Measured on a walk+      -- whose result is thrown away, and only when there is an annotation to+      -- judge, since the walk costs as much as instrumenting the module does.+      let measureModule :: TcM (Set String)+          measureModule = operatorNamesIn . snd <$> walk MeasureOnly configDisabled+      let reportDeadModuleDisables :: Set String -> TcM ()+          reportDeadModuleDisables fired =+            forM_ (deadModuleDisables knownOperators moduleDisables fired) $ \dead ->+              addErrAt (deadModuleDisableSpan (moduleStartSpan ms) (mpiModuleAnns parseInfo) dead) $+                mkTcRnUnknownMessage $+                  mkPlainError noHints $+                    text (renderDeadModuleDisable knownOperators dead)+      case mmaDisable moduleDisables of+        -- The module asks not to be mutated at all, so its compiled artefacts+        -- are returned unchanged.  It is still walked once with the+        -- annotation lifted, to find out whether the annotation is worth+        -- anything, and that walk is thrown away.  A module whose+        -- instrumentation itself misbehaves belongs in @exceptions@, which is+        -- checked above this and never walks the module at all.+        DisableAllOps -> do+          reportDeadModuleDisables =<< measureModule           liftIO $ putStrLn $ "mutation: skipping " ++ mn ++ " (DisableMutations)"           pure tcGblEnv-        else do-          let disabledNames = disabledFromConfig ++ disabledFromOperatorsConfig ++ [n | DisableNamed n <- disabledFromModAnns]+        DisableOps moduleAnnNames -> do+          fired <-+            if null moduleAnnNames+              then pure Set.empty+              else measureModule+          reportDeadModuleDisables fired           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)+          (binds', groups) <- walk Instrument (configDisabled ++ moduleAnnNames)           let totalMutations = sum [length rs | MutationGroup rs <- groups]           liftIO $ do             putStrLn $ "added " ++ show totalMutations ++ " mutations in " ++ show (length groups) ++ " groups"@@ -272,6 +408,19 @@               Nothing -> pure ()               Just dir -> writeModuleManifest dir mn groups           pure tcGblEnv {tcg_binds = binds'}++-- | Every operator name the plugin has, for judging a disable annotation that+-- names one.+knownOperators :: Set String+knownOperators = Set.fromList (map operatorName allOperators)++-- | A span at the start of the module's source file, for a complaint about an+-- annotation whose own span is not available.+moduleStartSpan :: ModSummary -> SrcSpan+moduleStartSpan ms =+  let file = fromMaybe (ms_hspp_file ms) (ml_hs_file (ms_location ms))+      loc = mkSrcLoc (mkFastString file) 1 1+   in mkSrcSpan loc loc  -- | Write the manifest for one module to @<dir>/<ModuleName>.json@ and a -- coloured human-readable rendering to @<dir>/<ModuleName>.txt@.  Each

@@ -19,19 +19,30 @@     instrumentModule,     applySpanRemoval,     applySwapSpans,+    InstrumentPurpose (..),+    parseDisableAnn,+    ParsedDisableAnn (..),     parseFunMutationAnns,     FunMutationAnns (..),-    LocalDisable (..),-    deadDisableTargets,+    MutationDisable (..),+    mergeDisables,+    DeadInScope (..),+    deadInScope,+    renderDeadInScope,+    namesControlOperator,+    DeadDisable (..),+    deadDisables,+    renderDeadDisable,+    operatorNamesIn,   ) where -import Control.Monad (filterM, foldM, forM_)+import Control.Monad (filterM, foldM, forM_, when) 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 (intercalate, isPrefixOf, nub, stripPrefix) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map)@@ -46,6 +57,7 @@ -- '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.ConLike (conLikeName) import GHC.Core.Predicate (isEvVar) import GHC.Core.TyCo.Rep (Scaled (..)) import GHC.Core.Type (isLiftedTypeKind, typeKind)@@ -73,7 +85,7 @@ 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.Operator.Util (collectApp, headFunctionName, headNameMatches) import Test.Syd.Mutation.Plugin.OptParse (OperatorConfig) import Test.Syd.Mutation.Runtime (MutationId (..)) @@ -204,6 +216,21 @@ -- --------------------------------------------------------------------------- -- Monad +-- | Whether a walk is the real instrumentation or a measurement of what the+-- real instrumentation would do.+--+-- A 'MeasureOnly' walk exists to answer "which operators fire in here", which+-- is what decides whether a disable annotation disables anything.  Its+-- syntax and its effect on 'InstrState' are thrown away afterwards+-- ('operatorsFiringIn'), so it must also stay silent and must not measure+-- again: otherwise a diagnostic would be reported once per measurement, and+-- nested annotations would each re-walk a subtree an enclosing annotation is+-- already re-walking.+data InstrumentPurpose+  = Instrument+  | MeasureOnly+  deriving (Eq)+ data InstrumentEnv = InstrumentEnv   { instrumentEnvModule :: Module,     -- | Source name ('OccName' string) of the enclosing top-level binding we@@ -222,10 +249,17 @@     -- uses the 'ExpressionOperator's and the binding walker the     -- 'FunctionDeclarationOperator's.     instrumentEnvOperators :: [MutationOperator],+    -- | Whether this walk instruments or only measures which operators fire.+    -- See 'InstrumentPurpose' and 'operatorsFiringIn'.+    instrumentEnvPurpose :: InstrumentPurpose,+    -- | The name of every operator the plugin has, whether or not this run+    -- enables it.  A disable annotation naming something absent from here+    -- names nothing at all, which is a different (and more useful) complaint+    -- than naming an operator that fires nowhere - and one that must not+    -- depend on how a particular run is configured.+    instrumentEnvKnownOperators :: Set String,     -- | 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).@@ -268,7 +302,7 @@     -- 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,+    instrumentEnvLocalDisables :: Map String MutationDisable,     -- | 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@@ -303,7 +337,21 @@     -- 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+    instrumentEnvAppDepth :: Int,+    -- | The functions whose arguments this expression is inside, innermost+    -- first.+    --+    -- Pushed when the walker descends into the argument of an application,+    -- and through @$@ on both its application and its infix form, so that+    -- @failJobFatal $ mconcat [\"...\", err]@ leaves the list literal with+    -- @[mconcat, failJobFatal]@ rather than only @mconcat@. That is the whole+    -- reason this is a list rather than the immediate callee: the call worth+    -- naming in a config file is the one that says what the argument is for,+    -- and it is never the innermost one for a string built out of pieces.+    --+    -- 'Test.Syd.Mutation.Plugin.Operator.ListLit' consults this for its+    -- @skip-calls-to@ key.+    instrumentEnvEnclosingCalls :: [Name]   }  -- | Original source information for an enclosing infix @OpApp@ — captured@@ -324,16 +372,19 @@  -- | The 'StateT' state threaded through instrumentation. data InstrState = InstrState-  { -- | Names of 'DisableMutationsFor' targets that 'applyLocalDisables' has+  { -- | For each 'DisableMutationsFor' target 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+    -- walked, the operators that fire inside that binding once the target's+    -- own disables are lifted.  'withFunBindEnv' brackets each declaring+    -- binding by resetting this to empty, walking the body, and reading it+    -- back, and 'deadDisables' then reads both halves of it: a declared+    -- target still absent named a binding that does not exist, and a target+    -- present but missing an operator it disables named a binding that+    -- operator does not mutate.  Either way the annotation is dead and we+    -- raise a compile error.  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),+    -- name (e.g. an @inner@ in each), which a single threaded map could not.+    instrLocalDisableHits :: !(Map String (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.@@ -348,7 +399,7 @@ emptyInstrState :: InstrState emptyInstrState =   InstrState-    { instrConsumedDisables = Set.empty,+    { instrLocalDisableHits = Map.empty,       instrSinceControl = 0,       instrControlSeq = 0     }@@ -379,6 +430,8 @@ runInstrument ::   TcGblEnv ->   [MutationOperator] ->+  -- | Whether to instrument for real or only to measure which operators fire.+  InstrumentPurpose ->   -- | Annotation environment for reading {-# ANN #-} annotations.   AnnEnv ->   -- | Mutation type names disabled globally or at module scope.@@ -399,7 +452,7 @@   [String] ->   InstrM a ->   TcM (a, [MutationGroup])-runInstrument tcGblEnv operators annEnv disabledMutations mSrcPath debug skipThSplices operatorsConfig spliceSpans ignore action = do+runInstrument tcGblEnv operators purpose annEnv disabledMutations mSrcPath debug skipThSplices operatorsConfig spliceSpans ignore action = do   let rdrEnv = tcg_rdr_env tcGblEnv       modul = tcg_mod tcGblEnv   ifMutId <- lookupRdrEnvId rdrEnv "ifMutation"@@ -420,16 +473,20 @@         instrumentEnvIfMutationId = ifMutId,         instrumentEnvMutationIdCon = mutIdCon,         instrumentEnvOperators = activeOperators,+        instrumentEnvPurpose = purpose,+        instrumentEnvKnownOperators = Set.fromList (map operatorName operators),         instrumentEnvAnnEnv = annEnv,-        instrumentEnvDisabledMutations = disabledMutations,         instrumentEnvSourceFile = mSrcFile,-        instrumentEnvDebug = debug,+        -- A measuring walk is thrown away, so announcing its mutations would+        -- be announcing mutations that never make it into the manifest.+        instrumentEnvDebug = debug && purpose == Instrument,         instrumentEnvSkipThSplices = skipThSplices,         instrumentEnvOperatorsConfig = operatorsConfig,         instrumentEnvSpliceSpans = spliceSpans,         instrumentEnvIgnore = ignore,         instrumentEnvInGuard = False,         instrumentEnvAppDepth = 0,+        instrumentEnvEnclosingCalls = [],         instrumentEnvLocalDisables = Map.empty,         instrumentEnvInLocalLet = False,         instrumentEnvOpAppCtx = Nothing@@ -565,6 +622,11 @@ -- | 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.+--+-- Also records what the matched entries are worth, by measuring the same+-- binding with them lifted.  This is the only place that knows which syntax a+-- @DisableMutationsFor <name>@ actually covers, so it is the only place that+-- can measure it. applyLocalDisables :: [String] -> InstrM a -> InstrM a applyLocalDisables occs action = do   InstrumentEnv {instrumentEnvLocalDisables, instrumentEnvOperators} <- ask@@ -572,7 +634,6 @@   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' =@@ -580,6 +641,23 @@               then []               else filter (\op -> operatorName op `notElem` namedDisables) instrumentEnvOperators           remaining = foldr (Map.delete . fst) instrumentEnvLocalDisables matches+      -- Measure with the matched entries lifted but removed from the map all+      -- the same, so that a shadowing binding of the same name inside does not+      -- narrow the measurement.  The real walk removes them for the same+      -- reason: an entry is spent on the outermost binding that matches it.+      fired <-+        operatorsFiringIn instrumentEnvOperators $+          local (\env -> env {instrumentEnvLocalDisables = remaining}) action+      modify'+        ( \s ->+            s+              { instrLocalDisableHits =+                  foldr+                    (\(occ, _) -> Map.insertWith Set.union occ fired)+                    (instrLocalDisableHits s)+                    matches+              }+        )       local         ( \env ->             env@@ -589,18 +667,54 @@         )         action --- | The 'DisableMutationsFor' targets that never matched a local binding.+-- | The operators that produce a mutation in @action@ when it is walked with+-- @operators@ available. ----- @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)+-- Runs the walk for its mutation records only: the groups it emits are+-- censored away, the instrumentation state is put back, and the instrumented+-- syntax it returns is dropped.  What is left is which operators would have+-- fired, which is what decides whether a disable annotation disables+-- anything.  Measuring with the real walk rather than asking each operator+-- whether it matches is what keeps the answer from drifting away from the+-- manifest: the @ignore@ list, per-operator @skip-calls-to@ keys, splice+-- filtering and the dropping of mutants that do not desugar all happen inside+-- the walk, and each of them can be the reason an operator produces nothing.+--+-- Answers 'Set.empty' without walking at all when there is nothing to+-- measure: no operators that could fire, or a walk that is itself already a+-- measurement, so a nested annotation does not re-walk a subtree its+-- enclosing annotation is already re-walking.+operatorsFiringIn :: [MutationOperator] -> InstrM a -> InstrM (Set String)+operatorsFiringIn operators action = do+  purpose <- asks instrumentEnvPurpose+  if null operators || purpose == MeasureOnly+    then pure Set.empty+    else do+      saved <- get+      (_, groups) <-+        censor (const []) $+          listen $+            local+              ( \env ->+                  env+                    { instrumentEnvOperators = operators,+                      instrumentEnvPurpose = MeasureOnly,+                      instrumentEnvDebug = False+                    }+              )+              action+      put saved+      pure (operatorNamesIn groups) +-- | The operators that recorded a mutation in a walk's output.+--+-- Reading the answer off the records rather than off the operators that were+-- tried is what makes a measurement mean "these would have been in the+-- manifest".+operatorNamesIn :: [MutationGroup] -> Set String+operatorNamesIn groups =+  Set.fromList [T.unpack (mutRecOperator record) | MutationGroup records <- groups, record <- records]+ -- | Run an instrumentation action with the operator list filtered by any -- {-# ANN funName ("DisableMutations..." :: String) #-} annotations on the -- given top-level name.@@ -613,36 +727,36 @@ -- 'findAnns' returns @[]@; in that case this is the identity on the -- environment (the existing 'instrumentEnvLocalDisables' from the enclosing -- top-level binding is preserved).+--+-- An annotated binding is also where every complaint about its annotations is+-- raised, because this is the scope those annotations cover: measuring the+-- body with the binding's own disables lifted says what they are worth, and+-- 'deadDisables' turns that into the complaints. withFunBindEnv :: Name -> InstrM a -> InstrM a withFunBindEnv funName action = do-  InstrumentEnv {instrumentEnvAnnEnv, instrumentEnvOperators, instrumentEnvLocalDisables} <- ask+  InstrumentEnv+    { instrumentEnvAnnEnv,+      instrumentEnvOperators,+      instrumentEnvLocalDisables,+      instrumentEnvKnownOperators,+      instrumentEnvPurpose+    } <-+    ask   let funAnns = findAnns deserializeWithData instrumentEnvAnnEnv (NamedTarget funName) :: [String]-      FunMutationAnns selfDisable localDisables = parseFunMutationAnns funAnns-      operators' = case selfDisable of+  let anns = parseFunMutationAnns funAnns+  let FunMutationAnns selfDisable localDisables _ = anns+  let 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' =+  -- 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.+  let 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 <-+  let withDisables :: InstrM b -> InstrM b+      withDisables =         local           ( \env ->               env@@ -650,41 +764,235 @@                   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."+  if not (hasMutationAnns anns)+    then+      -- This binding carries no mutation annotation, so it has nothing to+      -- measure and nothing to answer for.  It also leaves the per-target+      -- hits alone: a target hit inside it must still count for whichever+      -- outer binding declared that target.+      withDisables action+    else do+      -- What the binding's own disable is worth: the operators that fire in+      -- the body with that disable lifted, but with every other disable+      -- (configuration, an enclosing annotation, this binding's own+      -- per-target entries) still in force.  So "fires nowhere" means+      -- "removing this annotation would not change the manifest".+      selfFired <-+        if disablesNothing selfDisable+          then pure Set.empty+          else+            operatorsFiringIn instrumentEnvOperators $+              local (\env -> env {instrumentEnvLocalDisables = localDisables'}) action+      -- Bracket the per-target hits: reset them, walk the body, then read back+      -- exactly what this binding's body contributed.  A single threaded map+      -- would be wrong here, since several bindings can disable the same local+      -- name (e.g. an @inner@ in each), and the first hit would mask the+      -- others.+      saved <- gets instrLocalDisableHits+      modify' (\s -> s {instrLocalDisableHits = Map.empty})+      result <- withDisables action+      localFired <- gets instrLocalDisableHits+      -- Restore the enclosing scope's hits, plus what this body added, so an+      -- outer declaring binding still sees targets hit in here.+      modify' (\s -> s {instrLocalDisableHits = Map.unionWith Set.union saved localFired})+      case instrumentEnvPurpose of+        MeasureOnly -> pure ()+        Instrument ->+          forM_ (deadDisables instrumentEnvKnownOperators anns selfFired localFired) $ \dead ->+            liftTcM $+              addErrAt (nameSrcSpan funName) $+                mkTcRnUnknownMessage $+                  mkPlainError noHints $+                    text $+                      renderDeadDisable instrumentEnvKnownOperators (getOccString funName) dead       pure result +-- | A mutation-disable annotation on a binding that disables nothing.+--+-- Every constructor is a way for an annotation to be inert: removing it would+-- not change the manifest.  Each is a compile error, so an annotation either+-- earns its place or has to go.+data DeadDisable+  = -- | A string that announces itself as a mutation annotation but is none+    -- of the recognised forms, so it never reached a scope at all.+    MalformedAnnotation String+  | -- | What the binding disables on itself is inert.+    DeadSelf DeadInScope+  | -- | What the binding disables inside the named local binding is inert.+    DeadLocal String DeadInScope+  | -- | A @DisableMutationsFor <target>@ whose target is no local binding in+    -- the annotated binding's body: a typo, or a since-renamed local.+    DeadTarget String+  deriving (Eq, Show)++-- | Everything a binding's mutation annotations deserve to be told about.+--+-- @known@ is every operator name the plugin has, @selfFired@ the operators+-- that fire in the binding's body with its self-disable lifted, and+-- @localFired@ the same per local-disable target - with a target absent+-- altogether when it matched no local binding in the body.+deadDisables ::+  Set String ->+  FunMutationAnns ->+  Set String ->+  Map String (Set String) ->+  [DeadDisable]+deadDisables known (FunMutationAnns selfDisable localDisables malformed) selfFired localFired =+  let localDead :: (String, MutationDisable) -> [DeadDisable]+      localDead (target, disable) = case Map.lookup target localFired of+        Nothing -> [DeadTarget target]+        Just fired -> map (DeadLocal target) (deadInScope known disable fired)+   in concat+        [ map MalformedAnnotation malformed,+          map DeadSelf (deadInScope known selfDisable selfFired),+          concatMap localDead (Map.toList localDisables)+        ]++-- | The compile error one dead disable on @binding@ earns.+renderDeadDisable :: Set String -> String -> DeadDisable -> String+renderDeadDisable known binding =+  let onBinding :: String -> String+      onBinding rest = concat ["Mutation disable annotation on `", binding, "` ", rest]+   in \case+        MalformedAnnotation ann ->+          concat+            [ "Mutation annotation `",+              ann,+              "` on `",+              binding,+              "` is none of the recognised disable annotations, so it disables no mutations. ",+              recognisedFormsPhrase+            ]+        DeadSelf dead -> onBinding (renderDeadInScope known "its body" dead)+        DeadLocal target dead ->+          onBinding (renderDeadInScope known (concat ["`", target, "`"]) dead)+        DeadTarget target ->+          concat+            [ "Mutation DisableMutationsFor annotation on `",+              binding,+              "` targets `",+              target,+              "`, which is not a local binding in its body. ",+              "It disables no mutations; remove it."+            ]++-- | What is inert about one scope's disable, whatever kind of scope it is: a+-- module, a binding, or one local binding inside a binding.+data DeadInScope+  = -- | The annotation names something that is not a mutation operator.+    ScopeUnknownOperator String+  | -- | The annotation names the control (no-op) mutation among the operators+    -- it disables.  A control is inserted on a cadence at a site where an+    -- operator already fired, so it is not in the operator list a disable+    -- filters and naming it takes nothing away - but the name is right there+    -- in every report, which is what makes reaching for it a natural mistake.+    ScopeControlOperator+  | -- | The named operator produces no mutation in the scope.+    ScopeDeadOperator String+  | -- | An all-operator disable on a scope that would be mutated nowhere.+    ScopeDeadAll+  deriving (Eq, Show)++-- | Everything inert about one scope's disable.+--+-- @known@ is every operator name the plugin has and @fired@ the operators+-- that produce a mutation in the scope with the scope's own disables lifted.+--+-- A name that is no operator is reported as unknown rather than as dead: the+-- name is the problem, and whether a non-operator fires anywhere is not a+-- question worth answering.+deadInScope :: Set String -> MutationDisable -> Set String -> [DeadInScope]+deadInScope known disable fired =+  let verdict :: String -> [DeadInScope]+      verdict op+        | namesControlOperator op = [ScopeControlOperator]+        | not (op `Set.member` known) = [ScopeUnknownOperator op]+        | not (op `Set.member` fired) = [ScopeDeadOperator op]+        | otherwise = []+   in case disable of+        DisableAllOps -> [ScopeDeadAll | Set.null fired]+        DisableOps ops -> concatMap verdict (nub ops)++-- | The rest of the sentence about one inert disable, after the words that+-- name the annotation.  @scope@ names what the disable applies to, in a form+-- that reads after "in": @its body@, @`inner`@, @this module@.+renderDeadInScope :: Set String -> String -> DeadInScope -> String+renderDeadInScope known scope = \case+  ScopeUnknownOperator op ->+    concat ["names `", op, "`, which is not a mutation operator. ", knownOperatorsPhrase known]+  ScopeControlOperator ->+    concat+      [ "names `",+        T.unpack controlOperatorName,+        "`, which is the control (no-op) mutation rather than an operator. ",+        "A control is only ever inserted where an operator fires, so naming it ",+        "among operators to disable takes nothing away; remove it. ",+        "Disabling every operator on a scope leaves it with no controls either."+      ]+  ScopeDeadOperator op ->+    concat+      [ "disables `",+        op,+        "`, which produces no mutation in ",+        scope,+        " (it may already be disabled by configuration or by another annotation). ",+        "It disables no mutations; remove it."+      ]+  ScopeDeadAll ->+    concat+      [ "disables every operator, but nothing in ",+        scope,+        " would be mutated. It disables no mutations; remove it."+      ]++-- | Whether an annotation's operator name names the control (no-op) mutation+-- rather than an operator.+namesControlOperator :: String -> Bool+namesControlOperator = (== controlOperatorName) . T.pack++-- | The operator names, for an error message that has just rejected one.+knownOperatorsPhrase :: Set String -> String+knownOperatorsPhrase known =+  concat ["The mutation operators are: ", intercalate ", " (Set.toAscList known), "."]++-- | The disable annotations a binding accepts, for an error message that has+-- just rejected something that looked like one.+recognisedFormsPhrase :: String+recognisedFormsPhrase =+  unwords+    [ "Recognised forms are `DisableMutations`, `DisableMutation: <Operator>`,",+      "`DisableMutations: <Operator>, <Operator>`, `DisableMutationsFor <name>`,",+      "`DisableMutationFor <name>: <Operator>`",+      "and `DisableMutationsFor <name>: <Operator>, <Operator>`."+    ]+ -- | 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,+    famSelfDisable :: !MutationDisable,     -- | 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)+    famLocalDisables :: !(Map String MutationDisable),+    -- | Annotation strings that announced themselves as mutation disables but+    -- are none of the recognised forms.  Kept rather than dropped because+    -- such a string disables nothing, which is a mistake worth reporting.+    famMalformed :: ![String]   }   deriving (Eq, Show) +-- | Whether a binding carries any mutation annotation at all.+--+-- A binding that carries none has nothing to measure and nothing to answer+-- for, which is the overwhelmingly common case and worth not paying for.+hasMutationAnns :: FunMutationAnns -> Bool+hasMutationAnns (FunMutationAnns selfDisable localDisables malformed) =+  not (disablesNothing selfDisable)+    || not (Map.null localDisables)+    || not (null malformed)+ -- | What a single annotation disables on a scope.-data LocalDisable+data MutationDisable   = -- | Disable all operators on this scope.     DisableAllOps   | -- | Disable exactly the listed operator names on this scope. An empty@@ -692,71 +1000,110 @@     DisableOps [String]   deriving (Eq, Show) --- | Parse a list of @{-# ANN funName #-}@ string payloads.+-- | Whether a disable disables nothing by construction, because it names no+-- operator.  This is what the absence of any annotation parses to, so it is+-- also how "no disable here" is asked about.+disablesNothing :: MutationDisable -> Bool+disablesNothing = \case+  DisableAllOps -> False+  DisableOps ops -> null ops++-- | Parse all the @{-# ANN funName #-}@ string payloads on one binding.+parseFunMutationAnns :: [String] -> FunMutationAnns+parseFunMutationAnns = foldr combine (FunMutationAnns (DisableOps []) Map.empty [])+  where+    combine :: String -> FunMutationAnns -> FunMutationAnns+    combine ann soFar = case parseDisableAnn ann of+      AnnSelf d -> soFar {famSelfDisable = mergeDisables d (famSelfDisable soFar)}+      AnnLocal n d ->+        soFar {famLocalDisables = Map.insertWith mergeDisables n d (famLocalDisables soFar)}+      AnnMalformed s -> soFar {famMalformed = s : famMalformed soFar}+      AnnUnrelated -> soFar++-- | What one @{-# ANN #-}@ string payload asks the plugin to disable.+data ParsedDisableAnn+  = -- | Disable on the annotated scope itself.+    AnnSelf MutationDisable+  | -- | Disable inside the named local binding of the annotated scope.+    AnnLocal String MutationDisable+  | -- | A string that announces itself as a mutation disable but is none of+    -- the recognised forms, so it disables nothing.+    AnnMalformed String+  | -- | Not a mutation annotation at all.  @{-# ANN #-}@ string payloads are+    -- a shared mechanism (dekking's coverage marks functions with+    -- @"nocover"@), so a string that does not announce itself as a mutation+    -- disable has to be left alone rather than complained about.+    AnnUnrelated+  deriving (Eq, Show)++-- | Parse one @{-# ANN #-}@ string payload. -- -- 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.+--   * @DisableMutations@                            — disable all operators on the scope.+--   * @DisableMutations: A, B@                      — disable the listed operators on the scope.+--   * @DisableMutation: A@                          — disable the single named operator on the scope. --   * @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+-- the annotated top-level function's body.+parseDisableAnn :: String -> ParsedDisableAnn+parseDisableAnn s+  -- Try the "...For <name>" forms first so they don't get swallowed by+  -- the shorter prefixes.+  | Just rest <- stripPrefix "DisableMutationsFor " s = localAnn rest (Just DisableAllOps)+  | Just rest <- stripPrefix "DisableMutationFor " s = localAnn rest Nothing+  | s == "DisableMutations" = AnnSelf DisableAllOps+  | Just rest <- stripPrefix "DisableMutations:" s = selfAnn (map trim (splitOnComma rest))+  | Just rest <- stripPrefix "DisableMutation:" s = selfAnn [trim rest]+  -- Announcing itself as a mutation disable is what makes a string ours to+  -- complain about.  A typo bad enough to lose that prefix is indistinguishable+  -- from an annotation meant for something else, so it stays unrelated.+  | "DisableMutation" `isPrefixOf` s = AnnMalformed s+  | otherwise = AnnUnrelated   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 = []+    selfAnn :: [String] -> ParsedDisableAnn+    selfAnn ops+      | any null ops = AnnMalformed s+      | otherwise = AnnSelf (DisableOps ops)      -- 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 =+    -- either "<name>" or "<name>: A, B, ...".  Stopping at the name means+    -- "all operators" for the plural form; the singular form promises exactly+    -- one operator, so stopping at the name names none, which is a mistake+    -- rather than a shorthand.+    localAnn :: String -> Maybe MutationDisable -> ParsedDisableAnn+    localAnn rest noColonDisable =       case break (== ':') (trim rest) of-        (name, []) ->-          let n = trimTrailing name-           in [(n, defaultDisable) | not (null n)]+        (name, []) -> case noColonDisable of+          Nothing -> AnnMalformed s+          Just d -> named (trim name) d         (name, _ : opsRest) ->-          let n = trimTrailing name-              ops = map trim (splitOnComma opsRest)-           in [(n, DisableOps ops) | not (null n)]+          let ops = map trim (splitOnComma opsRest)+           in if any null ops+                then AnnMalformed s+                else named (trim name) (DisableOps ops) -    mergeDisable :: LocalDisable -> LocalDisable -> LocalDisable-    mergeDisable DisableAllOps _ = DisableAllOps-    mergeDisable _ DisableAllOps = DisableAllOps-    mergeDisable (DisableOps a) (DisableOps b) = DisableOps (a ++ b)+    named :: String -> MutationDisable -> ParsedDisableAnn+    named name d+      | null name = AnnMalformed s+      | otherwise = AnnLocal name d -    trim = dropWhile (== ' ')-    trimTrailing = reverse . dropWhile (== ' ') . reverse . trim+-- | Combine two disables on the same scope: disabling everything wins,+-- otherwise the named operators accumulate.+mergeDisables :: MutationDisable -> MutationDisable -> MutationDisable+mergeDisables DisableAllOps _ = DisableAllOps+mergeDisables _ DisableAllOps = DisableAllOps+mergeDisables (DisableOps a) (DisableOps b) = DisableOps (a ++ b) -data ParsedAnn-  = Self LocalDisable-  | Local String LocalDisable+-- | Strip the space around a name in an annotation.  Space at either end of+-- an operator name or a target name is invisible in the pragma, so keeping it+-- would reject a perfectly good annotation as naming nothing.+trim :: String -> String+trim = dropWhile (== ' ') . reverse . dropWhile (== ' ') . reverse  splitOnComma :: String -> [String] splitOnComma s = case break (== ',') s of@@ -964,7 +1311,15 @@   HsApp x f a ->     HsApp x       <$> local (\env -> env {instrumentEnvAppDepth = instrumentEnvAppDepth env + 1}) (instrumentLExpr f)-      <*> local (\env -> env {instrumentEnvAppDepth = 0}) (instrumentLExpr a)+      <*> local+        ( \env ->+            env+              { instrumentEnvAppDepth = 0,+                instrumentEnvEnclosingCalls =+                  pushEnclosingCall (applicationCallee f) (instrumentEnvEnclosingCalls env)+              }+        )+        (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@@ -977,7 +1332,20 @@   -- all, since 'instrumentLExprGo' does not mutate the signature node itself.   ExprWithTySig x e sig -> ExprWithTySig x <$> instrumentLExpr e <*> pure sig   NegApp x e se -> NegApp x <$> instrumentLExpr e <*> pure se-  OpApp x l op r -> OpApp x <$> instrumentLExpr l <*> pure op <*> instrumentLExpr r+  OpApp x l op r ->+    OpApp x+      <$> instrumentLExpr l+      <*> pure op+      <*> local+        ( \env ->+            env+              { instrumentEnvEnclosingCalls =+                  pushEnclosingCall+                    (if isDollar op then headOf l else Nothing)+                    (instrumentEnvEnclosingCalls env)+              }+        )+        (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.@@ -1034,6 +1402,59 @@     Just (collectPatBinders CollNoDictBinders pat)   _ -> Nothing +-- | The function an application calls, as far as a config file would name it.+--+-- Given the function side of an @HsApp@, this is the name at its head, except+-- that @$@ is not a call anybody means: @f $ x@ is @f@ applied to @x@, so the+-- name to report is @f@'s.+applicationCallee :: LHsExpr GhcTc -> Maybe Name+applicationCallee fnSide =+  let (hd, args) = collectApp fnSide+   in case calleeName hd of+        Just n+          | getOccString n == "$",+            (leftArg : _) <- args ->+              headOf leftArg+        other -> other++-- | The name at the head of an application, whatever it is applied to.+headOf :: LHsExpr GhcTc -> Maybe Name+headOf = calleeName . fst . collectApp++-- | The name at the head of an application, for the purpose of saying which+-- call an expression is inside.+--+-- A data constructor counts. @Left (mconcat [..])@ is an application whose+-- head says what the list is for exactly as @fail (mconcat [..])@ does, and a+-- codec or a column rejecting what it was handed says so by returning a+-- @Left@. Read here rather than in 'headFunctionName', which several operators+-- use to decide what is an elidable or swappable /call/: a constructor is not+-- one of those, and teaching that function about constructors would change+-- which mutants they produce.+calleeName :: LHsExpr GhcTc -> Maybe Name+calleeName le = case headFunctionName le of+  Just n -> Just n+  Nothing -> constructorName le++-- | The 'Name' of a data constructor at its post-typechecking 'ConLikeTc'+-- node, which is what GHC rewrites a constructor's 'HsVar' into.+constructorName :: LHsExpr GhcTc -> Maybe Name+constructorName le = case unLoc le of+  XExpr (ConLikeTc con _ _) -> Just (conLikeName con)+  XExpr (WrapExpr (HsWrap _ e)) -> constructorName (noLocA e)+  HsAppType _ f _ -> constructorName f+  HsPar _ e -> constructorName e+  _ -> Nothing++-- | Whether this operator is @$@, which stands for application rather than+-- being a call of its own.+isDollar :: LHsExpr GhcTc -> Bool+isDollar op = maybe False ((== "$") . getOccString) (headFunctionName op)++-- | Record a callee, when there was one to record.+pushEnclosingCall :: Maybe Name -> [Name] -> [Name]+pushEnclosingCall = maybe id (:)+ -- | 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@@ -1201,12 +1622,16 @@           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)+              -- A measuring walk is thrown away, so warning from it would+              -- report the same site once per measurement.+              purpose <- asks instrumentEnvPurpose+              when (purpose == Instrument) $+                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 @@ -1394,7 +1819,7 @@   Int ->   InstrM (MutationId, Maybe MutationRecord) recordMutationAt sp op origStr replStr delta mitigation altIndex = do-  InstrumentEnv {instrumentEnvModule, instrumentEnvSourceFile, instrumentEnvSkipThSplices, instrumentEnvSpliceSpans, instrumentEnvCurrentBinding} <- ask+  InstrumentEnv {instrumentEnvModule, instrumentEnvSourceFile, instrumentEnvSkipThSplices, instrumentEnvSpliceSpans, instrumentEnvCurrentBinding, instrumentEnvDebug} <- ask   case sp of     RealSrcSpan rss _       | instrumentEnvSkipThSplices && any (`containsSpan` rss) instrumentEnvSpliceSpans ->@@ -1473,18 +1898,19 @@                 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+        liftIO $+          when instrumentEnvDebug $ 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) 

@@ -260,9 +260,12 @@ -- @emptyFoo = NoFoo@ of the user's own. -- -- Best-effort: only an imported binding has an unfolding at this stage, and--- only when its defining module was compiled with enough optimisation to--- record one.  A miss costs a no-op mutant, which is what would be produced--- without this check at all.+-- only when its defining module recorded one.  A miss costs a no-op mutant,+-- which is what would be produced without this check at all.+--+-- Reading the unfolding at all takes the plugin unsetting+-- @-fignore-interface-pragmas@, which @-O0@ implies and instrumented builds+-- are compiled at; see the driver plugin in "Test.Syd.Mutation.Plugin". aliasedConstructor :: Id -> Maybe DataCon aliasedConstructor v = do   template <- maybeUnfoldingTemplate (realIdUnfolding v)

@@ -10,14 +10,29 @@ 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)+import Test.Syd.Mutation.Plugin.Operator.Util (ConstFnMatch (..), arrowTy, mkConstLambda, nameMatchCandidates, prefixFormPreview, unwrapWrap, viewConstFnResult)+import Test.Syd.Mutation.Plugin.OptParse (OperatorConfig (..), operatorExtraFlag, operatorExtraStrings)  -- | 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.+--+-- It complements it in @skip-calls-to@ too, with the same meaning and the same+-- matching: a list holding the pieces of a message is a list nobody asserts+-- the elements of, and emptying it is a mutant that can only be killed by+-- pinning wording. Naming the calls that take a message reaches those lists+-- wherever they are written, including inside an instance method, which is+-- where an @ANN@ pragma cannot go.+--+-- > operators:+-- >   ConstEmptyList:+-- >     skip-calls-to:+-- >       - fail+--+-- 'ListLit' documents why any enclosing call counts rather than only the+-- immediate one. theOperator :: MutationOperator theOperator =   MutationOperator@@ -39,9 +54,17 @@   appDepth <- asks instrumentEnvAppDepth   -- This operator interprets its own config entry's extra keys.   opsConfig <- asks instrumentEnvOperatorsConfig+  rdrEnv <- asks instrumentEnvRdrEnv+  enclosing <- asks instrumentEnvEnclosingCalls   let extra = maybe Map.empty operatorConfigExtra (Map.lookup "ConstEmptyList" opsConfig)       skipStrings = operatorExtraFlag "skip-strings" extra       skipLiteralStrings = operatorExtraFlag "skip-literal-strings" extra+      skipCallsTo = operatorExtraStrings "skip-calls-to" extra+      skippedByCall =+        not (null skipCallsTo)+          && any+            (\n -> any (`elem` skipCallsTo) (nameMatchCandidates rdrEnv n))+            enclosing       arity = length cfnArgTys       -- 'skip-strings' drops every @[Char]@-typed expression; the narrower       -- 'skip-literal-strings' drops only syntactic string literals.@@ -49,7 +72,7 @@         (skipStrings && isCharElemTy elTy)           || (skipLiteralStrings && isCharElemTy elTy && isStringLiteralExpr le)   -- See 'ConstNothing' for the dominance rule.-  if (arity >= 1 && appDepth >= arity) || skippedAsString+  if (arity >= 1 && appDepth >= arity) || skippedAsString || skippedByCall     then pure []     else       let emptyExpr = noLocA (ExplicitList elTy [])

@@ -1,11 +1,38 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}  module Test.Syd.Mutation.Plugin.Operator.ListLit (theOperator) where +import Control.Monad.Reader (asks)+import qualified Data.Map.Strict as Map import GHC import GHC.Builtin.Types (mkListTy)-import Test.Syd.Mutation.Plugin.Instrument (InstrM, MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (nameMatchCandidates)+import Test.Syd.Mutation.Plugin.OptParse (OperatorConfig (..), operatorExtraStrings) +-- | Shrink a list literal by removing elements or emptying it.+--+-- A list whose elements are the pieces of a message is a list nobody asserts+-- the elements of, and every such literal is one more mutant that can only be+-- killed by pinning wording. Those are named by the call they are an argument+-- of, under the operator's @skip-calls-to@ config key:+--+-- > operators:+-- >   ListLit:+-- >     skip-calls-to:+-- >       - logInfo+-- >       - fail+--+-- Any enclosing call counts, not only the immediate one, because the immediate+-- one is @mconcat@ or @unwords@ for every message built out of pieces: in+-- @fail $ mconcat [\"unknown: \", x]@ it is @fail@ that says what the list is+-- for, and it is two applications out. @$@ is seen through for the same+-- reason.+--+-- A name matches either bare (@fail@, matching any module) or fully qualified+-- (@GHC.Internal.Base.fail@). A qualifier may be either the function's+-- defining module or a module it is imported through. theOperator :: MutationOperator theOperator =   MutationOperator@@ -23,31 +50,44 @@   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+action ann elTy es = do+  opsConfig <- asks instrumentEnvOperatorsConfig+  rdrEnv <- asks instrumentEnvRdrEnv+  enclosing <- asks instrumentEnvEnclosingCalls+  let extra = maybe Map.empty operatorConfigExtra (Map.lookup "ListLit" opsConfig)+      skipCallsTo = operatorExtraStrings "skip-calls-to" extra+      skipThisList =+        not (null skipCallsTo)+          && any+            (\n -> any (`elem` skipCallsTo) (nameMatchCandidates rdrEnv n))+            enclosing+  if skipThisList+    then pure []+    else+      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

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           sydtest-mutation-plugin-version:        0.4.6.0+version:        0.5.0.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@@ -79,6 +79,7 @@   other-modules:       Test.Syd.Mutation.Plugin.InstrumentSpec       Test.Syd.Mutation.Plugin.OptParseSpec+      Test.Syd.Mutation.PluginSpec       Paths_sydtest_mutation_plugin   hs-source-dirs:       test

@@ -18,41 +18,84 @@  spec :: Spec spec = do+  describe "parseDisableAnn" $ do+    it "parses DisableMutations as a self DisableAllOps" $+      parseDisableAnn "DisableMutations" `shouldBe` AnnSelf DisableAllOps++    it "leaves a string that is not a mutation annotation alone" $+      parseDisableAnn "nocover" `shouldBe` AnnUnrelated++    it "reports a string that announces a mutation disable but does not parse as malformed" $+      parseDisableAnn "DisableMutationss: BoolLit" `shouldBe` AnnMalformed "DisableMutationss: BoolLit"++    it "reports a missing colon as malformed" $+      parseDisableAnn "DisableMutations BoolLit"+        `shouldBe` AnnMalformed "DisableMutations BoolLit"++    it "reports an empty operator list as malformed" $+      parseDisableAnn "DisableMutation:" `shouldBe` AnnMalformed "DisableMutation:"++    it "reports an empty entry in an operator list as malformed" $+      parseDisableAnn "DisableMutations: BoolLit, "+        `shouldBe` AnnMalformed "DisableMutations: BoolLit, "++    it "reports a DisableMutationsFor with an empty name as malformed" $+      parseDisableAnn "DisableMutationsFor " `shouldBe` AnnMalformed "DisableMutationsFor "++    it "ignores space around an operator name" $+      -- Space after the last operator is invisible in the pragma, so keeping+      -- it in the name would reject the annotation as naming no operator.+      parseDisableAnn "DisableMutations: BoolLit , ConstBool "+        `shouldBe` AnnSelf (DisableOps ["BoolLit", "ConstBool"])++    it "reports a singular DisableMutationFor without an operator as malformed" $+      -- The singular form promises exactly one operator, so stopping at the+      -- name names none.+      parseDisableAnn "DisableMutationFor innerVar"+        `shouldBe` AnnMalformed "DisableMutationFor innerVar"+   describe "parseFunMutationAnns" $ do     it "parses no annotations as no self-disable and no local disables" $       parseFunMutationAnns []-        `shouldBe` FunMutationAnns (DisableOps []) Map.empty+        `shouldBe` FunMutationAnns (DisableOps []) Map.empty []      it "parses DisableMutations as self DisableAllOps" $       parseFunMutationAnns ["DisableMutations"]-        `shouldBe` FunMutationAnns DisableAllOps Map.empty+        `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+        `shouldBe` FunMutationAnns (DisableOps ["BoolLit", "ConstBool"]) Map.empty []      it "parses DisableMutation: A as self DisableOps [A]" $       parseFunMutationAnns ["DisableMutation: BoolLit"]-        `shouldBe` FunMutationAnns (DisableOps ["BoolLit"]) Map.empty+        `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 "merges two self disables in the order they were annotated" $+      parseFunMutationAnns ["DisableMutation: BoolLit", "DisableMutation: ConstBool"]+        `shouldBe` FunMutationAnns (DisableOps ["BoolLit", "ConstBool"]) Map.empty []+     it "combines a self disable with a local disable" $       parseFunMutationAnns         [ "DisableMutations: BoolLit",@@ -61,6 +104,7 @@         `shouldBe` FunMutationAnns           (DisableOps ["BoolLit"])           (Map.singleton "innerVar" (DisableOps ["ConstBool"]))+          []      it "merges two local disables for the same name into a combined DisableOps" $       parseFunMutationAnns@@ -70,6 +114,7 @@         `shouldBe` FunMutationAnns           (DisableOps [])           (Map.singleton "innerVar" (DisableOps ["BoolLit", "ConstBool"]))+          []      it "merges a local DisableAllOps with a local DisableOps to DisableAllOps" $       parseFunMutationAnns@@ -79,6 +124,7 @@         `shouldBe` FunMutationAnns           (DisableOps [])           (Map.singleton "innerVar" DisableAllOps)+          []      it "keeps two distinct local-binding entries side by side" $       parseFunMutationAnns@@ -88,6 +134,7 @@         `shouldBe` FunMutationAnns           (DisableOps [])           (Map.fromList [("a", DisableAllOps), ("b", DisableOps ["BoolLit"])])+          []      it "ignores unrelated annotation strings" $       parseFunMutationAnns@@ -97,39 +144,178 @@         `shouldBe` FunMutationAnns           (DisableOps [])           (Map.singleton "innerVar" (DisableOps ["BoolLit"]))+          [] -    it "ignores a DisableMutationsFor with an empty name" $+    it "keeps a DisableMutationsFor with an empty name as malformed" $       parseFunMutationAnns ["DisableMutationsFor "]-        `shouldBe` FunMutationAnns (DisableOps []) Map.empty+        `shouldBe` FunMutationAnns (DisableOps []) Map.empty ["DisableMutationsFor "] -  describe "deadDisableTargets" $ do-    it "reports nothing when there are no declared targets" $-      deadDisableTargets Map.empty (Set.fromList ["a", "b"])+  describe "deadInScope" $ do+    it "reports nothing for a scope that disables nothing" $+      deadInScope (Set.fromList ["BoolLit"]) (DisableOps []) Set.empty         `shouldBe` [] -    it "reports a declared target that was never consumed" $-      deadDisableTargets-        (Map.singleton "innerVar" DisableAllOps)+    it "reports an operator name that is not an operator" $+      deadInScope (Set.fromList ["BoolLit"]) (DisableOps ["BoolLt"]) Set.empty+        `shouldBe` [ScopeUnknownOperator "BoolLt"]++    it "reports an unknown operator name as unknown rather than as dead" $+      -- The name is the problem; whether a non-operator fires is not a+      -- question worth answering.+      deadInScope (Set.fromList ["BoolLit"]) (DisableOps ["BoolLt"]) (Set.fromList ["BoolLit"])+        `shouldBe` [ScopeUnknownOperator "BoolLt"]++    it "reports a disable of the control mutation as the control mutation" $+      -- 'Control' is a name you see in a mutation report, so reaching for it+      -- in an annotation is a natural mistake, and answering "that is not a+      -- mutation operator" would contradict the report it came from.+      deadInScope (Set.fromList ["BoolLit"]) (DisableOps ["Control"]) (Set.fromList ["BoolLit"])+        `shouldBe` [ScopeControlOperator]++    it "reports a named operator that fires nowhere in the scope" $+      deadInScope+        (Set.fromList ["BoolLit", "ConstBool"])+        (DisableOps ["BoolLit"])+        (Set.fromList ["ConstBool"])+        `shouldBe` [ScopeDeadOperator "BoolLit"]++    it "reports nothing for a named operator that fires in the scope" $+      deadInScope+        (Set.fromList ["BoolLit", "ConstBool"])+        (DisableOps ["BoolLit"])+        (Set.fromList ["BoolLit"])+        `shouldBe` []++    it "reports each dead name once, in the order they were named" $+      deadInScope+        (Set.fromList ["BoolLit", "ConstBool", "Negate"])+        (DisableOps ["Negate", "BoolLit", "Negate", "ConstBool"])+        (Set.fromList ["ConstBool"])+        `shouldBe` [ScopeDeadOperator "Negate", ScopeDeadOperator "BoolLit"]++    it "reports an all-operator disable on a scope nothing would mutate" $+      deadInScope (Set.fromList ["BoolLit"]) DisableAllOps Set.empty+        `shouldBe` [ScopeDeadAll]++    it "reports nothing for an all-operator disable on a scope something mutates" $+      deadInScope (Set.fromList ["BoolLit"]) DisableAllOps (Set.fromList ["BoolLit"])+        `shouldBe` []++  describe "deadDisables" $ do+    it "reports nothing for a binding with no mutation annotations" $+      deadDisables+        (Set.fromList ["BoolLit"])+        (parseFunMutationAnns [])         Set.empty-        `shouldBe` ["innerVar"]+        Map.empty+        `shouldBe` [] -    it "reports nothing when the declared target was consumed" $-      deadDisableTargets-        (Map.singleton "innerVar" DisableAllOps)-        (Set.singleton "innerVar")+    it "reports a declared target that matched no local binding" $+      deadDisables+        (Set.fromList ["BoolLit"])+        (parseFunMutationAnns ["DisableMutationsFor innerVar"])+        Set.empty+        Map.empty+        `shouldBe` [DeadTarget "innerVar"]++    it "reports nothing when the declared target was mutated by what it disables" $+      deadDisables+        (Set.fromList ["BoolLit"])+        (parseFunMutationAnns ["DisableMutationsFor innerVar"])+        Set.empty+        (Map.singleton "innerVar" (Set.fromList ["BoolLit"]))         `shouldBe` [] -    it "reports only the unconsumed targets" $-      deadDisableTargets-        (Map.fromList [("a", DisableAllOps), ("b", DisableOps ["BoolLit"]), ("c", DisableAllOps)])-        (Set.fromList ["b"])-        `shouldBe` ["a", "c"]+    it "reports a target that exists but that the named operator does not mutate" $+      deadDisables+        (Set.fromList ["BoolLit", "ConstBool"])+        (parseFunMutationAnns ["DisableMutationFor innerVar: BoolLit"])+        Set.empty+        (Map.singleton "innerVar" (Set.fromList ["ConstBool"]))+        `shouldBe` [DeadLocal "innerVar" (ScopeDeadOperator "BoolLit")] -    it "ignores consumed names that were never declared" $-      deadDisableTargets-        (Map.singleton "a" DisableAllOps)-        (Set.fromList ["a", "x", "y"])+    it "reports a target that exists but would be mutated nowhere" $+      deadDisables+        (Set.fromList ["BoolLit"])+        (parseFunMutationAnns ["DisableMutationsFor innerVar"])+        Set.empty+        (Map.singleton "innerVar" Set.empty)+        `shouldBe` [DeadLocal "innerVar" ScopeDeadAll]++    it "reports only the targets that are dead" $+      deadDisables+        (Set.fromList ["BoolLit"])+        (parseFunMutationAnns ["DisableMutationsFor a", "DisableMutationsFor b"])+        Set.empty+        (Map.singleton "b" (Set.fromList ["BoolLit"]))+        `shouldBe` [DeadTarget "a"]++    it "reports a self-disable of an operator that mutates nothing in the binding" $+      deadDisables+        (Set.fromList ["BoolLit", "ConstBool"])+        (parseFunMutationAnns ["DisableMutation: BoolLit"])+        (Set.fromList ["ConstBool"])+        Map.empty+        `shouldBe` [DeadSelf (ScopeDeadOperator "BoolLit")]++    it "reports nothing for a self-disable of an operator that mutates the binding" $+      deadDisables+        (Set.fromList ["BoolLit"])+        (parseFunMutationAnns ["DisableMutation: BoolLit"])+        (Set.fromList ["BoolLit"])+        Map.empty         `shouldBe` []++    it "reports a self-disable of everything on a binding that would be mutated nowhere" $+      deadDisables+        (Set.fromList ["BoolLit"])+        (parseFunMutationAnns ["DisableMutations"])+        Set.empty+        Map.empty+        `shouldBe` [DeadSelf ScopeDeadAll]++    it "reports a malformed annotation" $+      deadDisables+        (Set.fromList ["BoolLit"])+        (parseFunMutationAnns ["DisableMutationss: BoolLit"])+        Set.empty+        Map.empty+        `shouldBe` [MalformedAnnotation "DisableMutationss: BoolLit"]++    it "reports every complaint a binding's annotations earn at once" $+      deadDisables+        (Set.fromList ["BoolLit", "ConstBool"])+        ( parseFunMutationAnns+            [ "DisableMutation: BoolLit",+              "DisableMutationsFor gone",+              "DisableMutationss: ConstBool"+            ]+        )+        Set.empty+        Map.empty+        `shouldBe` [ MalformedAnnotation "DisableMutationss: ConstBool",+                     DeadSelf (ScopeDeadOperator "BoolLit"),+                     DeadTarget "gone"+                   ]++  describe "renderDeadDisable" $ do+    it "asks for a dead target to be removed" $+      renderDeadDisable (Set.fromList ["BoolLit"]) "myFun" (DeadTarget "innerVar")+        `shouldBe` "Mutation DisableMutationsFor annotation on `myFun` targets `innerVar`, which is not a local binding in its body. It disables no mutations; remove it."++    it "names the operators when an annotation names something else" $+      renderDeadDisable+        (Set.fromList ["ConstBool", "BoolLit"])+        "myFun"+        (DeadSelf (ScopeUnknownOperator "BoolLt"))+        `shouldBe` "Mutation disable annotation on `myFun` names `BoolLt`, which is not a mutation operator. The mutation operators are: BoolLit, ConstBool."++    it "names the local binding a dead local disable is aimed at" $+      renderDeadDisable+        (Set.fromList ["BoolLit"])+        "myFun"+        (DeadLocal "innerVar" ScopeDeadAll)+        `shouldBe` "Mutation disable annotation on `myFun` disables every operator, but nothing in `innerVar` would be mutated. It disables no mutations; remove it."    describe "applySpanRemoval" $ do     it "removes the requested lines from a multi-line outer span" $

@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.PluginSpec (spec) where++import qualified Data.Set as Set+import GHC.Data.FastString (mkFastString)+import GHC.Types.SrcLoc+import Test.Syd+import Test.Syd.Mutation.Plugin+import Test.Syd.Mutation.Plugin.Instrument++atLine :: Int -> SrcSpan+atLine line =+  let loc = mkSrcLoc (mkFastString "test.hs") line 1+   in mkSrcSpan loc loc++spec :: Spec+spec = do+  describe "parseModuleMutationAnns" $ do+    it "parses no annotations as no disable" $+      parseModuleMutationAnns []+        `shouldBe` ModuleMutationAnns (DisableOps []) []++    it "parses DisableMutations as DisableAllOps" $+      parseModuleMutationAnns ["DisableMutations"]+        `shouldBe` ModuleMutationAnns DisableAllOps []++    it "parses DisableMutations: A, B as the named operators" $+      parseModuleMutationAnns ["DisableMutations: BoolLit, ConstBool"]+        `shouldBe` ModuleMutationAnns (DisableOps ["BoolLit", "ConstBool"]) []++    it "merges the disables of several annotations" $+      parseModuleMutationAnns ["DisableMutation: BoolLit", "DisableMutation: ConstBool"]+        `shouldBe` ModuleMutationAnns (DisableOps ["BoolLit", "ConstBool"]) []++    it "ignores unrelated annotation strings" $+      parseModuleMutationAnns ["nocover"]+        `shouldBe` ModuleMutationAnns (DisableOps []) []++    it "keeps a malformed annotation" $+      parseModuleMutationAnns ["DisableMutationss: BoolLit"]+        `shouldBe` ModuleMutationAnns (DisableOps []) ["DisableMutationss: BoolLit"]++    it "keeps a DisableMutationsFor as malformed, since a module has no local bindings" $+      parseModuleMutationAnns ["DisableMutationsFor innerVar"]+        `shouldBe` ModuleMutationAnns (DisableOps []) ["DisableMutationsFor innerVar"]++  describe "deadModuleDisables" $ do+    it "reports nothing for a module with no mutation annotations" $+      deadModuleDisables+        (Set.fromList ["BoolLit"])+        (parseModuleMutationAnns [])+        Set.empty+        `shouldBe` []++    it "reports a module-wide disable of everything on a module nothing would mutate" $+      deadModuleDisables+        (Set.fromList ["BoolLit"])+        (parseModuleMutationAnns ["DisableMutations"])+        Set.empty+        `shouldBe` [DeadModuleDisable ScopeDeadAll]++    it "reports nothing for a module-wide disable of everything on a module something mutates" $+      deadModuleDisables+        (Set.fromList ["BoolLit"])+        (parseModuleMutationAnns ["DisableMutations"])+        (Set.fromList ["BoolLit"])+        `shouldBe` []++    it "reports a named operator that mutates nothing in the module" $+      deadModuleDisables+        (Set.fromList ["BoolLit", "ConstBool"])+        (parseModuleMutationAnns ["DisableMutation: BoolLit"])+        (Set.fromList ["ConstBool"])+        `shouldBe` [DeadModuleDisable (ScopeDeadOperator "BoolLit")]++    it "reports an operator name that is not an operator" $+      deadModuleDisables+        (Set.fromList ["BoolLit"])+        (parseModuleMutationAnns ["DisableMutation: BoolLt"])+        Set.empty+        `shouldBe` [DeadModuleDisable (ScopeUnknownOperator "BoolLt")]++    it "reports a malformed annotation" $+      deadModuleDisables+        (Set.fromList ["BoolLit"])+        (parseModuleMutationAnns ["DisableMutationss: BoolLit"])+        (Set.fromList ["BoolLit"])+        `shouldBe` [MalformedModuleAnnotation "DisableMutationss: BoolLit"]++  describe "renderDeadModuleDisable" $ do+    it "asks for a module-wide disable of everything to be removed" $+      renderDeadModuleDisable (Set.fromList ["BoolLit"]) (DeadModuleDisable ScopeDeadAll)+        `shouldBe` "Module-level mutation disable annotation disables every operator, but nothing in this module would be mutated. It disables no mutations; remove it."++    it "names the module-level forms when an annotation is none of them" $+      renderDeadModuleDisable+        (Set.fromList ["BoolLit"])+        (MalformedModuleAnnotation "DisableMutationsFor innerVar")+        `shouldBe` "Module-level mutation annotation `DisableMutationsFor innerVar` is none of the recognised module-level disable annotations, so it disables no mutations. Recognised forms are `DisableMutations`, `DisableMutation: <Operator>` and `DisableMutations: <Operator>, <Operator>`."++  describe "deadModuleDisableSpan" $ do+    it "points at the annotation whose operator is dead" $+      deadModuleDisableSpan+        (atLine 1)+        [("DisableMutation: ConstBool", atLine 5), ("DisableMutation: BoolLit", atLine 9)]+        (DeadModuleDisable (ScopeDeadOperator "BoolLit"))+        `shouldBe` atLine 9++    it "points at the annotation that disables everything" $+      deadModuleDisableSpan+        (atLine 1)+        [("DisableMutation: ConstBool", atLine 5), ("DisableMutations", atLine 9)]+        (DeadModuleDisable ScopeDeadAll)+        `shouldBe` atLine 9++    it "points at the malformed annotation itself" $+      deadModuleDisableSpan+        (atLine 1)+        [("DisableMutationss: BoolLit", atLine 5)]+        (MalformedModuleAnnotation "DisableMutationss: BoolLit")+        `shouldBe` atLine 5++    it "falls back when no recorded annotation accounts for the complaint" $+      -- A payload that is not a literal string is invisible in the parsed+      -- AST, so there is no span to point at.+      deadModuleDisableSpan+        (atLine 1)+        []+        (DeadModuleDisable (ScopeDeadOperator "BoolLit"))+        `shouldBe` atLine 1