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