diff --git a/MuCheck.cabal b/MuCheck.cabal --- a/MuCheck.cabal +++ b/MuCheck.cabal @@ -1,12 +1,13 @@ name: MuCheck -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Automated Mutation Testing description: This package defines a mutation analysis library for haskell programs. It does this by parsing the haskell source, and replacing a few of the common haskell functions and operators with other, but similar operators and functions, and running the testsuite to check whether the difference has been - detected. Currently, it supports QuickCheck and HUnit tests. + detected. Currently, it supports QuickCheck, HUnit and Hspec + tests. homepage: https://bitbucket.com/osu-testing/mucheck license: GPL-2 license-file: LICENSE @@ -18,21 +19,25 @@ build-type: Simple cabal-version: >= 1.10 +source-repository head + type: git + location: https://bitbucket.org/osu-testing/mucheck.git + source-repository this type: git location: https://bitbucket.org/osu-testing/mucheck.git - tag: 0.1.0.1 + tag: 0.1.2.0 executable mucheck main-is: Main.hs - build-depends: base >=4 && <5, haskell-src-exts >=1.13, syb >= 0.4.0, time >= 1.4.0.1, QuickCheck>=2.6, hint >= 0.3.1.0, mtl>=2.1.2, HUnit >= 1.0, filepath, hspec >= 2.0, hspec-core >= 2.0 + build-depends: base >=4 && <5, haskell-src-exts >=1.13, syb >= 0.4.0, time >= 1.4.0.1, QuickCheck>=2.6, hint >= 0.3.1.0, mtl>=2.1.2, HUnit >= 1.0, filepath, hspec >= 2.0, hspec-core >= 2.0, random default-language: Haskell2010 hs-source-dirs: src library exposed-modules: MuCheck.MuOp, MuCheck.StdArgs, MuCheck.Interpreter, MuCheck.Mutation, MuCheck.Operators, MuCheck.Utils.Syb, MuCheck.Utils.Common, MuCheck.Utils.Print -- other-modules: - build-depends: base >=4 && <5, haskell-src-exts >=1.13, syb >= 0.4.0, time >= 1.4.0.1, QuickCheck>=2.6, hint >= 0.3.1.0, mtl>=2.1.2, HUnit >= 1.0, filepath, hspec>= 2.0, hspec-core >= 2.0 + build-depends: base >=4 && <5, haskell-src-exts >=1.13, syb >= 0.4.0, time >= 1.4.0.1, QuickCheck>=2.6, hint >= 0.3.1.0, mtl>=2.1.2, HUnit >= 1.0, filepath, hspec>= 2.0, hspec-core >= 2.0, random default-language: Haskell2010 hs-source-dirs: src @@ -41,5 +46,5 @@ hs-source-dirs: test main-is: Spec.hs default-language: Haskell2010 - build-depends: base >=4 && <5, haskell-src-exts >=1.13, syb >= 0.4.0, time >= 1.4.0.1, QuickCheck>=2.6, hint >= 0.3.1.0, mtl>=2.1.2, HUnit >= 1.0, filepath, hspec>= 2.0, hspec-core >= 2.0, MuCheck + build-depends: base >=4 && <5, haskell-src-exts >=1.13, syb >= 0.4.0, time >= 1.4.0.1, QuickCheck>=2.6, hint >= 0.3.1.0, mtl>=2.1.2, HUnit >= 1.0, filepath, hspec>= 2.0, hspec-core >= 2.0, MuCheck, random diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,22 +1,28 @@ module Main where -import System.Environment +import System.Environment (getArgs, withArgs) +import Control.Monad (void) import MuCheck.MuOp -import Language.Haskell.Exts import MuCheck.StdArgs -import MuCheck.Interpreter import MuCheck.Mutation import MuCheck.Operators import MuCheck.Utils.Common import MuCheck.Utils.Print +import MuCheck.Interpreter +import MuCheck.Run.QuickCheck +import MuCheck.Run.HUnit +import MuCheck.Run.Hspec process :: String -> String -> String -> String -> [String] -> IO () process t fn file modulename args = do numMutants <- genMutants fn file + let muts = take numMutants $ genFileNames file + l = "./" ++ t ++ ".log" + fn f = void $ f muts modulename args l case t of - "qcheck" -> checkQuickCheckOnMutants (take numMutants $ genFileNames file) modulename args "./qcheck.log" >> return () - "hspec" -> checkHspecOnMutants (take numMutants $ genFileNames file) modulename args "./hspec.log" >> return () - "hunit" -> checkHUnitOnMutants (take numMutants $ genFileNames file) modulename args "./hunit.log" >> return () + "qcheck" -> fn checkQuickCheckOnMutants + "hspec" -> fn checkHspecOnMutants + "hunit" -> fn checkHUnitOnMutants _ -> error "Unexpected test type" @@ -29,8 +35,8 @@ _ -> error "Need [qcheck|hunit|hspec] function file modulename [args]\n\tUse -h to get help" help :: IO () -help = putStrLn ("mucheck type function file modulename [args]\n" ++ (showAS ["E.g:", +help = putStrLn $ "mucheck type function file modulename [args]\n" ++ showAS ["E.g:", " ./mucheck qcheck qsort Examples/QuickCheckTest.hs Examples.QuickCheckTest 'quickCheckResult idEmpProp' 'quickCheckResult revProp' 'quickCheckResult modelProp'", " ./mucheck hunit qsort Examples/HUnitTest.hs Examples.HUnitTest 'runTestTT tests'", - " ./mucheck hspec qsort Examples/HspecTest.hs Examples.HspecTest 'spec (with \\\"qsort1\\\")'"])) + " ./mucheck hspec qsort Examples/HspecTest.hs Examples.HspecTest 'spec (with \\\"qsort1\\\")'"] diff --git a/src/MuCheck/Interpreter.hs b/src/MuCheck/Interpreter.hs --- a/src/MuCheck/Interpreter.hs +++ b/src/MuCheck/Interpreter.hs @@ -9,65 +9,82 @@ import Data.Typeable import MuCheck.Utils.Print (showA, showAS, (./.)) import Data.Either (partitionEithers, rights) -import Data.List((\\), groupBy, sortBy, intercalate, isInfixOf) -import Data.Time.Clock - -deriving instance Typeable Qc.Result -deriving instance Typeable HUnit.Counts -deriving instance Typeable Hspec.Summary +import Data.List(groupBy, sortBy) +import Data.Function (on) -type InterpreterOutput a = Either I.InterpreterError (String, a) +import MuCheck.Run.Common +import MuCheck.Run.QuickCheck +import MuCheck.Run.HUnit +import MuCheck.Run.Hspec +-- | run quickcheck test suite on mutants +-- @ +-- >>> numMutants <- genMutants "qsort" "Examples/QuickCheckTest.hs" +-- >>> checkQuickCheckOnMutants (take numMutants $ genFileNames -- "Examples/QuickCheckTest.hs") "Examples.QuickCheckTest" ["quickCheckResult idEmpProp", "quickCheckResult revProp", "quickCheckResult modelProp"] "./quickcheck.log" +-- @ checkQuickCheckOnMutants :: [String] -> String -> [String] -> String -> IO [Qc.Result] checkQuickCheckOnMutants = mutantCheckSummary +-- | run hunit test suite on mutants +-- @ +-- >>> numMutants <- genMutants "qsort" "Examples/HUnitTest.hs" +-- >>> checkHUnitOnMutants (take numMutants $ genFileNames "Examples/HUnitTest.hs") "Examples.HUnitTest" ["runTestTT tests"] "./hunit.log" +-- @ checkHUnitOnMutants :: [String] -> String -> [String] -> String -> IO [HUnit.Counts] checkHUnitOnMutants = mutantCheckSummary +-- | run hspec test suite on mutants +-- @ +-- >>> numMutants <- genMutants "qsort" "Examples/HspecTest.hs" +-- >>> checkHspecOnMutants (take numMutants $ genFileNames "Examples/HspecTest.hs") "Examples.HspecTest" ["spec (with \"qsort1\")"] "./hspec.log" +-- @ checkHspecOnMutants :: [String] -> String -> [String] -> String -> IO [Hspec.Summary] checkHspecOnMutants = mutantCheckSummary --- main entry point -mutantCheckSummary :: Summarizable a => [String] -> String -> [String] -> FilePath -> IO [a] +-- | Given the list of tests suites to check, run one test suite at a time on +-- all mutants. +mutantCheckSummary :: (Summarizable a, Show a) => [String] -> String -> [String] -> FilePath -> IO [a] mutantCheckSummary mutantFiles topModule evalSrcLst logFile = do results <- mapM (runCodeOnMutants mutantFiles topModule) evalSrcLst let singleTestSummaries = zip evalSrcLst $ map (testSummary mutantFiles) results - tssum = suiteSummary results + tssum = multipleCheckSummary (isSuccess . snd) results -- print results to terminal putStrLn $ delim ++ "Overall Results:" putStrLn $ terminalSummary tssum putStrLn $ showAS $ map showBrief singleTestSummaries putStr delim -- print results to logfile - appendFile logFile $ "OVERALL RESULTS:\n" ++ (tssum_log tssum) ++ (showAS $ map showDetail singleTestSummaries) + appendFile logFile $ "OVERALL RESULTS:\n" ++ tssum_log tssum ++ showAS (map showDetail singleTestSummaries) -- hacky solution to avoid printing entire results to stdout and to give -- guidance to the type checker in picking specific Summarizable instances - return $ tail [head $ (map snd) $ snd $ partitionEithers $ head results] - where showDetail (method, msum) = delim ++ showBrief (method, msum) ++ "\n" ++ detail msum + return $ tail [head $ map snd $ snd $ partitionEithers $ head results] + where showDetail (method, msum) = delim ++ showBrief (method, msum) ++ "\n" ++ tsum_log msum showBrief (method, msum) = showAS [method, - "\tTotal number of mutants:\t" ++ show (tsum_numMutants msum), - "\tFailed to Load:\t" ++ show (tsum_loadError msum), - "\tNot Killed:\t" ++ show (tsum_notKilled msum), - "\tKilled:\t" ++ show (tsum_killed msum), - "\tOthers:\t" ++ show (tsum_others msum), - ""] - detail msum = tsum_log msum - terminalSummary tssum = showAS ["Total number of mutants:\t" ++ show (tssum_numMutants tssum), - "Total number of alive mutants:\t" ++ show (tssum_alive tssum), - "Total number of load errors:\t" ++ show (tssum_errors tssum), - ""] - delim = "\n" ++ (take 25 (repeat '=')) ++ "\n" + "\tTotal number of mutants:\t" ++ show (tsum_numMutants msum), + "\tFailed to Load:\t" ++ (cpx tsum_loadError), + "\tNot Killed:\t" ++ (cpx tsum_notKilled), + "\tKilled:\t" ++ (cpx tsum_killed), + "\tOthers:\t" ++ (cpx tsum_others), + ""] + where cpx fn = show (fn msum) ++ " " ++ (fn msum) ./. (tsum_numMutants msum) + terminalSummary tssum = showAS [ + "Total number of mutants:\t" ++ show (tssum_numMutants tssum), + "Total number of alive mutants:\t" ++ (cpx tssum_alive), + "Total number of load errors:\t" ++ (cpx tssum_errors), + ""] + where cpx fn = show (fn tssum) ++ " " ++ (fn tssum) ./. (tssum_numMutants tssum) + delim = "\n" ++ replicate 25 '=' ++ "\n" --- Interpreter Functionalities --- Examples --- t = runInterpreter (evalMethod "Examples/Quicksort.hs" "Quicksort" "quickCheckResult idEmp") + +-- | Run one test suite on all mutants +-- @ +-- >>> t = runInterpreter (evalMethod "Examples/QuickCheckTest.hs" "Examples.QuickCheckTest" "quickCheckResult idEmp") +-- @ runCodeOnMutants mutantFiles topModule evalStr = mapM (evalMyStr evalStr) mutantFiles - where evalMyStr evalStr file = do putStrLn $ ">" ++ ":" ++ file ++ ":" ++ topModule ++ ":" ++ evalStr ++ ">" - x <- I.runInterpreter (evalMethod file topModule evalStr) - return x + where evalMyStr evalStr file = do putStrLn $ ">" ++ ":" ++ file ++ ":" ++ topModule ++ ":" ++ evalStr + I.runInterpreter (evalMethod file topModule evalStr) --- Given the filename, modulename, method to evaluate, evaluate, and return --- result as a pair. +-- | Given the filename, modulename, test to evaluate, evaluate, and return result as a pair. evalMethod :: (I.MonadInterpreter m, Typeable t) => String -> String -> String -> m (String, t) evalMethod fileName topModule evalStr = do I.loadModules [fileName] @@ -75,101 +92,21 @@ result <- I.interpret evalStr (I.as :: (Typeable a => IO a)) >>= liftIO return (fileName, result) -data TSum = TSum {tsum_numMutants::Int, tsum_loadError::Int, tsum_notKilled::Int, tsum_killed::Int, tsum_others::Int, tsum_log::String} -data TSSum = TSSum {tssum_numMutants::Int, tssum_alive::Int, tssum_errors::Int, tssum_log::String} - --- Class/Instance declaration -type MutantFilename = String -class Typeable s => Summarizable s where - testSummary :: [MutantFilename] -> [InterpreterOutput s] -> TSum - suiteSummary :: [[InterpreterOutput s]] -> TSSum - isSuccess :: s -> Bool - -instance Summarizable HUnit.Counts where - testSummary mutantFiles results = TSum { - tsum_numMutants = r, - tsum_loadError = le, - tsum_notKilled = s, - tsum_killed = fl, - tsum_others = re + ftc, - tsum_log = logMsg} - where (loadingErrorCases, executedCases) = partitionEithers results - loadingErrorFiles = mutantFiles \\ map fst executedCases - successCases = filter (isSuccess . snd) executedCases - failuresCases = filter ((>0) . HUnit.failures . snd) executedCases - runningErrorCases = (filter ((>0) . HUnit.errors . snd) executedCases) \\ failuresCases - failToFullyTryCases = filter ((\c -> HUnit.cases c > HUnit.tried c) . snd) executedCases - r = length results - le = length loadingErrorCases - [s, fl, re, ftc] = map length [successCases, failuresCases, runningErrorCases, failToFullyTryCases] - logMsg = showAS ["Details:", - "Loading error files:",showA loadingErrorFiles, - "Loading error messages:",showA loadingErrorCases, - "Successes:", showA successCases, - "Failures:", showA failuresCases, - "Error while running:", showA runningErrorCases, - "Incompletely tested (may include failures and running errors):",showA failToFullyTryCases] - suiteSummary = multipleCheckSummary (isSuccess . snd) - isSuccess = (\c -> (HUnit.cases c == HUnit.tried c) && HUnit.failures c == 0 && HUnit.errors c == 0) - -instance Summarizable Qc.Result where - testSummary mutantFiles results = TSum { - tsum_numMutants = r, - tsum_loadError = e, - tsum_notKilled = s, - tsum_killed = f, - tsum_others = g, - tsum_log = logMsg} - where (errorCases, executedCases) = partitionEithers results - [successCases, failureCases, gaveUpCases] = map (\c -> filter (c . snd) executedCases) [isSuccess, isFailure, isGaveUp] - r = length results - e = length errorCases - [s,f,g] = map length [successCases, failureCases, gaveUpCases] - errorFiles = mutantFiles \\ map fst executedCases - logMsg = showAS ["Details:", - "Loading error files:", showA errorFiles, - "Loading error messages:", showA errorCases, - "Successes:", showA successCases, - "Failure:", showA failureCases, - "Gaveups:", showA gaveUpCases] - isFailure :: Qc.Result -> Bool - isFailure Qc.Failure{} = True - isFailure _ = False - isGaveUp :: Qc.Result -> Bool - isGaveUp Qc.GaveUp{} = True - isGaveUp _ = False - - suiteSummary = multipleCheckSummary (isSuccess . snd) - isSuccess = Qc.isSuccess - -instance Summarizable Hspec.Summary where - testSummary mutantFiles results = TSum { - tsum_numMutants = r, - tsum_loadError = e, - tsum_notKilled = s, - tsum_killed = f, - tsum_others = 0, - tsum_log = logMsg} - where (errorCases, executedCases) = partitionEithers results - r = length results - e = length errorCases - [successCases, failureCases] = map (\c -> filter (c . snd) executedCases) [isSuccess, isFailure] - [s,f] = map length [successCases, failureCases] - errorFiles = mutantFiles \\ map fst executedCases - logMsg = showAS ["Details:", - "Loading error files:", showA errorFiles, - "Loading error messages:", showA errorCases, - "Successes:", showA successCases, - "Failure:", showA failureCases] - isFailure = not . isSuccess - suiteSummary = multipleCheckSummary (isSuccess . snd) - isSuccess (Hspec.Summary { Hspec.summaryExamples = se, Hspec.summaryFailures = sf } ) = sf == 0 +-- | Datatype to hold results of the entire run +data TSSum = TSSum {tssum_numMutants::Int, + tssum_alive::Int, + tssum_errors::Int, + tssum_log::String} --- we assume that checking each prop results in the same number of errorCases and executedCases +-- | Summarize the entire run multipleCheckSummary isSuccessFunction results + -- we assume that checking each prop results in the same number of errorCases and executedCases | not (checkLength results) = error "Output lengths differ for some properties." - | otherwise = TSSum {tssum_numMutants = countMutants, tssum_alive = countAlive, tssum_errors= countErrors, tssum_log = logMsg} - where executedCases = groupBy (\x y -> fst x == fst y) . sortBy (\x y -> fst x `compare` fst y) . rights $ concat results + | otherwise = TSSum {tssum_numMutants = countMutants, + tssum_alive = countAlive, + tssum_errors= countErrors, + tssum_log = logMsg} + where executedCases = groupBy ((==) `on` fst) . sortBy (compare `on` fst) . rights $ concat results allSuccesses = [rs | rs <- executedCases, length rs == length results, all isSuccessFunction rs] countAlive = length allSuccesses countErrors = countMutants - length executedCases diff --git a/src/MuCheck/Mutation.hs b/src/MuCheck/Mutation.hs --- a/src/MuCheck/Mutation.hs +++ b/src/MuCheck/Mutation.hs @@ -12,6 +12,8 @@ import Data.Generics (GenericQ, mkQ, Data, Typeable, mkMp) import Data.List(nub, (\\), permutations) import Control.Monad (liftM, zipWithM) +import System.Random +import Data.Time.Clock.POSIX import MuCheck.MuOp import MuCheck.Utils.Syb @@ -25,33 +27,35 @@ genMutantsWith :: StdArgs -> String -> FilePath -> IO Int genMutantsWith args funcname filename = liftM length $ do ast <- getASTFromFile filename + now <- round `fmap` getPOSIXTime let f = func funcname ast - case ops f ++ swapOps f of - [] -> return [] -- putStrLn "No applicable operator exists!" - _ -> zipWithM writeFile (genFileNames filename) $ map prettyPrint (programMutants ast) - where ops f = relevantOps f (muOps args ++ valOps f ++ ifElseNegOps f ++ guardedBoolNegOps f) - - valOps f = if doMutateValues args then selectIntOps f else [] - ifElseNegOps f = if doNegateIfElse args then selectIfElseBoolNegOps f else [] - guardedBoolNegOps f = if doNegateGuards args then selectGuardedBoolNegOps f else [] - swapOps f = if doMutatePatternMatches args then permMatches f ++ removeOnePMatch f else [] + g = mkStdGen now + ops = relevantOps f (muOps args ++ valOps ++ ifElseNegOps ++ guardedBoolNegOps) + swapOps = sampleF g (doMutatePatternMatches args) $ permMatches f ++ removeOnePMatch f - fstOrder = 1 -- first order + valOps = sampleF g (doMutateValues args) $ selectIntOps f + ifElseNegOps = sampleF g (doNegateIfElse args) $ selectIfElseBoolNegOps f + guardedBoolNegOps = sampleF g (doNegateGuards args) $ selectGuardedBoolNegOps f - patternMatchMutants, ifElseNegMutants, guardedNegMutants, operatorMutants, allMutants :: Decl -> [Decl] - patternMatchMutants f = mutatesN (swapOps f) f fstOrder - ifElseNegMutants f = mutatesN (ifElseNegOps f) f fstOrder - guardedNegMutants f = mutatesN (guardedBoolNegOps f) f fstOrder - operatorMutants f = case genMode args of - FirstOrderOnly -> mutatesN (ops f) f fstOrder - _ -> mutates (ops f) f + allMutants = nub $ patternMatchMutants ++ operatorMutants - allMutants f = nub $ patternMatchMutants f ++ operatorMutants f + patternMatchMutants, ifElseNegMutants, guardedNegMutants, operatorMutants, allMutants :: [Decl] + 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 func fname ast = fromJust $ selectOne (isFunctionD fname) ast programMutants ast = map (putDecls ast) $ mylst ast - mylst ast = [myfn ast x | x <- take (maxNumMutants args) $ allMutants (func funcname ast) ] + mylst ast = [myfn ast x | x <- take (maxNumMutants args) allMutants] myfn ast fn = replace (func funcname ast,fn) (getDecls ast) + + case ops ++ swapOps of + [] -> return [] -- putStrLn "No applicable operator exists!" + _ -> zipWithM writeFile (genFileNames filename) $ map prettyPrint (programMutants ast) + where fstOrder = 1 -- first order getASTFromFile filename = liftM parseModuleFromFile $ readFile filename -- Mutating a function's code using a bunch of mutation operators diff --git a/src/MuCheck/Operators.hs b/src/MuCheck/Operators.hs --- a/src/MuCheck/Operators.hs +++ b/src/MuCheck/Operators.hs @@ -1,18 +1,28 @@ -module MuCheck.Operators where +module MuCheck.Operators (comparators, + predNums, + binAriths, + arithLists, + allOps) where import MuCheck.MuOp +import MuCheck.Utils.Common import Language.Haskell.Exts (Name(Symbol), Exp(Var), QName(UnQual), Name(Ident)) --- all available operators +-- | all available operators allOps = concat [comparators, predNums, binAriths, arithLists] --- classes of code elements -comparators = Symbol <$> ["<", ">", "<=", ">=", "/=", "=="] -predNums = Var . UnQual . Ident <$> ["pred", "id", "succ"] -binAriths = Symbol <$> ["+", "-", "*", "/"] -arithLists = Var . UnQual . Ident <$> ["sum", "product", "maximum", "minimum", "head", "last"] +-- | comparison operators +comparators = coupling (==>) $ map Symbol ["<", ">", "<=", ">=", "/=", "=="] +-- | predicates +predNums = coupling (==>) $ map varfn ["pred", "id", "succ"] + +-- | binary arithmetic +binAriths = coupling (==>) $ map Symbol ["+", "-", "*", "/"] + +-- | arithmetic on lists +arithLists = coupling (==>) $ map varfn ["sum", "product", "maximum", "minimum", "head", "last"] + -- utilities -infixr 0 <$> -- this might not be the right fixity -f <$> ops = [o1 ==> o2 | o1 <- ops', o2 <- ops', o1 /= o2] - where ops' = map f ops +varfn = Var . UnQual . Ident + diff --git a/src/MuCheck/StdArgs.hs b/src/MuCheck/StdArgs.hs --- a/src/MuCheck/StdArgs.hs +++ b/src/MuCheck/StdArgs.hs @@ -8,20 +8,20 @@ deriving (Eq, Show) data StdArgs = StdArgs {muOps :: [MuOp] - , doMutatePatternMatches :: Bool - , doMutateValues :: Bool - , doNegateIfElse :: Bool - , doNegateGuards :: Bool + , doMutatePatternMatches :: Rational + , doMutateValues :: Rational + , doNegateIfElse :: Rational + , doNegateGuards :: Rational , maxNumMutants :: Int , genMode :: GenerationMode } deriving Show stdArgs :: StdArgs stdArgs = StdArgs {muOps = allOps - , doMutatePatternMatches = True -- False - , doMutateValues = True - , doNegateIfElse = True - , doNegateGuards = True + , doMutatePatternMatches = 1.0 + , doMutateValues = 1.0 + , doNegateIfElse = 1.0 + , doNegateGuards = 1.0 , maxNumMutants = 300 , genMode = FirstOrderOnly } diff --git a/src/MuCheck/Utils/Common.hs b/src/MuCheck/Utils/Common.hs --- a/src/MuCheck/Utils/Common.hs +++ b/src/MuCheck/Utils/Common.hs @@ -1,13 +1,19 @@ module MuCheck.Utils.Common where import System.FilePath (splitExtension) +import System.Random +import Data.List +import Control.Applicative -- | The `choose` function generates subsets of a given size -choose :: [b] -> Int -> [[b]] -_ `choose` 0 = [[]] -[] `choose` _ = [] -(x:xs) `choose` k = (x:) `fmap` (xs `choose` (k-1)) ++ xs `choose` k +choose :: [a] -> Int -> [[a]] +choose xs n = filter (\x -> length x == n) $ subsequences xs +-- | The `coupling` function produces all possible pairings, and applies the +-- given function to each +coupling fn ops = [(fn o1 o2) | o1 <- ops, o2 <- ops, o1 /= o2] + + -- | The `genFileNames` function lazily generates filenames of mutants genFileNames :: String -> [String] genFileNames s = map newname [1..] @@ -25,4 +31,23 @@ safeHead :: [a] -> Maybe a safeHead [] = Nothing safeHead (x:xs) = Just x + +-- | The `sample` function takes a random generator and chooses a random sample +-- subset of given size. +sample :: (RandomGen g, Num n, Eq n) => g -> n -> [t] -> [t] +sample g 0 xs = [] +sample g n xs = val : sample g' (n - 1) (remElt idx xs) + where val = xs !! idx + (idx,g') = randomR (0, length xs - 1) g + +-- | The `sampleF` function takes a random generator, and a fraction and +-- returns subset of size given by fraction +sampleF :: (RandomGen g, Num n) => g -> Rational -> [t] -> [t] +sampleF g f xs = sample g l xs + where l = round $ f * fromIntegral (length xs) + +-- | The `remElt` function removes element at index specified from a list +remElt :: Int -> [a] -> [a] +remElt idx xs = front ++ ack + where (front,b:ack) = splitAt idx xs diff --git a/src/MuCheck/Utils/Syb.hs b/src/MuCheck/Utils/Syb.hs --- a/src/MuCheck/Utils/Syb.hs +++ b/src/MuCheck/Utils/Syb.hs @@ -1,5 +1,5 @@ {-# LANGUAGE RankNTypes #-} - +-- | SYB functions module MuCheck.Utils.Syb ( selectMany , selectOne , relevantOps @@ -7,29 +7,29 @@ , once') where import Data.Generics (Data, Typeable, GenericM, gmapMo, everything, mkQ, mkMp) -import MuCheck.MuOp -import MuCheck.Utils.Common +import MuCheck.MuOp (mkMp', MuOp) +import MuCheck.Utils.Common (safeHead) import Control.Monad (MonadPlus, mplus) import Data.Maybe(fromMaybe, isJust) --- SYB functions --- apply a mutating function on a piece of code once at a time +-- | apply a mutating function on a piece of code one at a time once :: MonadPlus m => GenericM m -> GenericM m once f x = f x `mplus` gmapMo (once f) x once' :: (forall a. Data a => a -> Maybe a) -> (forall a. Data a => a -> a) once' f x = fromMaybe x $ once f x --- select all code components satisfying a certain predicate +-- | select all code components satisfying a certain predicate selectMany :: (Data a, Typeable b) => (b -> Bool) -> a -> [b] selectMany f = everything (++) ([] `mkQ` keep f) where keep fn x = [x | fn x] --- special case of selectMany, which selects the first --- components satisfying a predicate +-- | special case of selectMany, which selects the first components satisfying +-- a predicate +selectOne :: (Typeable a, Data a1) => (a -> Bool) -> a1 -> Maybe a selectOne f p = safeHead $ selectMany f p --- selecting all relevant ops +-- | selecting all relevant ops relevantOps :: (Data a, Eq a) => a -> [MuOp] -> [MuOp] relevantOps m mlst = filter (relevantOp m) mlst -- check if an operator can be applied to a program