{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Syd.Mutation.Plugin (plugin) where
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Data (Data, cast, gmapQ)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Data.List (isPrefixOf, stripPrefix)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import GHC
import GHC.Data.FastString (unpackFS)
import GHC.Driver.Env (Hsc, HscEnv (..))
import GHC.Driver.Plugins
import GHC.Driver.Session (WarningFlag (..), wopt_unset)
import GHC.Serialized (deserializeWithData)
import GHC.Tc.Types
import GHC.Types.Annotations (AnnTarget (..), findAnns)
import Path
import System.IO.Unsafe (unsafePerformIO)
import Test.Syd.Mutation.Manifest (MutationGroup (..), MutationManifest (..), writeManifestFile)
import Test.Syd.Mutation.Manifest.Render (writeManifestTxtFile)
import Test.Syd.Mutation.Plugin.Instrument
import Test.Syd.Mutation.Plugin.Operators (allOperators)
import Test.Syd.Mutation.Plugin.OptParse
( Settings (..),
operatorsConfigDisabled,
resolveSettings,
)
data DisabledMutation
= DisableAll
| DisableNamed String
deriving (Eq)
-- | Parse a list of @{-# ANN #-}@ string payloads into disabled-mutation specs.
--
-- Recognised formats:
-- @"DisableMutations"@ — disable all mutations on this scope
-- @"DisableMutations: Arith, BoolLit"@ — disable the listed mutation types
-- @"DisableMutation: Arith"@ — disable exactly one named mutation type
--
-- Spaces after the colon and after each comma are optional.
parseMutationAnnStrings :: [String] -> [DisabledMutation]
parseMutationAnnStrings = concatMap parse
where
parse s
| s == "DisableMutations" = [DisableAll]
| Just rest <- stripPrefix "DisableMutations:" s =
map (DisableNamed . trim) (splitOnComma rest)
| Just rest <- stripPrefix "DisableMutation:" s =
[DisableNamed (trim rest)]
| otherwise = []
trim :: String -> String
trim = dropWhile (== ' ')
splitOnComma :: String -> [String]
splitOnComma s = case break (== ',') s of
(w, []) -> [w]
(w, _ : rest) -> w : splitOnComma rest
plugin :: Plugin
plugin =
defaultPlugin
{ -- We instrument at the typechecked stage (GhcTc) so that mutations can
-- be type-directed (e.g. replace any expression of type 'Maybe a' with
-- 'Nothing', or only mutate '+' when the operands are numeric).
typeCheckResultAction = mutationTypeCheckAction,
-- Add an import of Test.Syd.Mutation.Plugin.Runtime at the parsed stage so that
-- ifMutation and MutationId are in tcg_rdr_env for the typecheck action.
parsedResultAction = mutationAddRuntimeImport,
-- Suppress -Wunused-imports for the injected import of Test.Syd.Mutation.Plugin.Runtime.
driverPlugin = \_ hscEnv ->
pure
hscEnv
{ hsc_dflags =
foldl
wopt_unset
(hsc_dflags hscEnv)
[ Opt_WarnUnusedImports,
-- Guard instrumentation wraps conditions in ifMutation, making the
-- exhaustiveness checker conservatively warn about patterns it can
-- no longer prove complete.
Opt_WarnIncompletePatterns,
Opt_WarnIncompleteUniPatterns
]
},
-- Recompile only when plugin flags change. We previously used
-- 'impurePlugin' (always force recompile), but that prevents the
-- two-step build in nix/addManifest.nix from working: the postBuild
-- step that compiles test-suites/executables re-invokes 'Setup build'
-- with the same plugin flags, and with 'impurePlugin' GHC would
-- recompile the already-instrumented library un-instrumented (the
-- env-var kill switch tells the plugin to instrument nothing).
-- 'flagRecompile' fingerprints only the plugin's CLI options, so the
-- library is not recompiled when the flags are identical between the
-- two invocations. Source-level changes still trigger recompile via
-- GHC's normal mechanism.
pluginRecompile = flagRecompile
}
-- | Inject @import Test.Syd.Mutation.Plugin.Runtime ()@ into every instrumented module.
-- This ensures sydtest-mutation-plugin is registered as used (it is already in
-- build-depends as the plugin package), and satisfies -Wunused-packages.
--
-- Also, when @--skip-th-splices@ is set, walk the parsed AST to collect
-- 'RealSrcSpan's covering every 'HsUntypedSplice', 'HsTypedSplice', and
-- declaration-level 'SpliceD'. These are stored in a process-global IORef
-- keyed by module name and consulted by 'recordMutation' (via the
-- 'instrumentEnvSpliceSpans' field of 'InstrumentEnv') to drop mutations whose own
-- span is contained inside any splice span.
--
-- Why parse-time: many top-level splices (e.g. @mkYesodData@,
-- @mkPersist [persistLowerCase| ... |]@) are evaluated during renaming and
-- their results are spliced into the typechecker as if they were original
-- code, so the typechecked AST no longer carries an 'ExpandedThingTc'
-- wrapper we could pattern-match on. The original splice nodes are still
-- present in the parsed AST.
mutationAddRuntimeImport ::
[CommandLineOption] ->
ModSummary ->
ParsedResult ->
Hsc ParsedResult
mutationAddRuntimeImport opts ms pr = do
let mn = moduleNameString (moduleName (ms_mod ms))
Settings
{ settingExceptions = exceptions,
settingSkipThSplices = skipThSplices
} <-
liftIO $ resolveSettings opts
if "Paths_" `isPrefixOf` mn || mn `elem` exceptions
then pure pr
else do
let pm = parsedResultModule pr
lm = hpm_module pm
-- Look for a module-level
-- {-# ANN module ("DisableMutations" :: String) #-} in the parsed
-- AST. When present, this module will be skipped in the
-- typecheck phase, so there's no point in walking its AST here to
-- collect splice spans. Keep the runtime-import injection
-- regardless, so -Wunused-packages stays happy on the
-- sydtest-mutation-plugin dep.
disabled = hasDisableMutationsAnn (unLoc lm)
liftIO $
when (skipThSplices && not disabled) $ do
let spliceRanges = collectSpliceSpans lm
atomicModifyIORef' spliceSpansMap (\m -> (Map.insert mn spliceRanges m, ()))
let runtimeImport = noLocA (simpleImportDecl (mkModuleName "Test.Syd.Mutation.Plugin.Runtime"))
lm' = fmap (\m -> m {hsmodImports = runtimeImport : hsmodImports m}) lm
pure pr {parsedResultModule = pm {hpm_module = lm'}}
-- | Recognise @{-# ANN module ("DisableMutations" :: String) #-}@ at the
-- top level of the parsed module. Only looks at module-level annotations
-- (ignores @ANN someFunction ...@) so it mirrors the typecheck-phase
-- check that uses 'tcg_ann_env' with 'ModuleTarget'.
hasDisableMutationsAnn :: HsModule GhcPs -> Bool
hasDisableMutationsAnn m = any isDisableMutationsDecl (hsmodDecls m)
where
isDisableMutationsDecl :: LHsDecl GhcPs -> Bool
isDisableMutationsDecl (L _ d) = case d of
AnnD _ (HsAnnotation _ ModuleAnnProvenance {} expr) ->
annExprIsDisableMutations expr
_ -> False
-- The payload of {-# ANN module ("DisableMutations" :: String) #-}
-- parses as @ExprWithTySig _ "DisableMutations" String@; strip
-- parentheses and type signatures to find the underlying string.
annExprIsDisableMutations :: LHsExpr GhcPs -> Bool
annExprIsDisableMutations le = case unLoc (stripExpr le) of
HsLit _ (HsString _ s) -> unpackFS s == "DisableMutations"
_ -> False
stripExpr :: LHsExpr GhcPs -> LHsExpr GhcPs
stripExpr le = case unLoc le of
HsPar _ inner -> stripExpr inner
ExprWithTySig _ inner _ -> stripExpr inner
_ -> le
-- | Per-module splice spans collected by 'mutationAddRuntimeImport' when
-- @--skip-th-splices@ is set, read back by 'mutationTypeCheckAction' and
-- threaded through 'InstrumentEnv'. Lives in a process-global IORef
-- because 'Hsc' and 'TcM' don't share state cleanly across compilation
-- units, and GHC may compile many modules in one process. Switched from
-- 'stm-containers' to 'IORef'+'atomicModifyIORef'' to avoid loading the
-- 'stm' package into the GHC-as-host process, which has been observed to
-- hang the plugin during the parsed-result action on real-world libraries
-- (e.g. safe-coloured-text).
{-# NOINLINE spliceSpansMap #-}
spliceSpansMap :: IORef (Map String [RealSrcSpan])
spliceSpansMap = unsafePerformIO (newIORef Map.empty)
-- | Generic traversal that collects 'RealSrcSpan's of all parsed-AST
-- splice and quasi-quote nodes. Uses 'Data' generics so we don't have
-- to enumerate every constructor of the AST.
collectSpliceSpans :: (Data a) => a -> [RealSrcSpan]
collectSpliceSpans x = here ++ concat (gmapQ collectSpliceSpans x)
where
here :: [RealSrcSpan]
here =
case (cast x :: Maybe (LHsExpr GhcPs)) of
Just le | isSpliceLExpr le -> realSpan (getLocA le)
_ -> case (cast x :: Maybe (LHsDecl GhcPs)) of
Just ld | isSpliceLDecl ld -> realSpan (getLocA ld)
_ -> []
realSpan (RealSrcSpan rss _) = [rss]
realSpan _ = []
isSpliceLExpr :: LHsExpr GhcPs -> Bool
isSpliceLExpr (L _ e) = case e of
HsUntypedSplice _ _ -> True
HsTypedSplice _ _ -> True
_ -> False
isSpliceLDecl :: LHsDecl GhcPs -> Bool
isSpliceLDecl (L _ d) = case d of
SpliceD _ _ -> True
_ -> False
mutationTypeCheckAction ::
[CommandLineOption] ->
ModSummary ->
TcGblEnv ->
TcM TcGblEnv
mutationTypeCheckAction opts ms tcGblEnv = do
let mn = moduleNameString (moduleName (tcg_mod tcGblEnv))
Settings
{ settingExceptions = exceptions,
settingDisabledMutations = disabledFromConfig,
settingIgnore = ignore,
settingSkipThSplices = skipThSplices,
settingOperators = operatorsConfig,
settingDebug = debug,
settingSkipInstrumentation = skipInstrumentation,
settingManifestDir = manifestDir
} <-
liftIO $ resolveSettings opts
-- Operators turned off via @operators.<Name>.enable: false@ are disabled
-- exactly as if listed in @disabled-mutations@. Operator-specific options
-- ride along in each operator's config entry and are read by the operator.
let disabledFromOperatorsConfig = operatorsConfigDisabled operatorsConfig
if "Paths_" `isPrefixOf` mn || mn `elem` exceptions || skipInstrumentation
then pure tcGblEnv
else do
let annEnv = tcg_ann_env tcGblEnv
let modAnns = findAnns deserializeWithData annEnv (ModuleTarget (tcg_mod tcGblEnv)) :: [String]
let disabledFromModAnns = parseMutationAnnStrings modAnns
-- A "disable-mutations" annotation with no names means disable all
-- mutations for this module. Skip both the AST walk and the splice-
-- span lookup; the module's compiled artefacts are returned unchanged.
if DisableAll `elem` disabledFromModAnns
then do
liftIO $ putStrLn $ "mutation: skipping " ++ mn ++ " (DisableMutations)"
pure tcGblEnv
else do
let disabledNames = disabledFromConfig ++ disabledFromOperatorsConfig ++ [n | DisableNamed n <- disabledFromModAnns]
liftIO $ putStrLn $ "mutation: instrumenting " ++ mn
let mSrcPath = ml_hs_file (ms_location ms)
spliceSpans <-
if skipThSplices
then liftIO $ Map.findWithDefault [] mn <$> readIORef spliceSpansMap
else pure []
(binds', groups) <-
runInstrument tcGblEnv allOperators annEnv disabledNames mSrcPath debug skipThSplices operatorsConfig spliceSpans ignore $
instrumentModule (tcg_binds tcGblEnv)
let totalMutations = sum [length rs | MutationGroup rs <- groups]
liftIO $ do
putStrLn $ "added " ++ show totalMutations ++ " mutations in " ++ show (length groups) ++ " groups"
case manifestDir of
Nothing -> pure ()
Just dir -> writeModuleManifest dir mn groups
pure tcGblEnv {tcg_binds = binds'}
-- | Write the manifest for one module to @<dir>/<ModuleName>.json@ and a
-- coloured human-readable rendering to @<dir>/<ModuleName>.txt@. Each
-- module gets its own pair of files, so no locking is needed.
--
-- The @.txt@ is what reviewers diff during code review; it uses the same
-- header + unified-diff layout as the runtime's surviving-mutation report.
writeModuleManifest :: Path Abs Dir -> String -> [MutationGroup] -> IO ()
writeModuleManifest dir mn groups = do
let manifest = MutationManifest groups
writeManifestFile dir mn manifest
writeManifestTxtFile dir mn manifest