module Test.MuCheck.Mutation where
import Language.Haskell.Exts(Literal(Int, Char, Frac, String, PrimInt, PrimChar, PrimFloat, PrimDouble, PrimWord, PrimString),
Exp(App, Var, If), QName(UnQual),
Stmt(Qualifier), Module(Module),
Name(Ident, Symbol), Decl(FunBind, PatBind),
Pat(PVar), Match(Match), GuardedRhs(GuardedRhs),
prettyPrint, fromParseResult, parseFileContents)
import Data.Generics (Typeable, mkMp, listify)
import Data.List(nub, (\\), permutations)
import System.Random (RandomGen)
import Test.MuCheck.MuOp
import Test.MuCheck.Utils.Syb
import Test.MuCheck.Utils.Common
import Test.MuCheck.Config
import Test.MuCheck.TestAdapter
genMutants :: String -> FilePath -> IO [Mutant]
genMutants = genMutantsWith defaultConfig
genMutantsWith :: Config -> String -> FilePath -> IO [Mutant]
genMutantsWith args func filename = do
g <- genRandomSeed
f <- readFile filename
return $ genMutantsForSrc defaultConfig func f (sampler args g)
sampler :: RandomGen g => Config -> g -> MuVars -> [t] -> [t]
sampler args g m = sampleF g (getSample m args)
genMutantsForSrc :: Config -> String -> String -> (MuVars -> [MuOp] -> [MuOp]) -> [Mutant]
genMutantsForSrc args funcname src sampleFn = map prettyPrint programMutants
where astMod = getASTFromStr src
f = getFunc funcname astMod
ops, swapOps, valOps, ifElseNegOps, guardedBoolNegOps :: [MuOp]
ops = relevantOps f (muOps args ++ valOps ++ ifElseNegOps ++ guardedBoolNegOps)
swapOps = sampleFn MutatePatternMatch $ permMatches f ++ removeOnePMatch f
valOps = sampleFn MutateValues $ selectLitOps f ++ selectBLitOps f
ifElseNegOps = sampleFn MutateNegateIfElse $ selectIfElseBoolNegOps f
guardedBoolNegOps = sampleFn MutateNegateGuards $ selectGuardedBoolNegOps f
patternMatchMutants, ifElseNegMutants, guardedNegMutants, operatorMutants, allMutants :: [Decl]
allMutants = nub $ patternMatchMutants ++
operatorMutants ++
ifElseNegMutants ++
guardedNegMutants
patternMatchMutants = mutatesN swapOps f fstOrder
ifElseNegMutants = mutatesN ifElseNegOps f fstOrder
guardedNegMutants = mutatesN guardedBoolNegOps f fstOrder
operatorMutants = case genMode args of
FirstOrderOnly -> mutatesN ops f fstOrder
_ -> mutates ops f
programMutants :: [Module]
programMutants = map (putDecls astMod) [replaceDef f fn astMod | fn <- allMutants]
fstOrder = 1
replaceDef :: Decl -> Decl -> Module -> [Decl]
replaceDef oldf newf (Module _ _ _ _ _ _ decls) = replaceFst (oldf, newf) decls
getFunc :: String -> Module -> Decl
getFunc fname ast = head $ listify (isFunctionD fname) ast
mutates :: [MuOp] -> Decl -> [Decl]
mutates ops m = filter (/= m) $ concat [mutatesN ops m x | x <- enumFrom 1]
mutatesN :: [MuOp] -> Decl -> Int -> [Decl]
mutatesN ops ms 1 = concat [mutate op ms | op <- ops ]
mutatesN ops ms c = concat [mutatesN ops m 1 | m <- mutatesN ops ms $ pred c]
mutate :: MuOp -> Decl -> [Decl]
mutate op m = once (mkMpMuOp op) m \\ [m]
isFunctionD :: String -> Decl -> Bool
isFunctionD n (FunBind (Match _ (Ident n') _ _ _ _ : _)) = n == n'
isFunctionD n (FunBind (Match _ (Symbol n') _ _ _ _ : _)) = n == n'
isFunctionD n (PatBind _ (PVar (Ident n')) _ _) = n == n'
isFunctionD _ _ = False
permMatches :: Decl -> [MuOp]
permMatches d@(FunBind ms) = d ==>* map FunBind (permutations ms \\ [ms])
permMatches _ = []
removeOnePMatch :: Decl -> [MuOp]
removeOnePMatch (FunBind [_]) = []
removeOnePMatch d@(FunBind ms) = d ==>* map FunBind (removeOneElem ms \\ [ms])
removeOnePMatch _ = []
removeOneElem :: Eq t => [t] -> [[t]]
removeOneElem l = choose l (length l 1)
getASTFromStr :: String -> Module
getASTFromStr fname = fromParseResult $ parseFileContents fname
putDecls :: Module -> [Decl] -> Module
putDecls (Module a b c d e f _) decls = Module a b c d e f decls
selectValOps :: (Typeable b, Mutable b) => (b -> Bool) -> (b -> [b]) -> Decl -> [MuOp]
selectValOps predicate f m = concat [ x ==>* f x | x <- vals ]
where vals = listify predicate m
selectLitOps :: Decl -> [MuOp]
selectLitOps m = selectValOps isLit convert m
where isLit (Int _) = True
isLit (PrimInt _) = True
isLit (Char _) = True
isLit (PrimChar _) = True
isLit (Frac _) = True
isLit (PrimFloat _) = True
isLit (PrimDouble _) = True
isLit (String _) = True
isLit (PrimString _) = True
isLit (PrimWord _) = True
convert (Int i) = map Int $ nub [i + 1, i 1, 0, 1]
convert (PrimInt i) = map PrimInt $ nub [i + 1, i 1, 0, 1]
convert (Char c) = map Char [pred c, succ c]
convert (PrimChar c) = map Char [pred c, succ c]
convert (Frac f) = map Frac $ nub [f + 1.0, f 1.0, 0.0, 1.1]
convert (PrimFloat f) = map PrimFloat $ nub [f + 1.0, f 1.0, 0.0, 1.1]
convert (PrimDouble f) = map PrimDouble $ nub [f + 1.0, f 1.0, 0.0, 1.1]
convert (String _) = map String $ nub [""]
convert (PrimString _) = map PrimString $ nub [""]
convert (PrimWord i) = map PrimWord $ nub [i + 1, i 1, 0, 1]
selectBLitOps :: Decl -> [MuOp]
selectBLitOps m = selectValOps isLit convert m
where isLit (Ident "True") = True
isLit (Ident "False") = True
isLit _ = False
convert (Ident "True") = [Ident "False"]
convert (Ident "False") = [Ident "True"]
convert _ = []
selectIfElseBoolNegOps :: Decl -> [MuOp]
selectIfElseBoolNegOps m = selectValOps isIf (\(If e1 e2 e3) -> [If e1 e3 e2]) m
where isIf If{} = True
isIf _ = False
selectGuardedBoolNegOps :: Decl -> [MuOp]
selectGuardedBoolNegOps m = selectValOps isGuardedRhs negateGuardedRhs m
where isGuardedRhs GuardedRhs{} = True
boolNegate e@(Qualifier (Var (UnQual (Ident "otherwise")))) = [e]
boolNegate (Qualifier expr) = [Qualifier (App (Var (UnQual (Ident "not"))) expr)]
boolNegate x = [x]
negateGuardedRhs (GuardedRhs srcLoc stmts expr) = [GuardedRhs srcLoc s expr | s <- once (mkMp boolNegate) stmts]