sydtest-mutation-plugin 0.4.4.0 → 0.4.5.0
raw patch · 7 files changed
+292/−31 lines, 7 filesdep ~sydtest-mutation-runtimesetup-changed
Dependency ranges changed: sydtest-mutation-runtime
Files
- CHANGELOG.md +34/−0
- Setup.hs +2/−0
- src/Test/Syd/Mutation/Plugin/Instrument.hs +16/−2
- src/Test/Syd/Mutation/Plugin/Operator/ConstConstructor.hs +188/−0
- src/Test/Syd/Mutation/Plugin/Operator/Util.hs +48/−27
- src/Test/Syd/Mutation/Plugin/Operators.hs +1/−0
- sydtest-mutation-plugin.cabal +3/−2
CHANGELOG.md view
@@ -1,5 +1,39 @@ # Changelog +## [0.4.5.0] - 2026-07-29++### Added++* A `ConstConstructor` mutation operator: for an expression whose type has a+ nullary constructor, or a function returning one, it emits one mutant per+ nullary constructor of that type. This covers both an enumeration (`data+ ABC = A | B | C`, where every value can be switched to every other) and a+ type that merely has a constant (`data MyMaybe a = MyNothing | MyJust a`,+ where `MyNothing` is the only replacement) — generalising what `ConstBool`+ and `BoolLit` do for `Bool` and what `ConstNothing` and `MaybeOp` do for+ `Maybe`. Those three types (plus lists, whose `[]` `ConstEmptyList` and+ `ListLit` already cover) are excluded so no mutation is produced twice, as+ is the alternative replacing a constructor with itself, and any type with+ fewer than two constructors (including `()`), which has no alternative+ value to offer.++### Fixed++* A parenthesised expression is no longer mutated twice. Every operator that+ fired on the expression inside also fired on the `HsPar` node around it,+ recording two mutations that differ only in span and that no test can tell+ apart.++* An expression under an inline type signature is now instrumented. The+ walker did not descend into `e :: T`, so nothing inside such an expression+ was a mutation site for any operator.++* The manifest preview for a constant-function mutation on an infix operator+ of arity 3 or more no longer drops the operands. It rendered `a <+> b` as+ `(\_ _ _ -> v)`, which does not even have the type of the expression it+ replaces; the mutation applies the constant function to both operands, so+ the preview now reads `(\_ _ _ -> v) (a) (b)`.+ ## [0.4.4.0] - 2026-06-20 ### Fixed
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
src/Test/Syd/Mutation/Plugin/Instrument.hs view
@@ -941,8 +941,18 @@ -- 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'+ case unLoc le of+ -- Parentheses and an inline type signature are pure syntax: the expression+ -- inside has the same type and the same value, and the walker visits it in+ -- its own right. Offering these nodes to the operators as well would+ -- record every one of the inner expression's mutations a second time, at+ -- the wider span: two mutants that no test can tell apart, in a run whose+ -- cost is one test suite per mutation.+ HsPar {} -> pure le'+ ExprWithTySig {} -> pure le'+ _ -> do+ InstrumentEnv {instrumentEnvOperators} <- ask+ tryMutateWith instrumentEnvOperators le le' instrumentExpr :: SrcSpan -> HsExpr GhcTc -> InstrM (HsExpr GhcTc) instrumentExpr _sp = \case@@ -962,6 +972,10 @@ 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+ -- Without this case an inline type signature would hide its whole subtree+ -- from every operator: @f (g x :: T)@ would offer no mutation on @g x@ at+ -- all, since 'instrumentLExprGo' does not mutate the signature node itself.+ ExprWithTySig x e sig -> ExprWithTySig x <$> instrumentLExpr e <*> pure sig NegApp x e se -> NegApp x <$> instrumentLExpr e <*> pure se OpApp x l op r -> OpApp x <$> instrumentLExpr l <*> pure op <*> instrumentLExpr r ExplicitTuple x args bx -> ExplicitTuple x <$> mapM instrumentTupArg args <*> pure bx
+ src/Test/Syd/Mutation/Plugin/Operator/ConstConstructor.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.Mutation.Plugin.Operator.ConstConstructor (theOperator) where++import Control.Monad.Reader (asks)+import qualified Data.Text as T+import GHC+import GHC.Builtin.Types (boolTyCon, listTyCon, maybeTyCon)+import GHC.Core.ConLike (ConLike (RealDataCon))+import GHC.Core.DataCon (dataConFullSig, dataConWrapId)+import GHC.Core.TyCon (tyConDataCons_maybe)+import GHC.Core.Type (splitTyConApp_maybe)+import GHC.Types.Id (isDataConId_maybe)+import GHC.Types.Name.Occurrence (isSymOcc, occNameString)+import Test.Syd.Mutation.Plugin.Instrument (InstrM, InstrumentEnv (..), MutationAlt (..), MutationOperator (..), MutationOperatorKind (..), OpAppCtx (..), SrcSpanDelta (..))+import Test.Syd.Mutation.Plugin.Operator.Util (ConstFnMatch (..), ConstructorHeads (..), arrowTy, mkConstLambda, prefixFormPreview, viewConstFnResultBy)++-- | Replace an expression whose type is @arg1 -> ... -> argN -> T tys@ (with+-- @N >= 0@) with a constant function returning a nullary constructor of @T@,+-- one mutant per such constructor.+--+-- * At arity 0, the mutants are the bare constructors.+-- * At arity N \>= 1, they are @\\_ ... _ -> Con@, typed at GhcTc via+-- 'mkConstLambda' — the same shape 'ConstBool' and 'ConstNothing' use.+--+-- A nullary constructor is a constant of its type, so it type-checks wherever+-- a value of that type is expected. That covers both an enumeration+-- (@data ABC = A | B | C@, where every constructor is a constant, so every+-- value can be switched to every other) and a type that merely has one+-- (@data MyMaybe a = MyNothing | MyJust a@, where @MyNothing@ is the only+-- replacement offered) — the latter being the user-defined-type counterpart+-- of what 'ConstNothing' and 'MaybeOp' do for 'Maybe'.+--+-- Four restrictions keep the mutant set free of duplicates and no-ops:+--+-- * 'Bool', 'Maybe' and lists are excluded. @Nothing@ and @[]@ are nullary+-- constructors like any other, but 'ConstBool' and 'BoolLit',+-- 'ConstNothing' and 'MaybeOp', and 'ConstEmptyList' and 'ListLit'+-- already produce exactly these mutants for those three types.+-- * A type with fewer than two constructors is excluded: every value of it+-- is built from the same constructor, so no replacement can change+-- anything. (This also rules out @()@ and tuples.)+-- * A constructor is a candidate replacement only when it takes no+-- arguments /and/ its signature has no existentials, no constraints, and+-- no GADT equality: otherwise it is not a constant, or not one at the+-- type this site needs. This is GHC's own @is_enum_con@ test, applied+-- per constructor rather than to the whole type.+-- * Unlike the rest of the @Const…@ family this operator matches+-- constructor-headed expressions, since for a user-defined type no other+-- operator claims them. It drops the alternative that replaces a+-- constructor with itself, which would be an unkillable no-op.+--+-- An arity-\>=1 firing is suppressed when 'instrumentEnvAppDepth' >= arity;+-- see 'ConstNothing' for that dominance rule.+--+-- The manifest preview names the constructor unqualified even when the+-- mutated module does not have it in scope. The mutant itself is built from+-- the constructor's 'Id' and compiles regardless of scope, so this only+-- affects how the diff reads.+theOperator :: MutationOperator+theOperator =+ MutationOperator+ { operatorName = "ConstConstructor",+ operatorDescription = "Replace an expression (or a function's result) with a constant constructor of its type",+ operatorKind = ExpressionOperator $ \le -> do+ m <- viewConstFnResultBy AllowConstructorHeads 0 hasConstantDataCons le+ cons <- constantDataConsOfType (cfnResTy m)+ pure (action le m cons)+ }++action ::+ LHsExpr GhcTc ->+ ConstFnMatch ->+ [DataCon] ->+ InstrM [MutationAlt]+action le ConstFnMatch {cfnArgTys, cfnResTy, cfnTyConArgs} cons = do+ opAppCtx <- asks instrumentEnvOpAppCtx+ appDepth <- asks instrumentEnvAppDepth+ let arity = length cfnArgTys+ -- See 'ConstNothing' for the dominance rule.+ if arity >= 1 && appDepth >= arity+ then pure []+ else+ let wholeTy = arrowTy cfnArgTys cfnResTy+ -- The constructor this expression is already built from, if any.+ -- Replacing it with itself is dropped below.+ headCon = constructorHead le+ atOpToken = case (arity, opAppCtx, getLocA le) of+ (n, Just ctx, RealSrcSpan mSp _) | n >= 1, mSp == opAppOpSpan ctx -> Just ctx+ _ -> Nothing+ mkAlt dc =+ let conName = conSourceName dc+ -- Instantiating the constructor's type arguments matters for+ -- a parameterised type (@data MyMaybe a = MyNothing |+ -- MyJust a@): the bare constructor is @forall a. MyMaybe a@,+ -- whose 'forall' would make the surrounding @ifMutation \@ty@+ -- wrapper ill-typed. See 'mkNothingExpr' for what that+ -- miscompiles into.+ v = nlHsTyApp (dataConWrapId dc) cfnTyConArgs+ mutated = mkConstLambda cfnArgTys cfnResTy v+ delta = case atOpToken of+ Just ctx ->+ ReplaceOuterSpan+ (opAppOuterSpan ctx)+ (prefixFormPreview arity (T.pack conName) (opAppLhsText ctx) (opAppRhsText ctx))+ Nothing ->+ let tokenText = case cfnArgTys of+ [] -> T.pack conName+ _ -> T.concat ["(\\", T.replicate arity "_ ", "-> ", T.pack conName, ")"]+ in TokenReplace tokenText+ origLabel = case cfnArgTys of+ [] -> maybe "e" conSourceName headCon+ _ -> "f"+ replLabel = case cfnArgTys of+ [] -> conName+ _ -> "\\" ++ unwords (replicate arity "_") ++ " -> " ++ conName+ in MutationAlt+ { mutAltType = wholeTy,+ mutAltExpr = mutated,+ mutAltOriginal = origLabel,+ mutAltReplacement = replLabel,+ mutAltDelta = delta,+ mutAltMitigation = Nothing+ }+ in pure [mkAlt dc | dc <- cons, Just dc /= headCon]++-- | How the constructor is written in an expression: a symbolic constructor+-- like @(:<)@ needs its parentheses to be one.+conSourceName :: DataCon -> String+conSourceName dc =+ let occ = getOccName dc+ in if isSymOcc occ+ then concat ["(", occNameString occ, ")"]+ else occNameString occ++-- | Whether the const-family matcher should accept a result type headed by+-- this TyCon.+hasConstantDataCons :: TyCon -> Bool+hasConstantDataCons tc = case constantDataCons tc of+ Just _ -> True+ Nothing -> False++-- | The constructors to mutate to, for a result type accepted by+-- 'hasConstantDataCons'.+constantDataConsOfType :: Type -> Maybe [DataCon]+constantDataConsOfType ty = do+ (tc, _) <- splitTyConApp_maybe ty+ constantDataCons tc++-- | The constant constructors of a TyCon this operator handles, or 'Nothing'+-- when it handles none of them.+constantDataCons :: TyCon -> Maybe [DataCon]+constantDataCons tc+ | tc `elem` [boolTyCon, maybeTyCon, listTyCon] = Nothing+ | otherwise = do+ cons <- tyConDataCons_maybe tc+ case cons of+ (_ : _ : _) -> case filter isConstantDataCon cons of+ [] -> Nothing+ constants -> Just constants+ _ -> Nothing++-- | Whether a constructor is a constant of @T tys@ for every @tys@: it takes+-- no arguments, and its signature does not refine the type with+-- existentials, constraints, or a GADT equality, so applying the type+-- arguments of the site being mutated builds a value of exactly that type.+isConstantDataCon :: DataCon -> Bool+isConstantDataCon dc =+ let (_univTvs, exTvs, eqSpec, theta, argTys, _resTy) = dataConFullSig dc+ in null exTvs && null eqSpec && null theta && null argTys++-- | The data constructor an expression is built from, if it is a constructor+-- application. Peels the wrappers the typechecker leaves around a+-- constructor occurrence, mirroring+-- 'Test.Syd.Mutation.Plugin.Operator.Util.nonConstructorHead'.+constructorHead :: LHsExpr GhcTc -> Maybe DataCon+constructorHead = \case+ L _ (XExpr (ConLikeTc (RealDataCon dc) _ _)) -> Just dc+ L _ (HsVar _ (L _ v)) -> isDataConId_maybe v+ L _ (HsApp _ f _) -> constructorHead f+ L _ (HsAppType _ f _) -> constructorHead f+ L _ (HsPar _ e) -> constructorHead e+ L _ (ExprWithTySig _ e _) -> constructorHead e+ L _ (XExpr (WrapExpr (HsWrap _ e))) -> constructorHead (noLocA e)+ L _ (XExpr (ExpandedThingTc _ e)) -> constructorHead (noLocA e)+ _ -> Nothing
src/Test/Syd/Mutation/Plugin/Operator/Util.hs view
@@ -9,6 +9,8 @@ matchTcOpApp, ConstFnMatch (..), viewConstFnResult,+ viewConstFnResultBy,+ ConstructorHeads (..), mkNothingExpr, mkConstLambda, arrowTy,@@ -236,20 +238,44 @@ -- @N >= minArity@, return the peeled arrow argument types, the final result -- type, and the target TyCon's arguments. Used by the @Const…@ family. --+-- Constructor-headed expressions are skipped; see 'viewConstFnResultBy' for+-- the full list of rejection reasons.+viewConstFnResult :: Int -> TyCon -> LHsExpr GhcTc -> Maybe ConstFnMatch+viewConstFnResult minArity targetTyCon =+ viewConstFnResultBy SkipConstructorHeads minArity (== targetTyCon)++-- | Whether an expression whose outermost head is a data constructor is a+-- candidate for a @Const…@ operator.+data ConstructorHeads+ = -- | Skip them. A dedicated operator already claims the target type's+ -- constructor applications ('BoolLit' for @True@ and @False@, 'MaybeOp'+ -- for @Just e@, 'ListLit' for @x : xs@), so matching them here would+ -- duplicate that operator's mutations.+ SkipConstructorHeads+ | -- | Match them too. Sound only when no other operator claims the target+ -- type's constructor applications, and the operator itself drops the+ -- alternative that replaces the expression with the constructor it+ -- already is.+ AllowConstructorHeads++-- | 'viewConstFnResult' generalised over the result TyCon and over whether+-- constructor-headed expressions match.+-- -- 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,+-- * @le@'s outermost head is a data constructor and @heads@ is+-- 'SkipConstructorHeads', -- * 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@,+-- * after peeling arrows, the result type does not split as @tc args@ with+-- @tc@ accepted by the predicate, -- * the arity (number of arrows peeled) is less than @minArity@.-viewConstFnResult :: Int -> TyCon -> LHsExpr GhcTc -> Maybe ConstFnMatch-viewConstFnResult minArity targetTyCon le = do- () <- nonConstructorHead le+viewConstFnResultBy :: ConstructorHeads -> Int -> (TyCon -> Bool) -> LHsExpr GhcTc -> Maybe ConstFnMatch+viewConstFnResultBy heads minArity isTargetTyCon le = do+ () <- case heads of+ SkipConstructorHeads -> nonConstructorHead le+ AllowConstructorHeads -> Just () let ty = lhsExprType le if isForAllTy ty then Nothing@@ -259,7 +285,7 @@ then Nothing else do (tc, tcArgs) <- splitTyConApp_maybe resTy- if tc == targetTyCon+ if isTargetTyCon tc then Just (ConstFnMatch argTys resTy tcArgs) else Nothing @@ -354,12 +380,15 @@ -- 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.+-- arity \>= 2: @(\\_ _ -> v) (lhsText) (rhsText)@ — the mutant stands in+-- for the operator, which the enclosing @OpApp@ applies to+-- both operands however many arguments it goes on to take.+-- 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.+-- Callers only reach here at arity \>= 1 (a constant needs no prefix form). prefixFormPreview :: -- | Arity of the constant function being inserted. Int ->@@ -371,16 +400,10 @@ Text -> Text prefixFormPreview arity vText lhsText rhsText =- let lam =- "(\\"- <> T.replicate arity "_ "- <> "-> "- <> vText- <> ")"+ let lam = T.concat ["(\\", T.replicate arity "_ ", "-> ", vText, ")"] in case arity of- 2 -> lam <> " (" <> lhsText <> ") (" <> rhsText <> ")"- 1 -> lam <> " (" <> rhsText <> ")"- _ -> lam+ 1 -> T.concat [lam, " (", rhsText, ")"]+ _ -> T.concat [lam, " (", lhsText, ") (", rhsText, ")"] -- | The value arguments of a prefix application, in source order, together -- with the function at the head.@@ -389,12 +412,10 @@ -- 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.+-- Stops at an 'HsPar', so @(f) a b@ is read as an application of the+-- parenthesised head rather than of @f@. The head is only ever used to+-- identify and rebuild the application, both of which work just as well with+-- the parentheses left in place. collectApp :: LHsExpr GhcTc -> (LHsExpr GhcTc, [LHsExpr GhcTc]) collectApp = go [] where
src/Test/Syd/Mutation/Plugin/Operators.hs view
@@ -16,6 +16,7 @@ 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.ConstConstructor import qualified Test.Syd.Mutation.Plugin.Operator.ConstEmptyList import qualified Test.Syd.Mutation.Plugin.Operator.ConstNothing import qualified Test.Syd.Mutation.Plugin.Operator.ElideCall
sydtest-mutation-plugin.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest-mutation-plugin-version: 0.4.4.0+version: 0.4.5.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@@ -31,6 +31,7 @@ Test.Syd.Mutation.Plugin.Operator.BoolLit Test.Syd.Mutation.Plugin.Operator.Cmp Test.Syd.Mutation.Plugin.Operator.ConstBool+ Test.Syd.Mutation.Plugin.Operator.ConstConstructor Test.Syd.Mutation.Plugin.Operator.ConstEmptyList Test.Syd.Mutation.Plugin.Operator.ConstNothing Test.Syd.Mutation.Plugin.Operator.ElideCall@@ -67,7 +68,7 @@ , path , path-io , safe-coloured-text- , sydtest-mutation-runtime >=0.1+ , sydtest-mutation-runtime >=0.1.1 , template-haskell , text default-language: Haskell2010