diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Test/Syd/Mutation/Plugin/Instrument.hs b/src/Test/Syd/Mutation/Plugin/Instrument.hs --- a/src/Test/Syd/Mutation/Plugin/Instrument.hs +++ b/src/Test/Syd/Mutation/Plugin/Instrument.hs @@ -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 diff --git a/src/Test/Syd/Mutation/Plugin/Operator/ConstConstructor.hs b/src/Test/Syd/Mutation/Plugin/Operator/ConstConstructor.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Mutation/Plugin/Operator/ConstConstructor.hs @@ -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 diff --git a/src/Test/Syd/Mutation/Plugin/Operator/Util.hs b/src/Test/Syd/Mutation/Plugin/Operator/Util.hs --- a/src/Test/Syd/Mutation/Plugin/Operator/Util.hs +++ b/src/Test/Syd/Mutation/Plugin/Operator/Util.hs @@ -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 diff --git a/src/Test/Syd/Mutation/Plugin/Operators.hs b/src/Test/Syd/Mutation/Plugin/Operators.hs --- a/src/Test/Syd/Mutation/Plugin/Operators.hs +++ b/src/Test/Syd/Mutation/Plugin/Operators.hs @@ -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 diff --git a/sydtest-mutation-plugin.cabal b/sydtest-mutation-plugin.cabal --- a/sydtest-mutation-plugin.cabal +++ b/sydtest-mutation-plugin.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest-mutation-plugin -version: 0.4.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