diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ` 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 diff --git a/src/Test/Syd/Mutation/Plugin.hs b/src/Test/Syd/Mutation/Plugin.hs --- a/src/Test/Syd/Mutation/Plugin.hs +++ b/src/Test/Syd/Mutation/Plugin.hs @@ -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 @ + -- 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: ` ", + "and `DisableMutations: , `." + ] + 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 " 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 @/.json@ and a -- coloured human-readable rendering to @/.txt@. Each diff --git a/src/Test/Syd/Mutation/Plugin/Instrument.hs b/src/Test/Syd/Mutation/Plugin/Instrument.hs --- a/src/Test/Syd/Mutation/Plugin/Instrument.hs +++ b/src/Test/Syd/Mutation/Plugin/Instrument.hs @@ -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 @ 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 @ 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: `,", + "`DisableMutations: , `, `DisableMutationsFor `,", + "`DisableMutationFor : `", + "and `DisableMutationsFor : , `." + ] + -- | 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 @ — disable all operators inside the -- local binding named @\@. -- * @DisableMutationsFor : A, B@ — disable the listed operators inside @\@. -- * @DisableMutationFor : A@ — disable the single named operator inside @\@. -- -- @\@ 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 " 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 " 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 "" (no colon → default disable) - -- ": 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 "" or ": 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) diff --git a/src/Test/Syd/Mutation/Plugin/Operator/ConstConstructor.hs b/src/Test/Syd/Mutation/Plugin/Operator/ConstConstructor.hs --- a/src/Test/Syd/Mutation/Plugin/Operator/ConstConstructor.hs +++ b/src/Test/Syd/Mutation/Plugin/Operator/ConstConstructor.hs @@ -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) diff --git a/src/Test/Syd/Mutation/Plugin/Operator/ConstEmptyList.hs b/src/Test/Syd/Mutation/Plugin/Operator/ConstEmptyList.hs --- a/src/Test/Syd/Mutation/Plugin/Operator/ConstEmptyList.hs +++ b/src/Test/Syd/Mutation/Plugin/Operator/ConstEmptyList.hs @@ -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 []) diff --git a/src/Test/Syd/Mutation/Plugin/Operator/ListLit.hs b/src/Test/Syd/Mutation/Plugin/Operator/ListLit.hs --- a/src/Test/Syd/Mutation/Plugin/Operator/ListLit.hs +++ b/src/Test/Syd/Mutation/Plugin/Operator/ListLit.hs @@ -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 diff --git a/sydtest-mutation-plugin.cabal b/sydtest-mutation-plugin.cabal --- a/sydtest-mutation-plugin.cabal +++ b/sydtest-mutation-plugin.cabal @@ -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 diff --git a/test/Test/Syd/Mutation/Plugin/InstrumentSpec.hs b/test/Test/Syd/Mutation/Plugin/InstrumentSpec.hs --- a/test/Test/Syd/Mutation/Plugin/InstrumentSpec.hs +++ b/test/Test/Syd/Mutation/Plugin/InstrumentSpec.hs @@ -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 as a local DisableAllOps entry" $ parseFunMutationAnns ["DisableMutationsFor innerVar"] `shouldBe` FunMutationAnns (DisableOps []) (Map.singleton "innerVar" DisableAllOps) + [] it "parses DisableMutationsFor : A, B as a local DisableOps entry" $ parseFunMutationAnns ["DisableMutationsFor innerVar: BoolLit, ConstBool"] `shouldBe` FunMutationAnns (DisableOps []) (Map.singleton "innerVar" (DisableOps ["BoolLit", "ConstBool"])) + [] it "parses DisableMutationFor : 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" $ diff --git a/test/Test/Syd/Mutation/PluginSpec.hs b/test/Test/Syd/Mutation/PluginSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Mutation/PluginSpec.hs @@ -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: ` and `DisableMutations: , `." + + 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