diff --git a/FitSpec.hs b/FitSpec.hs deleted file mode 100644 --- a/FitSpec.hs +++ /dev/null @@ -1,106 +0,0 @@ --- | FitSpec: refining property-sets for functional testing --- --- FitSpec provides automated assistance in the task of refining test properties --- for Haskell functions. FitSpec tests mutant variations of functions under test --- against a given property set, recording any surviving mutants that pass all --- tests. FitSpec then reports: --- --- * /surviving mutants:/ --- indicating incompleteness of properties, --- prompting the user to amend a property or to add a new one; --- * /conjectures:/ --- indicating redundancy in the property set, --- prompting the user to remove properties so to reduce the cost of testing. --- --- Example, refining a @sort@ specification: --- --- > import FitSpec --- > import Data.List (sort) --- > --- > properties sort = --- > [ property $ \xs -> ordered (sort xs) --- > , property $ \xs -> length (sort xs) == length xs --- > , property $ \x xs -> elem x (sort xs) == elem x xs --- > , property $ \x xs -> notElem x (sort xs) == notElem x xs --- > , property $ \x xs -> minimum (x:xs) == head (sort (x:xs)) --- > ] --- > where --- > ordered (x:y:xs) = x <= y && ordered (y:xs) --- > ordered _ = True --- > --- > main = mainWith args { names = ["sort xs"] --- > , nMutants = 4000 --- > , nTests = 4000 --- > , timeout = 0 --- > } --- > (sort::[Word2]->[Word2]) --- --- The above program reports the following: --- --- > Apparent incomplete and non-minimal specification based on --- > 4000 test cases for each of properties 1, 2, 3, 4 and 5 --- > for each of 4000 mutant variations. --- > --- > 3 survivors (99% killed), smallest: --- > \xs -> case xs of --- > [0,0,1] -> [0,1,1] --- > _ -> sort xs --- > --- > apparent minimal property subsets: {1,2,3} {1,2,4} --- > conjectures: {3} = {4} 96% killed (weak) --- > {1,3} ==> {5} 98% killed (weak) -module FitSpec - ( - -- * Encoding properties - Property - , property - - -- * Configuring reports - , Args (..), ShowMutantAs (..) - , args - , fixargs - - -- * Reporting results - , report - , reportWith - , reportWithExtra - - -- ** Parsing command line arguments - , mainWith - , defaultMain - , getArgs - , getArgsWith - - -- * Mutable types - , Mutable (..) - , mutiersEq - - , ShowMutable (..) - , mutantSEq - , showMutantAsTuple - , showMutantDefinition - , showMutantNested - , showMutantBindings - - -- * Automatic derivation - , deriveMutable - , deriveMutableE - - -- * Re-export modules - , module FitSpec.TestTypes - , module Test.LeanCheck - ) -where - -import FitSpec.Engine -import FitSpec.Report -import FitSpec.Main - -import FitSpec.Mutable -import FitSpec.Mutable.Tuples -import FitSpec.ShowMutable -import FitSpec.ShowMutable.Tuples -import FitSpec.Derive -import FitSpec.TestTypes - -import Test.LeanCheck diff --git a/FitSpec/Derive.hs b/FitSpec/Derive.hs deleted file mode 100644 --- a/FitSpec/Derive.hs +++ /dev/null @@ -1,172 +0,0 @@ --- | Experimental module for deriving Mutable instances --- --- Needs GHC and Template Haskell --- (tested on GHC 7.4, 7.6, 7.8, 7.10 and 8.0) --- --- Despite Mutable instances being actually very simple, this module can be --- used to derive those. However, it will not work on all cases: when that --- happens, you should write your instances manually. -{-# LANGUAGE TemplateHaskell, CPP #-} -module FitSpec.Derive - ( deriveMutable - , deriveMutableE - , module FitSpec.Mutable - , module FitSpec.ShowMutable - , module Test.LeanCheck - ) -where - -import FitSpec.Mutable -import FitSpec.ShowMutable - -import Test.LeanCheck -import Language.Haskell.TH -import Control.Monad (when, unless, liftM, liftM2) - -#if __GLASGOW_HASKELL__ < 706 --- reportWarning was only introduced in GHC 7.6 / TH 2.8 -reportWarning :: String -> Q () -reportWarning = report False -#endif - -deriveListableIfNeeded :: Name -> DecsQ -deriveListableIfNeeded t = do - is <- t `isInstanceOf` ''Listable - if is - then return [] - else deriveListable t - --- | Derives a Mutable instance for a given type ('Name'). -deriveMutable :: Name -> DecsQ -deriveMutable = deriveMutableE [] - --- | Derives a Mutable instance for a given type ('Name') using a given context --- for all type variables. -deriveMutableE :: [Name] -> Name -> DecsQ -deriveMutableE cs t = do - is <- t `isInstanceOf` ''Mutable - if is - then do - reportWarning $ "Instance Mutable " ++ show t - ++ " already exists, skipping derivation" - return [] - else do - cd <- canDeriveMutable t - unless cd (fail $ "Unable to derive Mutable " ++ show t) - liftM2 (++) (deriveListableIfNeeded t) (reallyDeriveMutable cs t) - --- | Checks whether it is possible to derive a Mutable instance. -canDeriveMutable :: Name -> Q Bool -canDeriveMutable t = (t `isInstanceOf` ''Eq) - &&& (t `isInstanceOf` ''Show) - where (&&&) = liftM2 (&&) - -reallyDeriveMutable :: [Name] -> Name -> DecsQ -reallyDeriveMutable cs t = do - (nt,vs) <- normalizeType t -#if __GLASGOW_HASKELL__ >= 710 - cxt <- sequence [ [t| $(conT c) $(return v) |] -#else - cxt <- sequence [ classP c [return v] -#endif - | v <- vs, c <- ''Eq:''Listable:''Show:cs ] -#if __GLASGOW_HASKELL__ >= 708 - cxt |=>| [d| instance Mutable $(return nt) - where mutiers = mutiersEq - instance ShowMutable $(return nt) - where mutantS = mutantSEq |] -#else - return [ InstanceD - cxt - (AppT (ConT ''Mutable) nt) - [ValD (VarP 'mutiers) (NormalB (VarE 'mutiersEq)) []] - , InstanceD - cxt - (AppT (ConT ''ShowMutable) nt) - [ValD (VarP 'mutantS) (NormalB (VarE 'mutantSEq)) []] - ] -#endif - - --- * Template haskell utilities - --- Normalizes a type by applying it to necessary type variables, making it --- accept "zero" parameters. The normalized type is tupled with a list of --- necessary type variables. --- --- Suppose: --- --- > data DT a b c ... = ... --- --- Then, in pseudo-TH: --- --- > normalizeType [t|DT|] == Q (DT a b c ..., [a, b, c, ...]) -normalizeType :: Name -> Q (Type, [Type]) -normalizeType t = do - ar <- typeArity t - vs <- newVarTs ar - return (foldl AppT (ConT t) vs, vs) - where - newNames :: [String] -> Q [Name] - newNames = mapM newName - newVarTs :: Int -> Q [Type] - newVarTs n = liftM (map VarT) - $ newNames (take n . map (:[]) $ cycle ['a'..'z']) - --- Normalizes a type by applying it to units (`()`) while possible. --- --- > normalizeTypeUnits ''Int === [t| Int |] --- > normalizeTypeUnits ''Maybe === [t| Maybe () |] --- > normalizeTypeUnits ''Either === [t| Either () () |] -normalizeTypeUnits :: Name -> Q Type -normalizeTypeUnits t = do - ar <- typeArity t - return (foldl AppT (ConT t) (replicate ar (TupleT 0))) - --- Given a type name and a class name, --- returns whether the type is an instance of that class. -isInstanceOf :: Name -> Name -> Q Bool -isInstanceOf tn cl = do - ty <- normalizeTypeUnits tn - isInstance cl [ty] - --- | Given a type name, return the number of arguments taken by that type. --- Examples in partially broken TH: --- --- > arity ''Int === Q 0 --- > arity ''Int->Int === Q 0 --- > arity ''Maybe === Q 1 --- > arity ''Either === Q 2 --- > arity ''Int-> === Q 1 --- --- This works for Data's and Newtype's and it is useful when generating --- typeclass instances. -typeArity :: Name -> Q Int -typeArity t = do - ti <- reify t - return . length $ case ti of -#if __GLASGOW_HASKELL__ < 800 - TyConI (DataD _ _ ks _ _) -> ks - TyConI (NewtypeD _ _ ks _ _) -> ks -#else - TyConI (DataD _ _ ks _ _ _) -> ks - TyConI (NewtypeD _ _ ks _ _ _) -> ks -#endif - _ -> error $ "error (arity): symbol " - ++ show t - ++ " is not a newtype or data" - --- Append to instance contexts in a declaration. --- --- > sequence [[|Eq b|],[|Eq c|]] |=>| [t|instance Eq a => Cl (Ty a) where f=g|] --- > == [t| instance (Eq a, Eq b, Eq c) => Cl (Ty a) where f = g |] -(|=>|) :: Cxt -> DecsQ -> DecsQ -c |=>| qds = do ds <- qds - return $ map (`ac` c) ds -#if __GLASGOW_HASKELL__ < 800 - where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds - ac d _ = d -#else - where ac (InstanceD o c ts ds) c' = InstanceD o (c++c') ts ds - ac d _ = d -#endif diff --git a/FitSpec/Dot.hs b/FitSpec/Dot.hs deleted file mode 100644 --- a/FitSpec/Dot.hs +++ /dev/null @@ -1,70 +0,0 @@ --- | Generate dotfiles (graphviz) -module FitSpec.Dot where - -import FitSpec -import FitSpec.Engine -import FitSpec.Utils -import Data.List - --- | Given a list of pairs of property groups and their implications, --- return implications between groups (transitive cases are ommitted). -groupImplications :: Eq i => [([[i]], [i])] -> [([[i]],[[i]])] -groupImplications [] = [] -groupImplications (n:ns) = [ (fst n, fst n') - | n' <- filterU (not ... implies) - . filter (n `implies`) - $ ns - ] ++ groupImplications ns - where actual (iss,is) = foldr union [] iss `union` is - n `implies` m = actual n `contains` actual m - -isObvious :: Eq i => [[i]] -> [[i]] -> Bool -isObvious as bs = or [ a `contains` b - | a <- as - , b <- bs ] - -attachObviousness :: Eq i => [([[i]], [[i]])] -> [([[i]],[[i]],Bool)] -attachObviousness = map attachObviousness' - where attachObviousness' (as,bs) = (as,bs,isObvious as bs) - - --- | Given a list of relations, generate a graphviz graph containing those relations. --- Generate a dotfile from implications between groups. -genDotfileFromGI :: Show i - => [([[i]],[[i]],Bool)] - -> String -genDotfileFromGI = (\s -> "digraph G {\n" ++ s ++ "}\n") - . unlines - . map showEntry - where showG = unwords . map show - showEntry (iss,jss,p) = "\"" ++ showG iss ++ "\" -> \"" - ++ showG jss ++ "\"" - ++ if p - then " [ color = grey ]" - else "" - --- | Equivalent to 'getResults' but returns a dotfile -getDotfile :: (Mutable a) - => [a] - -> Int -> Int -> a -> (a -> [Property]) - -> String -getDotfile ems m n f ps = genDotfileFromGI - . attachObviousness - . groupImplications - . map (\r -> (sets r, implied r)) - $ getResultsExtra ems f ps m n - --- | Equivalent to report, but writes a dotfile to a file -writeDotfile :: (Mutable a) - => String - -> [a] - -> Int -> Int -> a -> (a -> [Property]) - -> IO () -writeDotfile fn ems m n f = writeFile fn . getDotfile ems m n f - --- | Equivalent to report, but writes a dotfile to stdout -putDotfile :: (Mutable a) - => [a] - -> Int -> Int -> a -> (a -> [Property]) - -> IO () -putDotfile ems m n f = putStr . getDotfile ems m n f diff --git a/FitSpec/Engine.hs b/FitSpec/Engine.hs deleted file mode 100644 --- a/FitSpec/Engine.hs +++ /dev/null @@ -1,278 +0,0 @@ --- | FitSpec: refining property-sets for functional testing --- --- This is the main engine, besides FitSpec.Mutable. -module FitSpec.Engine - ( property - , Property - - , getResults - , getResultsExtra - , getResultsExtraTimeout - , Result (..) - , Results - - , propertiesNTests - , propertiesTestsExhausted - , propertiesToMap - , propertiesHold - , propertiesCE - - , minimal - , complete - - , reduceImplications - , filterNonCanon - , Conjecture (..) - , conjectures - ) -where - -import Test.LeanCheck.Error -import FitSpec.Utils -import Data.Maybe (catMaybes, listToMaybe) -import Data.List ((\\),union,transpose) -import FitSpec.Mutable - --- | An encoded representation of a property suitable for use by FitSpec. --- --- Each list of strings is a printable representation of one possible choice of --- argument values for the property. Each boolean indicate whether the --- property holds for this choice. -type Property = [([String],Bool)] -type Properties = [Property] - --- | Given a 'Testable' type (as defined by 'Test.Check'), returns a 'Property'. --- --- This function should be used on every property to create a property list to --- be passed to 'report', 'reportWith', 'mainDefault' or 'mainWith'. --- --- > property $ \x y -> x + y < y + (x::Int) -property :: Testable a => a -> Property -property = results - -propertyHolds :: Int -> Property -> Bool -propertyHolds n = all snd . take n - -propertyCE :: Int -> Property -> Maybe String -propertyCE n = listToMaybe . map (unwords . fst) . filter (not . snd) . take n - -propertiesToMap :: [Property] -> Int -> [Bool] -propertiesToMap ps n = map (propertyHolds n) ps - -propertiesHold :: Int -> [Property] -> Bool -propertiesHold n = all (propertyHolds n) - -propertiesCE :: Int -> [Property] -> Maybe String -propertiesCE n = listToMaybe - . catMaybes - . zipWith (\n -> fmap ((show n ++ ": ") ++)) [1..] - . map (propertyCE n) - -propertiesNTests :: Int -> [Property] -> [Int] -propertiesNTests n = map (length . take n) - -propertiesTestsExhausted :: Int -> [Property] -> [Bool] -propertiesTestsExhausted n = map (<= n) . propertiesNTests (n+1) - -filterNonCanon :: [Result a] -> [Result a] -filterNonCanon [] = [] -filterNonCanon (r:rs) = (r:) - . filterNonCanon - . filter (not . null . sets) - . map (updateSets removeNonCanon) - $ rs - where removeNonCanon = filter (not . (\p' -> (p' `contains`) `any` tail (sets r))) - updateSets f r = r { sets = f (sets r) } - -reduceImplications :: [Result a] -> [Result a] -reduceImplications [] = [] -reduceImplications (r:rs) = r : map (r `reduce`) (reduceImplications rs) - where r `reduce` r' = if or [s `contained` s' | s <- sets r, s' <- sets r'] - then r' { implied = implied r' \\ implied r } - else r' - - --- | A line of result for a single equivalence class of properties --- with the exact same surviving mutants. -data Result a = Result - { sets :: [[Int]] -- ^ property-sets in the equivalence class - , implied :: [Int] -- ^ properties implied by this class - , survivors :: [a] -- ^ list of surviving mutants - , smallestSurvivor :: Maybe a -- ^ smallest surviving mutant, if any - , nSurvivors :: Int -- ^ number of surviving mutants - , nKilled :: Int -- ^ number of killed mutants - , totalMutants :: Int -- ^ total number of mutants generated and tested - , score :: Int -- ^ percentage of killed mutants, 0-100 - , maxTests :: Int -- ^ Requested number of tests (same for all rs.) - , mutantsExhausted :: Bool -- ^ mutants were exhausted - } -type Results a = [Result a] - - --- | Return minimality and completeness results. See 'report'. -getResults :: (Mutable a) - => a -> (a -> [Property]) -> Int -> Int - -> Results a -getResults = getResultsExtra [] - -getResultsExtra :: (Mutable a) - => [a] - -> a -> (a -> [Property]) -> Int -> Int - -> Results a -getResultsExtra ems f ps nms nts = map (uncurry $ processRawResult mex nts) - $ getRawResults is pmap ms - where is = [1..(length $ ps f)] - pmap f = propertiesToMap (ps f) nts - ms' = take (nms+1) (tail $ mutants f) - mex = length ms' <= nms - ms = take nms ms' ++ ems - -getResultsExtraTimeout :: (Mutable a) - => Int - -> [a] - -> a -> (a -> [Property]) -> Int -> Int - -> IO (Results a) -getResultsExtraTimeout 0 ems f ps m n = return $ getResultsExtra ems f ps m n -getResultsExtraTimeout t ems f ps nm0 nt0 = lastTimeout t resultss - where - resultss = map fst - $ takeWhileIncreasingOn ((totalMutants . head) *** id) - [ (getResultsExtra ems f ps nm nt, propertiesNTests nt $ ps f) - | (nm,nt) <- iterate (incHalf *** incHalf) (nm0,nt0) ] - incHalf x = x + x `div` 2 - -processRawResult :: Bool -> Int -> [[Int]] -> [(a,Bool)] -> Result a -processRawResult mex nt iss mhs = Result - { sets = relevantPropertySets iss - , implied = relevantImplications iss - , survivors = ms - , smallestSurvivor = listToMaybe ms - , nSurvivors = ns - , nKilled = nk - , totalMutants = nm - , score = nk*100 `div` nm - , maxTests = nt - , mutantsExhausted = mex - } - where ms = [m | (m,h) <- mhs, h] - nm = length mhs - ns = length ms - nk = nm - ns - -minimal :: Results a -> Bool -minimal (r:_) = null (implied r) - && length (sets r) == 1 - -complete :: Results a -> Bool -complete (r:_) = nSurvivors r == 0 - -relevantPropertySets :: Eq i => [[i]] -> [[i]] -relevantPropertySets = filterU (not ... contained) . sortOn length - -relevantImplications :: Eq i => [[i]] -> [i] -relevantImplications iss = foldr union [] iss - \\ foldr union [] (relevantPropertySets iss) - --- | Returns a description of property sets, grouping the ones that had the --- same surviving mutants. The resulting list is ordered starting with the --- least surviving mutants to the most surviving mutants. --- --- Arguments: --- --- * @is@: list of property ids (@length is == length (pmap x)@) --- --- * @pmap@: a property map --- --- * @ms@: list of mutants to apply to the property map --- --- Return a list of tuples containing: --- --- * a list of property sets --- * a list of mutants paired with booleans indicating whether each survived -getRawResults :: [i] -> (a -> [Bool]) -> [a] -> [([[i]],[(a,Bool)])] -getRawResults is ps ms = (id *** (zip ms)) `map` getRawResults' is ps ms - --- | Returns a description of property sets, grouping the ones that had the --- same surviving mutants. The resulting list is ordered starting with the --- least surviving mutants to the most surviving mutants. --- --- Arguments: --- --- * @is@: list of property ids (@length is == length (pmap x)@) --- --- * @pmap@: a property map --- --- * @ms@: list of mutants to apply to the property map --- --- Return a list of tuples containing: --- --- * a list of property sets --- * a boolean list indicating whether a given mutant survived -getRawResults' :: [i] -> (a -> [Bool]) -> [a] -> [([[i]],[Bool])] -getRawResults' is pmap = sortOn (count id . snd) - . sortAndGroupFstBySnd - . zip (subsets is) - . transpose - . map (compositions . pmap) - --- | 'nSurv' @props fs@ returns the number of values that match --- compositions of properties on the property map. --- --- * @props@ should be a function from a value to a list of properties that --- match that value (in the case of functions, functions that "survive" those --- properties). --- --- * @fs@ is a list of values to be mapped over by @props@ --- --- > length (nSurvivors props fs) == 2 ^ (length (props fs)) --- --- This function is otherwise unused in this file. It is just a simpler --- version of 'pssurv' to serve as documentation. -nSurv :: (a -> [Bool]) -> [a] -> [Int] -nSurv props = map (count id) - . transpose - . map (compositions . props) - - -data Conjecture = Conjecture - { isEq :: Bool - , isIm :: Bool - , cleft :: [Int] - , cright :: [Int] - , cscore :: Int - , cnKilled :: Int - , cnSurvivors :: Int - } deriving Show - -conjectures :: [Result a] -> [Conjecture] -conjectures = concatMap conjectures1 - . sortOn (abs . (50-) . score) -- closer to 50 the better! - . reduceImplications - . filterNonCanon - . reverse - -conjectures1 :: Result a -> [Conjecture] -conjectures1 r = [ p `eq` p' | p' <- ps ] - ++ [ p `im` i | (not.null) i ] - where - (p:ps) = sets r - i = implied r - eq = conj True - im = conj False - conj isE p p' = Conjecture - { isEq = isE - , isIm = not isE - , cleft = p - , cright = p' - , cscore = score r - , cnKilled = nKilled r - , cnSurvivors = nSurvivors r - } --- TODO: improve implication score --- implication score can be improved by --- by separating each implication on its own: --- [4] ==> [2,3] --- become --- [4] ==> [2] --- [4] ==> [3] --- Then evaluating percentage of occurences of True ==> True and other cases diff --git a/FitSpec/Main.hs b/FitSpec/Main.hs deleted file mode 100644 --- a/FitSpec/Main.hs +++ /dev/null @@ -1,69 +0,0 @@ --- | Exports "main" functions for FitSpec. --- They work exactly by 'report' and 'reportWith' but can be customized by --- command line arguments. --- --- > main = mainWith args { ... } functions properties -{-# Language DeriveDataTypeable, StandaloneDeriving #-} -module FitSpec.Main - ( mainWith - , defaultMain - , getArgs - , getArgsWith - , module FitSpec.Report -- deprecated export, remove later - ) -where - -import FitSpec.Report -import System.Console.CmdArgs hiding (args) -import qualified System.Console.CmdArgs as CA (args) -import Control.Monad (liftM) -import FitSpec.Mutable -import FitSpec.ShowMutable - -deriving instance Data ShowMutantAs -deriving instance Data Args -deriving instance Typeable ShowMutantAs -deriving instance Typeable Args - -annotate :: Args -> Args -annotate as = Args - { nMutants = nMutants as &= name "m" - &= help "(starting) number of function mutations" - , nTests = nTests as &= name "n" - &= help "(starting) number of test values (each prop.)" - , timeout = timeout as &= name "t" &= name "s" - &= help "timeout in seconds, 0 for just T*M" - , names = names as - &= ignore - , rows = rows as - &= help "how many rows of results to show" - , verbose = verbose as - &= help "activate verbose output" - , showMutantAs = showMutantAs as &= name "a" - &= help "how to show mutants (tuple / nestedtuple / definition / bindings)" - &= typ "type" - , extra = extra as &= CA.args - &= typ "extra arguments" - } &= summary "FitSpec" - &= program "program" - &= help "Refine property-sets for functional testing" - -getArgsWith :: Args -> IO Args -getArgsWith = cmdArgs . annotate - -getArgs :: IO Args -getArgs = getArgsWith args - --- | Same as 'reportWith', but allow overriding of configuration via command --- line arguments. -mainWith :: (Mutable a, ShowMutable a) - => Args - -> a -> (a -> [Property]) -> IO () -mainWith as f ps = do - as' <- getArgsWith as - reportWith as' f ps - --- | Same as 'report', but allow configuration via command line arguments. -defaultMain :: (Mutable a, ShowMutable a) - => a -> (a -> [Property]) -> IO () -defaultMain = mainWith args diff --git a/FitSpec/Most.hs b/FitSpec/Most.hs deleted file mode 100644 --- a/FitSpec/Most.hs +++ /dev/null @@ -1,2 +0,0 @@ --- | Deprecated, import 'FitSpec' instead -module FitSpec.Most (module FitSpec) where import FitSpec diff --git a/FitSpec/Mutable.hs b/FitSpec/Mutable.hs deleted file mode 100644 --- a/FitSpec/Mutable.hs +++ /dev/null @@ -1,186 +0,0 @@ --- | Enumeration of function mutations -module FitSpec.Mutable - ( Mutable (..) - , mutiersEq ---, mutantsIntegral - ) -where - -import Test.LeanCheck -import Data.List (intercalate, delete) -import Data.Maybe -import Test.LeanCheck.Error (errorToNothing) - --- | This typeclass is similar to 'Listable'. --- --- A type is 'Mutable' when there exists a function that --- is able to list mutations of a value. --- Ideally: list all possible values without repetitions. --- --- Instances are usually defined by a 'mutiers' function that --- given a value, returns tiers of mutants of that value: --- the first tier contains the equivalent mutant, of size 0, --- the second tier contains mutants of size 1, --- the third tier contains mutants of size 2, --- and so on. --- --- The equivalent mutant is the actual function without mutations. --- --- The size of a mutant is given by the sum of: --- the number of mutated points (relations) and --- the sizes of mutated arguments and results. --- --- To get only inequivalent mutants, --- just take the 'tail' of either 'mutants' or 'mutiers': --- --- > tail mutants --- --- > tail mutiers --- --- Given that the underlying 'Listable' enumeration has no repetitions --- parametric instances defined in this file will have no repeated mutants. -class Mutable a where - mutiers :: a -> [[a]] - mutants :: a -> [a] - mutiers = map (:[]) . mutants - mutants = concat . mutiers - {-# MINIMAL mutants | mutiers #-} - - --- *** *** Instances for (non-functional) data types *** *** - --- | Implementation of 'mutiers' for non-functional data types. --- Use this to create instances for user-defined data types, e.g.: --- --- > instance MyData --- > where mutiers = mutiersEq --- --- and for parametric datatypes: --- --- > instance (Eq a, Eq b) => MyDt a b --- > where mutiers = mutiersEq --- --- Examples: --- --- > mutiersEq True = [[True], [False]] --- > mutiersEq 2 = [[2], [0], [1], [], [3], [4], [5], [6], [7], [8], [9], ...] --- > mutiersEq [1] = [[[1]], [[]], [[0]], [[0,0]], [[0,0,0],[0,1],[1,0],[-1]], ...] -mutiersEq :: (Listable a, Eq a) => a -> [[a]] -mutiersEq x = [x] : deleteT x tiers - --- | > mutants () = [()] -instance Mutable () where mutiers = mutiersEq - --- | > mutants 3 = [3,0,1,2,4,5,6,7,8,9,... -instance Mutable Int where mutiers = mutiersEq - -instance Mutable Char where mutiers = mutiersEq - --- | > mutants True = [True,False] -instance Mutable Bool where mutiers = mutiersEq -- > mutants True=[True,False] - --- | > mutants [0] = [ [0], [], [0,0], [1], ... -instance (Eq a, Listable a) => Mutable [a] where mutiers = mutiersEq - --- | > mutants (Just 0) = [Just 0, Nothing, ... -instance (Eq a, Listable a) => Mutable (Maybe a) where mutiers = mutiersEq - -{- Alternative implementations for Mutable Ints and Lists. --- These do not improve results significantly. --- That is why I have kept the simpler mutations above. - --- |- Generate mutants of an Integral value. --- Alternates between successors and predecessors of the original number. --- The enumeration starts "towards" zero. -mutantsIntegral :: Integral a => a -> [a] -mutantsIntegral i | i > 0 = [i..] +| tail [i,(i-1)..] - | otherwise = [i,(i-1)..] +| tail [i..] --- NOTE: tail is there to avoid generating out of bound values --- as (i-1) is usually safe while (i-2) is not. - -instance Mutable Int where mutants = mutantsIntegral - -instance (Listable a, Mutable a) => Mutable [a] - where mutiers [] = [ [] ] - : [ ] - : tail tiers - mutiers (x:xs) = [ (x:xs) ] - : [ [] ] - : tail (lsProductWith (:) (mutiers x) (mutiers xs)) --- -} - - --- *** *** Instances for functional types *** *** - --- | Mutate a function at a single point. --- The following two declarations are equivalent: --- --- > id' = id `mut` (0,1) --- --- > id' 0 = 1 --- > id' x = x -mut :: Eq a => (a -> b) -> (a,b) -> (a -> b) -mut f (x',fx') = \x -> if x == x' - then fx' - else f x - --- | Mutate a function at several points. --- --- > f `mutate` [(x,a),(y,b),(z,c)] = f `mut` (x,a) `mut` (y,b) `mut` (z,c) -mutate :: Eq a => (a -> b) -> [(a,b)] -> (a -> b) -mutate f ms = foldr (flip mut) f ms -- or: foldl mut f ms - --- | Return tiers of possible mutations for a single point of a function. --- If the function is undefined at that point, no mutations are provided. --- This function does not return the null mutant. --- --- > (+1) `mutationsFor` 1 = [ [(1,0)], [(1,1)], [], [(1,3)], [(1,4)], ... -mutationsFor :: Mutable b => (a->b) -> a -> [[(a,b)]] -mutationsFor f x = case errorToNothing (f x) of - Nothing -> [] - Just fx -> ((,) x) `mapT` tail (mutiers fx) - --- | Returns tiers of mutants on a selection of arguments of a function. --- Will only return the null mutant from an empty selection of arguments. -tiersMutantsOn :: (Eq a, Mutable b) => (a->b) -> [a] -> [[a->b]] -tiersMutantsOn f xs = mutate f `mapT` products (map (mutationsFor f) xs) - --- | --- > mutants not = --- > [ not --- > , \p -> case p of False -> False; _ -> not p --- > , \p -> case p of True -> True; _ -> not p --- > , \p -> case p of False -> False; True -> True --- > ] -instance (Eq a, Listable a, Mutable b) => Mutable (a -> b) where - mutiers f = tiersMutantsOn f `concatMapT` setsOf tiers - - --- *** *** Instances for tuples *** *** - --- | > mutants (0,1) = [(0,1),(0,0),(1,1),(0,-1),...] -instance (Mutable a, Mutable b) => Mutable (a,b) where - mutiers (f,g) = mutiers f >< mutiers g - -instance (Mutable a, Mutable b, Mutable c) => Mutable (a,b,c) where - mutiers (f,g,h) = productWith (\f' (g',h') -> (f',g',h')) - (mutiers f) (mutiers (g,h)) - -instance (Mutable a, Mutable b, Mutable c, Mutable d) - => Mutable (a,b,c,d) where - mutiers (f,g,h,i) = productWith (\f' (g',h',i') -> (f',g',h',i')) - (mutiers f) (mutiers (g,h,i)) - -instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e) - => Mutable (a,b,c,d,e) where - mutiers (f,g,h,i,j) = productWith (\f' (g',h',i',j') -> (f',g',h',i',j')) - (mutiers f) (mutiers (g,h,i,j)) - --- | For Mutable tuple instances greater than sixtuples, see --- 'FitSpec.Mutable.Tuples'. Despite being hidden in this Haddock --- documentation, 7-tuples up to 12-tuples are exported by 'FitSpec'. -instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, Mutable f) - => Mutable (a,b,c,d,e,f) where - mutiers (f,g,h,i,j,k) = productWith (\f' (g',h',i',j',k') -> - (f',g',h',i',j',k')) - (mutiers f) (mutiers (g,h,i,j,k)) diff --git a/FitSpec/Mutable/Tuples.hs b/FitSpec/Mutable/Tuples.hs deleted file mode 100644 --- a/FitSpec/Mutable/Tuples.hs +++ /dev/null @@ -1,62 +0,0 @@ --- | Mutable instances: septuples up to 12-tuples --- --- This is part of a Hack that allows those instances to be hidden from Haddock. --- Otherwise Haddock documentation will look very ugly. -module FitSpec.Mutable.Tuples () where - -import FitSpec.Mutable -import Test.LeanCheck (productWith) - -instance (Mutable a, Mutable b, Mutable c, Mutable d, - Mutable e, Mutable f, Mutable g) - => Mutable (a,b,c,d,e,f,g) where - mutiers (f,g,h,i,j,k,l) = productWith (\f' (g',h',i',j',k',l') -> - (f',g',h',i',j',k',l')) - (mutiers f) - (mutiers (g,h,i,j,k,l)) - -instance (Mutable a, Mutable b, Mutable c, Mutable d, - Mutable e, Mutable f, Mutable g, Mutable h) - => Mutable (a,b,c,d,e,f,g,h) where - mutiers (f,g,h,i,j,k,l,m) = productWith (\f' (g',h',i',j',k',l',m') -> - (f',g',h',i',j',k',l',m')) - (mutiers f) - (mutiers (g,h,i,j,k,l,m)) - -instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, - Mutable f, Mutable g, Mutable h, Mutable i) - => Mutable (a,b,c,d,e,f,g,h,i) where - mutiers (f,g,h,i,j,k,l,m,n) = - productWith (\f' (g',h',i',j',k',l',m',n') -> - (f',g',h',i',j',k',l',m',n')) - (mutiers f) - (mutiers (g,h,i,j,k,l,m,n)) - -instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, - Mutable f, Mutable g, Mutable h, Mutable i, Mutable j) - => Mutable (a,b,c,d,e,f,g,h,i,j) where - mutiers (f,g,h,i,j,k,l,m,n,o) = - productWith (\f' (g',h',i',j',k',l',m',n',o') -> - (f',g',h',i',j',k',l',m',n',o')) - (mutiers f) - (mutiers (g,h,i,j,k,l,m,n,o)) - -instance (Mutable a, Mutable b, Mutable c, Mutable d, - Mutable e, Mutable f, Mutable g, Mutable h, - Mutable i, Mutable j, Mutable k) - => Mutable (a,b,c,d,e,f,g,h,i,j,k) where - mutiers (f,g,h,i,j,k,l,m,n,o,p) = - productWith (\f' (g',h',i',j',k',l',m',n',o',p') -> - (f',g',h',i',j',k',l',m',n',o',p')) - (mutiers f) - (mutiers (g,h,i,j,k,l,m,n,o,p)) - -instance (Mutable a, Mutable b, Mutable c, Mutable d, - Mutable e, Mutable f, Mutable g, Mutable h, - Mutable i, Mutable j, Mutable k, Mutable l) - => Mutable (a,b,c,d,e,f,g,h,i,j,k,l) where - mutiers (f,g,h,i,j,k,l,m,n,o,p,q) = - productWith (\f' (g',h',i',j',k',l',m',n',o',p',q') -> - (f',g',h',i',j',k',l',m',n',o',p',q')) - (mutiers f) - (mutiers (g,h,i,j,k,l,m,n,o,p,q)) diff --git a/FitSpec/PrettyPrint.hs b/FitSpec/PrettyPrint.hs deleted file mode 100644 --- a/FitSpec/PrettyPrint.hs +++ /dev/null @@ -1,141 +0,0 @@ --- | Poor man's pretty printing library --- --- This module has somewhat inefficient implementations that could be improved --- in the future. i.e.: heavy use of '(++)'. -module FitSpec.PrettyPrint - ( beside - , above - , showTuple - , table - , columns - , showQuantity - , showEach - , headToUpper - ) -where - -import Data.List (intercalate,transpose,isSuffixOf) -import Data.Char (toUpper) - -showQuantity :: Int -> String -> String -showQuantity 1 what = "1 " ++ what -showQuantity n what = show n ++ " " ++ pluralize what - -showEach :: Show a => String -> [a] -> String -showEach what [x] = what ++ " " ++ show x -showEach what xs = "each of " ++ pluralize what ++ " " - ++ intercalate ", " (map show $ init xs) - ++ " and " - ++ show (last xs) - --- | Pluralizes a word. --- Is not comprehensive (and may never be), --- add missing cases as they are found. --- --- > pluralize "test case" == "test cases" --- > pluralize "property" == "properties" -pluralize :: String -> String -pluralize s | s `ew` "se" = s ++ "s" - | s `ew` "n" = s ++ "s" - | s `ew` "y" = init s ++ "ies" - | otherwise = s - where ew = flip isSuffixOf - - --- | Appends two Strings side by side, line by line --- --- > beside ["asdf\nqw\n","zxvc\nas"] == --- > "asdfzxvc\n\ --- > \qw as\n" -beside :: String -> String -> String -beside cs ds = unlines $ zipWith (++) (normalize ' ' css) dss - where [css,dss] = normalize "" [lines cs,lines ds] - --- | Append two Strings on top of each other, adding line breaks *when needed*. -above :: String -> String -> String -above cs ds = if last cs == '\n' || head ds == '\n' - then cs ++ ds - else cs ++ '\n':ds - --- | Show elements of a list as a tuple. If there are multiple lines in any of --- the strings, tuple is printed multiline. --- --- > showTuple ["asdf\nqwer\n","zxvc\nasdf\n"] == --- > "( asdf\n\ --- > \ qwer\n\ --- > \, zxvc\n\ --- > \ asdf )\n" --- --- > showTuple ["asdf","qwer"] == "(asdf,qwer)" -showTuple :: [String] -> String -showTuple [] = "" -showTuple [s] = s -showTuple (s:ss) = - if any ('\n' `elem`) (s:ss) - then "( " `beside` s - ++ init (concatMap (", " `beside`) ss) - ++ " )\n" - else "(" ++ intercalate "," (s:ss) ++ ")" - --- | Formats a table using a given separator. --- --- > table " " [ ["asdf", "qwer", "zxvc\nzxvc"] --- > , ["0", "1", "2"] --- > , ["123", "456\n789", "3"] ] == --- > "asdf qwer zxvc\n\ --- > \ zxvc\n\ --- > \0 1 2\n\ --- > \123 456 3\n\ --- > \ 789\n\" -table :: String -> [[String]] -> String -table s [] = "" -table s sss = unlines - . map (removeTrailing ' ') - . map (intercalate s) - . transpose - . map (normalize ' ') - . foldr1 (zipWith (++)) - . map (normalize "" . map lines) - . normalize "" - $ sss - --- | Given a separator, format strings in columns --- --- > columns " | " ["asdf", "qw\nzxcv", "as\ndf"] == --- > "asdf | qw | as\n\ --- > \ | zxcv | df\n" -columns :: String -> [String] -> String -columns s = unlines - . map (removeTrailing ' ') - . map (intercalate s) - . transpose - . map (normalize ' ') - . normalize "" - . map lines - --- | Fits a list to a certain width by appending a certain value --- --- > fit ' ' 6 "str" == "str " --- --- > fit 0 6 [1,2,3] == [1,2,3,0,0,0] -fit :: a -> Int -> [a] -> [a] -fit x n xs = xs ++ replicate (n - length xs) x - --- | normalize makes all list the same length by adding a value --- --- > normalize ["asdf","qw","er"] == normalize ["asdf","qw ","er "] -normalize :: a -> [[a]] -> [[a]] -normalize x xs = map (x `fit` maxLength xs) xs - --- | Given a list of lists returns the maximum length -maxLength :: [[a]] -> Int -maxLength = maximum . (0:) . map length - -removeTrailing :: Eq a => a -> [a] -> [a] -removeTrailing x = reverse - . dropWhile (==x) - . reverse - -headToUpper :: [Char] -> [Char] -headToUpper [] = [] -headToUpper (c:cs) = toUpper c : cs diff --git a/FitSpec/Report.hs b/FitSpec/Report.hs deleted file mode 100644 --- a/FitSpec/Report.hs +++ /dev/null @@ -1,246 +0,0 @@ -module FitSpec.Report - ( report - , reportWith - , reportWithExtra - , Args(..) - , args - , fixargs - , Property - , ShowMutantAs(..) - ) -where - -import Data.List (intercalate, intersperse) -import Data.Maybe (fromMaybe) - -import FitSpec.Engine -import FitSpec.Mutable -import FitSpec.ShowMutable -import FitSpec.Utils -import FitSpec.PrettyPrint - --- | How to show mutants. Use this to fill 'showMutantAs'. -data ShowMutantAs = Tuple | NestedTuple - | Definition | Bindings - --- | Extra arguments / configuration for 'reportWith'. --- See 'args' for default values. -data Args = Args - { nMutants :: Int -- ^ (starting) number of function mutations - , nTests :: Int -- ^ (starting) number of test values (for each prop.) - , timeout :: Int -- ^ timeout in seconds, 0 for just 'nTests' * 'nMutants' - , names :: [String] -- ^ names of functions: @["foo x y","goo x y"]@ - - -- advanced options: - , verbose :: Bool -- ^ whether to show detailed results - , showMutantAs :: ShowMutantAs -- ^ how to show mutants - , rows :: Maybe Int -- ^ number of surviving mutants to show - , extra :: [String] -- ^ ignored argument (user defined meaning) - } - --- | Default arguments for 'reportWith': --- --- * @nMutants = 500@, start with 500 mutants --- --- * @nTests = 1000@, start with 1000 test values --- --- * @timeout = 5@, keep incresing the number of mutants --- until 5 seconds elapse --- --- * @names = []@, default function call template: --- --- > ["f x y z", "g x y z", "h x y z", ...] -args :: Args -args = Args { nMutants = 500 - , nTests = 1000 - , timeout = 5 -- seconds - , names = [] - , verbose = False - , showMutantAs = Tuple - , rows = Nothing - , extra = [] - } - --- | Non timed-out default arguments. --- Make conjectures based on a fixed number of mutants and tests, e.g.: --- --- > reportWith (fixargs 100 200) f pmap --- --- This is just a shorthand, see: --- --- > fixargs nm nt = args { nMutants = nm, nTests = nt, timeout = 0 } --- --- > (fixargs nm nt) { nMutants = 500, nTests = 1000, timeout = 5 } = args -fixargs :: Int -> Int -> Args -fixargs nm nt = args - { nMutants = nm - , nTests = nt - , timeout = 0 - } - -showMutant :: ShowMutable a => Args -> a -> a -> String -showMutant as = showMutantByType (showMutantAs as) (names as) - where - showMutantByType Tuple = showMutantAsTuple - showMutantByType NestedTuple = showMutantNested - showMutantByType Definition = showMutantDefinition - showMutantByType Bindings = showMutantBindings - --- | Report results generated by FitSpec. --- Uses standard configuration (see 'args'). --- Needs a function to be mutated and a property map. --- Example (specification of boolean negation): --- --- > properties not = --- > [ property $ \p -> not (not p) == p --- > , property $ \p -> not (not (not p)) == not p --- > ] --- > --- > main = report not properties -report :: (Mutable a, ShowMutable a) - => a -> (a -> [Property]) -> IO () -report = reportWith args - - --- | Same as 'report' but can be configured via 'Args' ('args' or 'fixargs'), --- e.g.: --- --- > reportWith args { timeout = 10 } fun properties -reportWith :: (Mutable a, ShowMutable a) - => Args -> a -> (a -> [Property]) -> IO () -reportWith = reportWithExtra [] - - --- | Same as 'reportWith', but accepts a list of manually defined (extra) --- mutants to be tested alongside those automatically generated. -reportWithExtra :: (Mutable a, ShowMutable a) - => [a] -> Args -> a -> (a -> [Property]) -> IO () -reportWithExtra extraMutants args f properties = do - let nm = nMutants args - nt = nTests args - case propertiesCE nt (properties f) of - Nothing -> reportWithExtra' extraMutants args f properties - Just ce -> do - putStrLn $ "ERROR: The original function-set does not follow property set for " - ++ show nt ++ " tests" - putStrLn $ "Counter-example to property " ++ ce - putStrLn $ "Aborting." - --- | Same as 'reportWithExtra', does not abort if the original function does not --- follow the property set. -reportWithExtra' :: (Mutable a, ShowMutable a) - => [a] -> Args -> a -> (a -> [Property]) -> IO () -reportWithExtra' extraMutants args f properties = do - results <- getResultsExtraTimeout (timeout args) - extraMutants - f properties - (nMutants args) (nTests args) - - let nm = totalMutants $ head results - nt = maxTests $ head results - nts = propertiesNTests nt (properties f) - tex = and $ propertiesTestsExhausted nt (properties f) - mex = mutantsExhausted $ head results - apparent | tex && mex = "" - | otherwise = "apparent " - putStrLn . headToUpper $ apparent ++ qualifyCM results ++ " specification based on" - putStrLn $ showNumberOfTestsAndMutants tex mex nts nm False - - let showR | verbose args = showDetailedResults - | otherwise = showResults - putStrLn $ showR (rows args) (showMutant args f) results - - -showResults :: Maybe Int -> (a -> String) - -> [Result a] -> String -showResults mlimit showMutant rs@(r:_) = completeness - ++ "\n" ++ minimality - where - showMutants ms = init . unlines $ map showMutant ms - completeness = show (nSurvivors r) ++ " survivors (" - ++ show (score r) ++ "% killed)" - ++ case take (fromMaybe 1 mlimit) $ survivors r of - [] -> ".\n" - [m] -> ", smallest:\n" - ++ " " `beside` showMutant m - ms -> ", " ++ show (length ms) ++ " smallest:\n" - ++ " " `beside` showMutants ms - minimality = "apparent minimal property subsets: " - ++ (unwords . map showPropertySet $ sets r) ++ "\n" - ++ case showConjectures False rs of - "" -> "No conjectures.\n" - cs -> "conjectures: " `beside` cs - - -showDetailedResults :: Maybe Int -> (a -> String) - -> [Result a] -> String -showDetailedResults mlimit showMutant rs = completeness - ++ "\n" ++ minimality - where - completeness = table " " . intersperse ["\n"] - . ([ "Property\n sets" - , "#Survivors\n (%Killed)" - , "Smallest or simplest\n surviving mutant" - ]:) - . map showResult - . maybe id take mlimit - $ rs - showResult r = [ unwords . map showPropertySet $ sets r - , show (nSurvivors r) ++ " (" ++ show (score r) ++ "%)" - , maybe "" showMutant $ smallestSurvivor r - ] - minimality = case showConjectures True rs of - "" -> "No conjectures.\n" - cs -> "Conjectures:\n" ++ cs - - -showNumberOfTestsAndMutants :: Bool -> Bool -> [Int] -> Int -> Bool -> String -showNumberOfTestsAndMutants tex mex nts nm ssum = numTests ++ numMutants - where - mexS | mex = " (exhausted)" - | otherwise = "" - numMutants = "for each of " ++ showQuantity nm "mutant variation" ++ mexS ++ ".\n" - numTests | ssum = showQuantity (sum nts) "test case" - ++ (if tex then " (exhausted)" else "") - ++ "\n" - | otherwise = unlines - . (++ ["(test cases exhausted)" | tex]) - . sortGroupAndCollapse fst snd testsForProps - $ zip nts [1..] - testsForProps n ps = showQuantity n "test case" - ++ " for " ++ showEach "property" ps - -showPropertySet :: Show i => [i] -> String -showPropertySet = (\s -> "{" ++ s ++ "}") . intercalate "," . map show - - --- | Show conjectures derived from results -showConjectures :: Bool -> [Result a] -> String -showConjectures showVeryWeak = table " " - . map showConjecture - . filter (\r -> showVeryWeak - || cnKilled r /= 0 - && cnSurvivors r /= 0) - . conjectures - -showConjecture :: Conjecture -> [String] -showConjecture Conjecture {isEq=eq, cleft=l, cright=r, cscore=s} = - [ showPropertySet l - , if eq then " = " else "==>" - , showPropertySet r - , " " - , show s ++ "% killed" - , sMeaning - ] - where sMeaning | s < 1 || 99 < s = "(very weak)" - | s < 11 || 89 < s = "(weak)" - | s < 33 || 67 < s = "(mild)" - | otherwise = "(strong)" -- the closer to 50 the better - -qualifyCM :: Results a -> String -qualifyCM rs | c && m = "complete and minimal" - | c = "complete but non-minimal" - | m = "minimal but incomplete" - | otherwise = "incomplete and non-minimal" - where c = complete rs - m = minimal rs diff --git a/FitSpec/ShowMutable.hs b/FitSpec/ShowMutable.hs deleted file mode 100644 --- a/FitSpec/ShowMutable.hs +++ /dev/null @@ -1,362 +0,0 @@ --- | Show mutant variations -module FitSpec.ShowMutable - ( ShowMutable (..) - , mutantSEq - , showMutantAsTuple - , showMutantNested - , showMutantDefinition - , showMutantBindings - , MutantS () - , mutantSTuple - ) -where - -import FitSpec.PrettyPrint -import Test.LeanCheck.Error (errorToNothing, Listable(..)) -import Data.Maybe (mapMaybe,isNothing) -import Control.Monad (join) -import Data.List (intercalate,tails) -import Data.Char (isLetter) - - --- | Show a Mutant as a tuple of lambdas. --- --- > > putStrLn $ showMutantAsTuple ["p && q","not p"] ((&&),not) ((||),id) --- > ( \p q -> case (p,q) of --- > (False,False) -> True --- > _ -> p && q --- >, \p -> case p of --- > False -> False --- > True -> True --- > _ -> not p ) --- --- Can be easily copy pasted into an interactive session for manipulation. --- On GHCi, use @:{@ and @:}@ to allow multi-line expressions and definitions. -showMutantAsTuple :: ShowMutable a => [String] -> a -> a -> String -showMutantAsTuple names f f' = showMutantSAsTuple names - $ flatten - $ mutantS f f' - --- | Show a Mutant as the list of bindings that differ from the original --- function(s). --- --- > > putStrLn $ showMutantBindings ["p && q","not p"] ((&&),not) ((==),id) --- > False && False = True --- > not False = False --- > not True = True --- --- Can possibly be copied into the source of the original function for --- manipulation. -showMutantBindings :: ShowMutable a => [String] -> a -> a -> String -showMutantBindings names f f' = showMutantSBindings False names - $ flatten - $ mutantS f f' - --- | Show a Mutant as a new complete top-level definition, with a prime --- appended to the name of the mutant. --- --- > > putStrLn $ showMutantDefinition ["p && q","not p"] ((&&),not) ((==),id) --- > False &&- False = True --- > p &&- q = p && q --- > not' False = False --- > not' True = True --- > not' p = not p -showMutantDefinition :: ShowMutable a => [String] -> a -> a -> String -showMutantDefinition names f f' = showMutantSBindings True names - $ flatten - $ mutantS f f' - --- | Show a Mutant as a tuple of nested lambdas. --- Very similar to 'showMutantAsTuple', but the underlying data structure is --- not flatten: so the output is as close as possible to the underlying --- representation. -showMutantNested :: ShowMutable a => [String] -> a -> a -> String -showMutantNested names f f' = showMutantSAsTuple names - $ mutantS f f' - --- | Show a Mutant without providing a default name. --- An alias for @showMutantAsTuple []@. -showMutant :: ShowMutable a => a -> a -> String -showMutant = showMutantAsTuple [] - - --- | Default function names (when none given): --- --- > f g h f' g' h' f'' g'' h'' -defaultFunctionNames :: [String] -defaultFunctionNames = ["f","g","h"] ++ map (++"'") defaultFunctionNames - --- | Default names in a call (function and variables): --- --- > f x y z w x' y' z' w' x'' y'' z'' w'' ... -defaultNames :: [String] -defaultNames = head defaultFunctionNames : defVarNames - where defVarNames = ["x","y","z","w"] ++ map (++"'") defVarNames - - --- | Types that can have their mutation shown. --- Has only one function 'mutantS' that returns a simple AST ('MutantS') --- representing the mutant. A standard implementation of 'mutantS' for 'Eq' --- types is given by 'mutantSEq'. -class ShowMutable a where - mutantS :: a -> a -> MutantS - --- | For a given type @Type@ instance of @Eq@ and @Show@, --- define the 'ShowMutable' instance as: --- --- > instance ShowMutable Type --- > where mutantS = mutantSEq -mutantSEq :: (Eq a, Show a) - => a -> a -> MutantS -mutantSEq x x' = if x == x' - then Unmutated $ show x - else Atom $ show x' - -instance ShowMutable () where mutantS = mutantSEq -instance ShowMutable Int where mutantS = mutantSEq -instance ShowMutable Char where mutantS = mutantSEq -instance ShowMutable Bool where mutantS = mutantSEq -instance (Eq a, Show a) => ShowMutable [a] where mutantS = mutantSEq -instance (Eq a, Show a) => ShowMutable (Maybe a) where mutantS = mutantSEq - -instance (Listable a, Show a, ShowMutable b) => ShowMutable (a->b) where - -- TODO: let the user provide how many values should be tried when printing - mutantS f f' = Function - . take 10 - . filter (not . isUnmutated . snd) - . mapMaybe bindingFor - . take 200 - $ list - where bindingFor x = fmap ((,) [show x]) - $ errorToNothing (mutantS (f x) (f' x)) - -instance (ShowMutable a, ShowMutable b) => ShowMutable (a,b) where - mutantS (f,g) (f',g') = Tuple [ mutantS f f' - , mutantS g g' ] - -instance (ShowMutable a, ShowMutable b, ShowMutable c) - => ShowMutable (a,b,c) where - mutantS (f,g,h) (f',g',h') = Tuple [ mutantS f f' - , mutantS g g' - , mutantS h h' ] - - --- | (Show) Structure of a mutant. --- This format is intended for processing then pretty-printing. -data MutantS = Unmutated String - | Atom String - | Tuple [MutantS] - | Function [([String],MutantS)] - deriving Show - --- | Check if a 'MutantS' is null -isUnmutated :: MutantS -> Bool -isUnmutated (Unmutated _) = True -isUnmutated (Tuple ms) = all isUnmutated ms -isUnmutated (Function bs) = all (isUnmutated . snd) bs -isUnmutated _ = False - --- | Check if a 'MutantS' is a function. -isFunction :: MutantS -> Bool -isFunction (Function _) = True -isFunction _ = False - --- | Flatten a MutantS by merging nested 'Function's. -flatten :: MutantS -> MutantS -flatten (Tuple ms) = Tuple $ map flatten ms -flatten (Function [([],s)]) = flatten s -flatten (Function (([],s):_)) = error "flatten: ambiguous value" -flatten (Function bs) = let bs' = map (mapSnd flatten) bs in - if any (not . isFunction . snd) bs' - then Function bs' - else Function - $ take 10 - $ concatMap (\(as,Function bs'') -> map (mapFst (as++)) bs'') bs' -flatten m = m - - --- | Show a nameless mutant. --- Functions should not (but can) be shown using this. -showMutantS :: MutantS -> String -showMutantS (Unmutated s) = s -showMutantS (Atom s) = s -showMutantS (Tuple ms) = showTuple $ map showMutantS ms -showMutantS (Function bs) = showLambda ["??"] bs - --- | Show top-level (maybe tuple) named 'MutantS' as a tuple. -showMutantSAsTuple :: [String] -> MutantS -> String -showMutantSAsTuple ns (Tuple ms) = showTuple $ zipWith show1 (ns +- defaultFunctionNames) ms - where show1 n (Unmutated _) = n - show1 n (Function bs) = showLambda (fvnames n) bs - show1 _ m = showMutantS m -showMutantSAsTuple ns m = showMutantSAsTuple ns (Tuple [m]) - --- | Show top-level (maybe tuple) named 'MutantS' as a bindings. --- In general, you want to 'flatten' the 'MutantS' before applying this --- function. -showMutantSBindings :: Bool -> [String] -> MutantS -> String -showMutantSBindings new ns (Tuple ms) = concatMap (uncurry show1) - $ zip (ns ++ defaultFunctionNames) ms - where show1 _ (Unmutated s) = "" - show1 _ (Function []) = "" - show1 n (Function bs) = showBindings new (fvnames n) bs - show1 n m = let fn = head $ fvnames n - fn' | new = prime fn - | otherwise = fn - in (apply fn' [] ++ " = ") - `beside` showMutantS m -showMutantSBindings new ns m = showMutantSBindings new ns (Tuple [m]) - - --- | Given a list with the function and variable names and a list of bindings, --- show a function as a case expression enclosed in a lambda. -showLambda :: [String] -> [([String],MutantS)] -> String -showLambda [] [] = "undefined {- (err?) unmutated -}" -showLambda (n:_) [] = apply n [] -showLambda _ [([],m)] = showMutantS m -showLambda _ (([],_):_) = "undefined {- (err?) ambiguous value -}" -showLambda ns bs = (("\\" ++ unwords bound ++ " -> ") `beside`) - $ "case " ++ showTuple bound ++ " of\n" - ++ " " `beside` cases - where - cases = concatMap (\(as,r) -> (showTuple as ++ " -> ") `beside` showResult r) bs - ++ "_ -> " ++ apply fn bound - showResult (Function bs') = showLambda (apply fn bound:unbound) bs' - showResult m = showMutantS m - unbound = drop (length bound) vns - bound = zipWith const vns (fst $ head bs) - (fn:vns) = ns +- defaultNames - --- | Given a list with the function and variable names and a list of bindings, --- show function binding declarations. --- --- The 'new' boolean argument indicates whether if the function should be shown --- as a new definition. -showBindings :: Bool -> [String] -> [([String],MutantS)] -> String -showBindings new ns bs = - table " " $ (uncurry showBind `map` bs) - ++ [words (apply fn' bound) ++ ["=", apply fn bound] | new] - where - showBind [a1,a2] r | isInfix fn' = [a1, fn', a2, "=", showMutantS r] - showBind as r = [fn'] ++ as ++ ["=", showMutantS r] - fn' | new = prime fn - | otherwise = fn - bound = zipWith const vns (fst $ head bs) - (fn:vns) = ns +- defaultNames - - --- | Separate function from variable names in a simple Haskell expr. --- --- > fvarnames "f x y" == ["f","x","y"] --- > fvarnames "aa bb cc dd" == ["aa","bb","cc","dd"] --- --- When there are three lexemes, the function checks for a potential infix --- operator in the middle. --- --- > fvarnames "x + y" == ["(+)","x","y"] --- --- This function always returns a "head" --- --- > fvarnames "" == ["f"] -fvnames :: String -> [String] -fvnames = fvns' . words - where fvns' :: [String] -> [String] - fvns' [a,o,b] | isInfix o = o:[a,b] - fvns' [] = defaultNames - fvns' fvs = fvs - --- | Apply a function ('String') to a list of variables ('[String]'). --- --- For the sake of clarity, in the following examples, double-quotes are omitted: --- > apply f == f --- > apply f x == f x --- > apply f x y == f x y --- > apply (+) == (+) --- > apply (+) x == (+) x --- > apply (+) x y == (+) x y --- > apply + == (+) --- > apply + x == (+) x --- > apply + x y == (x + y) --- > apply + x y z == (+) x y z -apply :: String -> [String] -> String -apply f [x,y] | isInfix f = unwords [x,f,y] -apply f xs = if isInfix f - then unwords (toPrefix f:xs) - else unwords (f:xs) - --- | Check if a function / operator is infix --- --- > isInfix "foo" == False --- > isInfix "(+)" == False --- > isInfix "`foo`" == True --- > isInfix "+" == True -isInfix :: String -> Bool -isInfix (c:cs) = c /= '(' && not (isLetter c) - --- | Transform an infix operator into an infix function: --- --- > toPrefix "`foo`" == "foo" --- > toPrefix "+" == "(+)" -toPrefix :: String -> String -toPrefix ('`':cs) = init cs -toPrefix cs = '(':cs ++ ")" - --- Primeify the name of a function by appending prime @'@ to functions and --- minus @-@ to operators. --- --- > prime "(+)" == "(+-)" --- > prime "foo" == "foo'" --- > prime "`foo`" == "`foo'`" --- > prime "*" == "*- -prime :: String -> String -prime ('`':cs) = '`':init cs ++ "'`" -- `foo` to `foo'` -prime ('(':cs) = '(':init cs ++ "-)" -- (+) to (+-) -prime cs | isInfix cs = cs ++ "-" -- + to +- - | otherwise = cs ++ "'" -- foo to foo' - - -mapFst :: (a->b) -> (a,c) -> (b,c) -mapFst f (x,y) = (f x,y) - -mapSnd :: (a->b) -> (c,a) -> (c,b) -mapSnd f (x,y) = (x,f y) - --- | @xs +- ys@ superimposes @xs@ over @ys@. --- --- [1,2,3] +- [0,0,0,0,0,0,0] == [1,2,3,0,0,0,0] --- [x,y,z] +- [a,b,c,d,e,f,g] == [x,y,z,d,e,f,g] --- "asdf" +- "this is a test" == "asdf is a test" -(+-) :: Eq a => [a] -> [a] -> [a] -xs +- ys = xs ++ drop (length xs) ys - - --- Instances of ShowMutable for up to 6-tuples are given here: - -instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d) - => ShowMutable (a,b,c,d) where - mutantS (f,g,h,i) (f',g',h',i') = Tuple [ mutantS f f' - , mutantS g g' - , mutantS h h' - , mutantS i i' ] - -instance (ShowMutable a, ShowMutable b, ShowMutable c, - ShowMutable d, ShowMutable e) - => ShowMutable (a,b,c,d,e) where - mutantS (f,g,h,i,j) (f',g',h',i',j') = Tuple [ mutantS f f' - , mutantS g g' - , mutantS h h' - , mutantS i i' - , mutantS j j' ] - -instance (ShowMutable a, ShowMutable b, ShowMutable c, - ShowMutable d, ShowMutable e, ShowMutable f) - => ShowMutable (a,b,c,d,e,f) where - mutantS (f,g,h,i,j,k) (f',g',h',i',j',k') = Tuple [ mutantS f f' - , mutantS g g' - , mutantS h h' - , mutantS i i' - , mutantS j j' - , mutantS k k' ] - -mutantSTuple :: [MutantS] -> MutantS -mutantSTuple = Tuple diff --git a/FitSpec/ShowMutable/Tuples.hs b/FitSpec/ShowMutable/Tuples.hs deleted file mode 100644 --- a/FitSpec/ShowMutable/Tuples.hs +++ /dev/null @@ -1,98 +0,0 @@ --- | ShowMutable instances: septuples up to 12-tuples --- --- This is part of a Hack that allows those instances to be hidden from Haddock. --- Otherwise Haddock documentation will look very ugly. -module FitSpec.ShowMutable.Tuples () where - -import FitSpec.ShowMutable - -instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, - ShowMutable e, ShowMutable f, ShowMutable g) - => ShowMutable (a,b,c,d,e,f,g) where - mutantS (f,g,h,i,j,k,l) (f',g',h',i',j',k',l') = mutantSTuple - [ mutantS f f' - , mutantS g g' - , mutantS h h' - , mutantS i i' - , mutantS j j' - , mutantS k k' - , mutantS l l' ] - -instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, - ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h) - => ShowMutable (a,b,c,d,e,f,g,h) where - mutantS (f,g,h,i,j,k,l,m) (f',g',h',i',j',k',l',m') = mutantSTuple - [ mutantS f f' - , mutantS g g' - , mutantS h h' - , mutantS i i' - , mutantS j j' - , mutantS k k' - , mutantS l l' - , mutantS m m' ] - -instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, - ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, - ShowMutable i) - => ShowMutable (a,b,c,d,e,f,g,h,i) where - mutantS (f,g,h,i,j,k,l,m,n) (f',g',h',i',j',k',l',m',n') = mutantSTuple - [ mutantS f f' - , mutantS g g' - , mutantS h h' - , mutantS i i' - , mutantS j j' - , mutantS k k' - , mutantS l l' - , mutantS m m' - , mutantS n n' ] - -instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, - ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, - ShowMutable i, ShowMutable j) - => ShowMutable (a,b,c,d,e,f,h,g,i,j) where - mutantS (f,g,h,i,j,k,l,m,n,o) (f',g',h',i',j',k',l',m',n',o') = mutantSTuple - [ mutantS f f' - , mutantS g g' - , mutantS h h' - , mutantS i i' - , mutantS j j' - , mutantS k k' - , mutantS l l' - , mutantS m m' - , mutantS n n' - , mutantS o o' ] - -instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, - ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, - ShowMutable i, ShowMutable j, ShowMutable k) - => ShowMutable (a,b,c,d,e,f,g,h,i,j,k) where - mutantS (f,g,h,i,j,k,l,m,n,o,p) (f',g',h',i',j',k',l',m',n',o',p') = mutantSTuple - [ mutantS f f' - , mutantS g g' - , mutantS h h' - , mutantS i i' - , mutantS j j' - , mutantS k k' - , mutantS l l' - , mutantS m m' - , mutantS n n' - , mutantS o o' - , mutantS p p' ] - -instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, - ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, - ShowMutable i, ShowMutable j, ShowMutable k, ShowMutable l) - => ShowMutable (a,b,c,d,e,f,g,h,i,j,k,l) where - mutantS (f,g,h,i,j,k,l,m,n,o,p,q) (f',g',h',i',j',k',l',m',n',o',p',q') = mutantSTuple - [ mutantS f f' - , mutantS g g' - , mutantS h h' - , mutantS i i' - , mutantS j j' - , mutantS k k' - , mutantS l l' - , mutantS m m' - , mutantS n n' - , mutantS o o' - , mutantS p p' - , mutantS q q' ] diff --git a/FitSpec/TestTypes.hs b/FitSpec/TestTypes.hs deleted file mode 100644 --- a/FitSpec/TestTypes.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | FitSpec Test Types: --- 'Nat', --- 'Int2', 'Int3', 'Int4', --- 'UInt2', 'UInt3', 'UInt4'. --- --- This module basically re-exports LeanCheck's Test.Types module --- and defines Mutable and ShowMutable instances for the types --- defined there. -module FitSpec.TestTypes (module Test.LeanCheck.Utils.Types) where - -import FitSpec.Mutable -import FitSpec.ShowMutable -import Test.LeanCheck.Utils.Types - --- {- Standard implementation: -instance Mutable Nat where mutiers = mutiersEq -instance Mutable Int1 where mutiers = mutiersEq -instance Mutable Int2 where mutiers = mutiersEq -instance Mutable Int3 where mutiers = mutiersEq -instance Mutable Int4 where mutiers = mutiersEq -instance Mutable Word1 where mutiers = mutiersEq -instance Mutable Word2 where mutiers = mutiersEq -instance Mutable Word3 where mutiers = mutiersEq -instance Mutable Word4 where mutiers = mutiersEq --- -} -{- Alternative implementation: -instance Mutable Nat where mutants = mutantsIntegral -instance Mutable Int2 where mutants = mutantsIntegral -instance Mutable Int3 where mutants = mutantsIntegral -instance Mutable Int4 where mutants = mutantsIntegral -instance Mutable Word2 where mutants = mutantsIntegral -instance Mutable Word3 where mutants = mutantsIntegral -instance Mutable Word4 where mutants = mutantsIntegral --- -} -instance ShowMutable Nat where mutantS = mutantSEq -instance ShowMutable Int1 where mutantS = mutantSEq -instance ShowMutable Int2 where mutantS = mutantSEq -instance ShowMutable Int3 where mutantS = mutantSEq -instance ShowMutable Int4 where mutantS = mutantSEq -instance ShowMutable Word1 where mutantS = mutantSEq -instance ShowMutable Word2 where mutantS = mutantSEq -instance ShowMutable Word3 where mutantS = mutantSEq -instance ShowMutable Word4 where mutantS = mutantSEq diff --git a/FitSpec/Utils.hs b/FitSpec/Utils.hs deleted file mode 100644 --- a/FitSpec/Utils.hs +++ /dev/null @@ -1,133 +0,0 @@ --- | General purpose utility functions for FitSpec -{-# LANGUAGE CPP #-} -module FitSpec.Utils - ( (...) - , uncurry3 - , count - , compositions - , subsets - , contained - , contains - , filterU - , sortAndGroupOn - , sortAndGroupFstBySnd - , sortGroupAndCollapse - , takeWhileIncreasing - , takeWhileIncreasingOn - , lastTimeout - , sortOn - , (***) - ) -where - -#if __GLASGOW_HASKELL__ <= 704 -import Prelude hiding (catch) -#endif -import System.IO.Unsafe (unsafePerformIO) -import Control.Exception ( Exception - , SomeException - , ArithException - , ArrayException - , ErrorCall - , PatternMatchFail - , catch - , catches - , Handler (Handler) - , evaluate - ) -import Data.Function (on) -import Data.Ord (comparing) -import Data.List (groupBy,sortBy) -import Data.IORef (newIORef, readIORef, writeIORef) -import Control.Concurrent (forkIO, threadDelay, killThread) -import Control.Monad (liftM) - --- | Compose composed with compose operator. --- --- > (f ... g) x y === f (g x y) -(...) :: (c->d) -> (a->b->c) -> a -> b -> d -(...) = (.) . (.) --- f ... g = \x y -> f (g x y) - -uncurry3 :: (a->b->c->d) -> (a,b,c) -> d -uncurry3 f (x,y,z) = f x y z - -count :: (a -> Bool) -> [a] -> Int -count p = length . filter p - --- | 'compositions' @bs@ returns all compositions formed by taking values of @bs@ -compositions :: [Bool] -> [Bool] -compositions = map and . subsets - --- | 'subsets' @xs@ returns the list of sublists formed by taking values of @xs@ -subsets :: [a] -> [[a]] -subsets [] = [[]] -subsets (x:xs) = map (x:) (subsets xs) ++ subsets xs - --- TODO: rename contained and contains to subset and superset? - --- | Check if all elements of a list is contained in another list -contained :: Eq a => [a] -> [a] -> Bool -xs `contained` ys = all (`elem` ys) xs - -contains :: Eq a => [a] -> [a] -> Bool -contains = flip contained - --- | 'filterU' filter greater-later elements in a list according to a partial --- ordering relation. --- --- > filterU (notContained) [[1],[2],[1,2,3],[3,4,5]] == [[1],[2],[3,4,5]] -filterU :: (a -> a -> Bool) -> [a] -> [a] -filterU f [] = [] -filterU f (x:xs) = x : filter (f x) (filterU f xs) - -sortOn :: Ord b => (a -> b) -> [a] -> [a] -sortOn f = sortBy (compare `on` f) - -sortAndGroupOn :: Ord b => (a -> b) -> [a] -> [[a]] -sortAndGroupOn f = groupBy ((==) `on` f) - . sortOn f - -sortGroupAndCollapse :: Ord b - => (a -> b) -> (a -> c) -> (b -> [c] -> d) - -> [a] -> [d] -sortGroupAndCollapse f g h = map collapse - . sortAndGroupOn f - where collapse (x:xs) = f x `h` map g (x:xs) - -sortAndGroupFstBySnd :: Ord b => [(a,b)] -> [([a],b)] -sortAndGroupFstBySnd = sortGroupAndCollapse snd fst (flip (,)) - --- | Takes values from a list while the values increase. If the original list --- is non-empty, the returning list will also be non-empty -takeWhileIncreasing :: (a -> a -> Ordering) -> [a] -> [a] -takeWhileIncreasing _ [] = [] -takeWhileIncreasing _ [x] = [x] -takeWhileIncreasing cmp (x:y:xs) = x : case x `cmp` y of - LT -> takeWhileIncreasing cmp (y:xs) - _ -> [] - - -takeWhileIncreasingOn :: Ord b => (a -> b) -> [a] -> [a] -takeWhileIncreasingOn f = takeWhileIncreasing (compare `on` f) - - --- | @lastTimeout s xs@ will take the last value of @xs@ it is able evaluate --- before @s@ seconds elapse. -lastTimeout :: Int -> [a] -> IO a -lastTimeout _ [] = error "lastTimeout: empty list" -lastTimeout 0 (x:_) = return x -- no time to lose -lastTimeout s (x:xs) = do - r <- newIORef x - tid <- forkIO $ keepImproving r xs - threadDelay (s*1000000) -- TODO: change to waitForThread!!! - killThread tid - readIORef r - where keepImproving _ [] = return () - keepImproving r (x:xs) = do - evaluate x - writeIORef r x - keepImproving r xs - -(***) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d) -f *** g = \(x,y) -> (f x, g y) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,7 +20,7 @@ $ cabal install fitspec -Pre-requisites are [cmdargs], [pretty] and [leancheck]. +Pre-requisites are [cmdargs] and [leancheck]. They should be automatically resolved and installed by [Cabal]. diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -15,9 +15,3 @@ * write detailed install instructions on INSTALL.md (cabal install, cabal from sandbox, source include) - - -v0.3 ----- - -* (?) rename FitSpec to Test.FitSpec diff --git a/bench/avltrees.hs b/bench/avltrees.hs --- a/bench/avltrees.hs +++ b/bench/avltrees.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -import FitSpec +import Test.FitSpec import AVLTree import Data.List (sort,nubBy) @@ -13,7 +13,7 @@ -- all possible mid-points of a list, then recursively -- generating trees for the rest of elements. instance (Ord a, Listable a) => Listable (Tree a) where - tiers = map (nubBy same . sort) (consFromNoDupList fromList) + tiers = map (nubBy same . sort) (noDupListCons fromList) instance (Ord a, Listable a) => Mutable (Tree a) where mutiers = mutiersEq diff --git a/bench/bools.hs b/bench/bools.hs --- a/bench/bools.hs +++ b/bench/bools.hs @@ -1,4 +1,4 @@ -import FitSpec +import Test.FitSpec propertiesN :: (Bool -> Bool) -> [Property] propertiesN not = diff --git a/bench/digraphs.hs b/bench/digraphs.hs --- a/bench/digraphs.hs +++ b/bench/digraphs.hs @@ -13,7 +13,7 @@ -- * allows switching between refinements -- 'digraphs ps 0', 'digraphs ps 1', ...; -- * uses polymorphism where it could use monomorphism. import Digraph as D -import FitSpec.Most +import Test.FitSpec import Data.List ((\\)) import qualified Data.List as L (delete) import Control.Monad diff --git a/bench/heaps.hs b/bench/heaps.hs --- a/bench/heaps.hs +++ b/bench/heaps.hs @@ -1,6 +1,6 @@ {-# Language DeriveDataTypeable, NoMonomorphismRestriction #-} import System.Console.CmdArgs hiding (args) -import FitSpec +import Test.FitSpec import Prelude hiding (null) import qualified Data.List as L import Data.Maybe (listToMaybe) @@ -8,7 +8,7 @@ import Control.Monad (unless) instance (Ord a, Listable a) => Listable (Heap a) where - tiers = consFromAscendingList fromList + tiers = bagCons fromList -- a good property to assure that the above does not leave out elements is: -- diff --git a/bench/id.hs b/bench/id.hs --- a/bench/id.hs +++ b/bench/id.hs @@ -1,6 +1,6 @@ -- Example benchmark that mutation tests properties over the function id import System.Console.CmdArgs hiding (args) -import FitSpec +import Test.FitSpec type Ty a = a -> a diff --git a/bench/list.hs b/bench/list.hs --- a/bench/list.hs +++ b/bench/list.hs @@ -1,5 +1,5 @@ import System.Console.CmdArgs hiding (args) -import FitSpec +import Test.FitSpec import Data.List type Cons a = a -> [a] -> [a] diff --git a/bench/mergeheaps.hs b/bench/mergeheaps.hs --- a/bench/mergeheaps.hs +++ b/bench/mergeheaps.hs @@ -1,6 +1,6 @@ {-# Language DeriveDataTypeable, NoMonomorphismRestriction #-} import System.Console.CmdArgs hiding (args) -import FitSpec +import Test.FitSpec import Prelude hiding (null) import qualified Data.List as L import Data.Maybe (listToMaybe) @@ -8,7 +8,7 @@ import Control.Monad (unless) instance (Ord a, Listable a) => Listable (Heap a) where - tiers = consFromAscendingList fromList + tiers = bagCons fromList instance (Ord a, Listable a) => Mutable (Heap a) where mutiers = mutiersEq diff --git a/bench/pretty.hs b/bench/pretty.hs --- a/bench/pretty.hs +++ b/bench/pretty.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -import FitSpec +import Test.FitSpec import Text.PrettyPrint #if __GLASGOW_HASKELL__ < 710 diff --git a/bench/sets.hs b/bench/sets.hs --- a/bench/sets.hs +++ b/bench/sets.hs @@ -1,9 +1,9 @@ import Set -import FitSpec hiding ((\/)) +import Test.FitSpec hiding ((\/)) instance (Ord a, Listable a) => Listable (Set a) where - tiers = consFromSet set + tiers = setCons set instance (Ord a, Listable a) => Mutable (Set a) where mutiers = mutiersEq diff --git a/bench/setsofsets.hs b/bench/setsofsets.hs --- a/bench/setsofsets.hs +++ b/bench/setsofsets.hs @@ -1,9 +1,9 @@ import Set -import FitSpec hiding ((\/)) +import Test.FitSpec hiding ((\/)) instance (Ord a, Listable a) => Listable (Set a) where - tiers = consFromSet set + tiers = setCons set instance (Ord a, Listable a) => Mutable (Set a) where mutiers = mutiersEq diff --git a/bench/sieve.hs b/bench/sieve.hs --- a/bench/sieve.hs +++ b/bench/sieve.hs @@ -1,6 +1,6 @@ -- Example benchmark that mutation tests properties over an infinite list of primes import System.Console.CmdArgs hiding (args) -import FitSpec +import Test.FitSpec import Data.Maybe -- The code under test diff --git a/bench/sorting.hs b/bench/sorting.hs --- a/bench/sorting.hs +++ b/bench/sorting.hs @@ -1,5 +1,5 @@ import Data.List -import FitSpec +import Test.FitSpec ordered :: Ord a => [a] -> Bool diff --git a/bench/spring.hs b/bench/spring.hs --- a/bench/spring.hs +++ b/bench/spring.hs @@ -1,5 +1,5 @@ import System.Console.CmdArgs hiding (args) -import FitSpec +import Test.FitSpec import Data.List type Add a = a -> a -> a diff --git a/fitspec.cabal b/fitspec.cabal --- a/fitspec.cabal +++ b/fitspec.cabal @@ -1,5 +1,5 @@ name: fitspec -version: 0.2.2 +version: 0.3.0 synopsis: refining property sets for testing Haskell programs description: FitSpec provides automated assistance in the task of refining test properties @@ -38,138 +38,144 @@ source-repository this type: git location: https://github.com/rudymatela/fitspec - tag: v0.2.2 + tag: v0.3.0 library - exposed-modules: FitSpec - , FitSpec.Engine - , FitSpec.Report - , FitSpec.Mutable - , FitSpec.Mutable.Tuples - , FitSpec.ShowMutable - , FitSpec.ShowMutable.Tuples - , FitSpec.Derive - , FitSpec.Main - , FitSpec.Most - , FitSpec.TestTypes - other-modules: FitSpec.Utils - , FitSpec.PrettyPrint - , FitSpec.Dot + exposed-modules: Test.FitSpec + , Test.FitSpec.Engine + , Test.FitSpec.Report + , Test.FitSpec.Mutable + , Test.FitSpec.Mutable.Tuples + , Test.FitSpec.ShowMutable + , Test.FitSpec.ShowMutable.Tuples + , Test.FitSpec.Derive + , Test.FitSpec.Main + , Test.FitSpec.TestTypes + other-modules: Test.FitSpec.Utils + , Test.FitSpec.PrettyPrint + , Test.FitSpec.Dot build-depends: base >= 4 && < 5, leancheck >= 0.4, cmdargs, template-haskell - hs-source-dirs: . + hs-source-dirs: src default-language: Haskell2010 test-suite mutate type: exitcode-stdio-1.0 main-is: test-mutate.hs - hs-source-dirs: ., tests + hs-source-dirs: src, tests build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell default-language: Haskell2010 test-suite showmutable type: exitcode-stdio-1.0 main-is: test-showmutable.hs - hs-source-dirs: ., tests + hs-source-dirs: src, tests build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell default-language: Haskell2010 test-suite derive type: exitcode-stdio-1.0 main-is: test-derive.hs - hs-source-dirs: ., tests + hs-source-dirs: src, tests build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell default-language: Haskell2010 +test-suite utils + type: exitcode-stdio-1.0 + main-is: test-utils.hs + hs-source-dirs: src, tests + build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell + default-language: Haskell2010 + benchmark avltrees main-is: avltrees.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark bools main-is: bools.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark digraphs main-is: digraphs.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark heaps main-is: heaps.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark id main-is: id.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark list main-is: list.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark mergeheaps main-is: mergeheaps.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark pretty main-is: pretty.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell, pretty - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark sets main-is: sets.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark setsofsets main-is: setsofsets.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark sieve main-is: sieve.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark sorting main-is: sorting.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 benchmark spring main-is: spring.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell - hs-source-dirs: ., bench + hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 diff --git a/src/Test/FitSpec.hs b/src/Test/FitSpec.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec.hs @@ -0,0 +1,106 @@ +-- | FitSpec: refining property-sets for functional testing +-- +-- FitSpec provides automated assistance in the task of refining test properties +-- for Haskell functions. FitSpec tests mutant variations of functions under test +-- against a given property set, recording any surviving mutants that pass all +-- tests. FitSpec then reports: +-- +-- * /surviving mutants:/ +-- indicating incompleteness of properties, +-- prompting the user to amend a property or to add a new one; +-- * /conjectures:/ +-- indicating redundancy in the property set, +-- prompting the user to remove properties so to reduce the cost of testing. +-- +-- Example, refining a @sort@ specification: +-- +-- > import FitSpec +-- > import Data.List (sort) +-- > +-- > properties sort = +-- > [ property $ \xs -> ordered (sort xs) +-- > , property $ \xs -> length (sort xs) == length xs +-- > , property $ \x xs -> elem x (sort xs) == elem x xs +-- > , property $ \x xs -> notElem x (sort xs) == notElem x xs +-- > , property $ \x xs -> minimum (x:xs) == head (sort (x:xs)) +-- > ] +-- > where +-- > ordered (x:y:xs) = x <= y && ordered (y:xs) +-- > ordered _ = True +-- > +-- > main = mainWith args { names = ["sort xs"] +-- > , nMutants = 4000 +-- > , nTests = 4000 +-- > , timeout = 0 +-- > } +-- > (sort::[Word2]->[Word2]) +-- +-- The above program reports the following: +-- +-- > Apparent incomplete and non-minimal specification based on +-- > 4000 test cases for each of properties 1, 2, 3, 4 and 5 +-- > for each of 4000 mutant variations. +-- > +-- > 3 survivors (99% killed), smallest: +-- > \xs -> case xs of +-- > [0,0,1] -> [0,1,1] +-- > _ -> sort xs +-- > +-- > apparent minimal property subsets: {1,2,3} {1,2,4} +-- > conjectures: {3} = {4} 96% killed (weak) +-- > {1,3} ==> {5} 98% killed (weak) +module Test.FitSpec + ( + -- * Encoding properties + Property + , property + + -- * Configuring reports + , Args (..), ShowMutantAs (..) + , args + , fixargs + + -- * Reporting results + , report + , reportWith + , reportWithExtra + + -- ** Parsing command line arguments + , mainWith + , defaultMain + , getArgs + , getArgsWith + + -- * Mutable types + , Mutable (..) + , mutiersEq + + , ShowMutable (..) + , mutantSEq + , showMutantAsTuple + , showMutantDefinition + , showMutantNested + , showMutantBindings + + -- * Automatic derivation + , deriveMutable + , deriveMutableE + + -- * Re-export modules + , module Test.FitSpec.TestTypes + , module Test.LeanCheck + ) +where + +import Test.FitSpec.Engine +import Test.FitSpec.Report +import Test.FitSpec.Main + +import Test.FitSpec.Mutable +import Test.FitSpec.Mutable.Tuples +import Test.FitSpec.ShowMutable +import Test.FitSpec.ShowMutable.Tuples +import Test.FitSpec.Derive +import Test.FitSpec.TestTypes + +import Test.LeanCheck diff --git a/src/Test/FitSpec/Derive.hs b/src/Test/FitSpec/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/Derive.hs @@ -0,0 +1,172 @@ +-- | Experimental module for deriving Mutable instances +-- +-- Needs GHC and Template Haskell +-- (tested on GHC 7.4, 7.6, 7.8, 7.10 and 8.0) +-- +-- Despite Mutable instances being actually very simple, this module can be +-- used to derive those. However, it will not work on all cases: when that +-- happens, you should write your instances manually. +{-# LANGUAGE TemplateHaskell, CPP #-} +module Test.FitSpec.Derive + ( deriveMutable + , deriveMutableE + , module Test.FitSpec.Mutable + , module Test.FitSpec.ShowMutable + , module Test.LeanCheck + ) +where + +import Test.FitSpec.Mutable +import Test.FitSpec.ShowMutable + +import Test.LeanCheck +import Language.Haskell.TH +import Control.Monad (when, unless, liftM, liftM2) + +#if __GLASGOW_HASKELL__ < 706 +-- reportWarning was only introduced in GHC 7.6 / TH 2.8 +reportWarning :: String -> Q () +reportWarning = report False +#endif + +deriveListableIfNeeded :: Name -> DecsQ +deriveListableIfNeeded t = do + is <- t `isInstanceOf` ''Listable + if is + then return [] + else deriveListable t + +-- | Derives a Mutable instance for a given type 'Name'. +deriveMutable :: Name -> DecsQ +deriveMutable = deriveMutableE [] + +-- | Derives a Mutable instance for a given type 'Name' +-- using a given context for all type variables. +deriveMutableE :: [Name] -> Name -> DecsQ +deriveMutableE cs t = do + is <- t `isInstanceOf` ''Mutable + if is + then do + reportWarning $ "Instance Mutable " ++ show t + ++ " already exists, skipping derivation" + return [] + else do + cd <- canDeriveMutable t + unless cd (fail $ "Unable to derive Mutable " ++ show t) + liftM2 (++) (deriveListableIfNeeded t) (reallyDeriveMutable cs t) + +-- | Checks whether it is possible to derive a Mutable instance. +canDeriveMutable :: Name -> Q Bool +canDeriveMutable t = (t `isInstanceOf` ''Eq) + &&& (t `isInstanceOf` ''Show) + where (&&&) = liftM2 (&&) + +reallyDeriveMutable :: [Name] -> Name -> DecsQ +reallyDeriveMutable cs t = do + (nt,vs) <- normalizeType t +#if __GLASGOW_HASKELL__ >= 710 + cxt <- sequence [ [t| $(conT c) $(return v) |] +#else + cxt <- sequence [ classP c [return v] +#endif + | v <- vs, c <- ''Eq:''Listable:''Show:cs ] +#if __GLASGOW_HASKELL__ >= 708 + cxt |=>| [d| instance Mutable $(return nt) + where mutiers = mutiersEq + instance ShowMutable $(return nt) + where mutantS = mutantSEq |] +#else + return [ InstanceD + cxt + (AppT (ConT ''Mutable) nt) + [ValD (VarP 'mutiers) (NormalB (VarE 'mutiersEq)) []] + , InstanceD + cxt + (AppT (ConT ''ShowMutable) nt) + [ValD (VarP 'mutantS) (NormalB (VarE 'mutantSEq)) []] + ] +#endif + + +-- * Template haskell utilities + +-- Normalizes a type by applying it to necessary type variables, making it +-- accept "zero" parameters. The normalized type is tupled with a list of +-- necessary type variables. +-- +-- Suppose: +-- +-- > data DT a b c ... = ... +-- +-- Then, in pseudo-TH: +-- +-- > normalizeType [t|DT|] == Q (DT a b c ..., [a, b, c, ...]) +normalizeType :: Name -> Q (Type, [Type]) +normalizeType t = do + ar <- typeArity t + vs <- newVarTs ar + return (foldl AppT (ConT t) vs, vs) + where + newNames :: [String] -> Q [Name] + newNames = mapM newName + newVarTs :: Int -> Q [Type] + newVarTs n = liftM (map VarT) + $ newNames (take n . map (:[]) $ cycle ['a'..'z']) + +-- Normalizes a type by applying it to units (`()`) while possible. +-- +-- > normalizeTypeUnits ''Int === [t| Int |] +-- > normalizeTypeUnits ''Maybe === [t| Maybe () |] +-- > normalizeTypeUnits ''Either === [t| Either () () |] +normalizeTypeUnits :: Name -> Q Type +normalizeTypeUnits t = do + ar <- typeArity t + return (foldl AppT (ConT t) (replicate ar (TupleT 0))) + +-- Given a type name and a class name, +-- returns whether the type is an instance of that class. +isInstanceOf :: Name -> Name -> Q Bool +isInstanceOf tn cl = do + ty <- normalizeTypeUnits tn + isInstance cl [ty] + +-- | Given a type name, return the number of arguments taken by that type. +-- Examples in partially broken TH: +-- +-- > arity ''Int === Q 0 +-- > arity ''Int->Int === Q 0 +-- > arity ''Maybe === Q 1 +-- > arity ''Either === Q 2 +-- > arity ''Int-> === Q 1 +-- +-- This works for Data's and Newtype's and it is useful when generating +-- typeclass instances. +typeArity :: Name -> Q Int +typeArity t = do + ti <- reify t + return . length $ case ti of +#if __GLASGOW_HASKELL__ < 800 + TyConI (DataD _ _ ks _ _) -> ks + TyConI (NewtypeD _ _ ks _ _) -> ks +#else + TyConI (DataD _ _ ks _ _ _) -> ks + TyConI (NewtypeD _ _ ks _ _ _) -> ks +#endif + _ -> error $ "error (arity): symbol " + ++ show t + ++ " is not a newtype or data" + +-- Append to instance contexts in a declaration. +-- +-- > sequence [[|Eq b|],[|Eq c|]] |=>| [t|instance Eq a => Cl (Ty a) where f=g|] +-- > == [t| instance (Eq a, Eq b, Eq c) => Cl (Ty a) where f = g |] +(|=>|) :: Cxt -> DecsQ -> DecsQ +c |=>| qds = do ds <- qds + return $ map (`ac` c) ds +#if __GLASGOW_HASKELL__ < 800 + where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds + ac d _ = d +#else + where ac (InstanceD o c ts ds) c' = InstanceD o (c++c') ts ds + ac d _ = d +#endif diff --git a/src/Test/FitSpec/Dot.hs b/src/Test/FitSpec/Dot.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/Dot.hs @@ -0,0 +1,70 @@ +-- | Generate dotfiles (graphviz) +module Test.FitSpec.Dot where + +import Test.FitSpec +import Test.FitSpec.Engine +import Test.FitSpec.Utils +import Data.List + +-- | Given a list of pairs of property groups and their implications, +-- return implications between groups (transitive cases are ommitted). +groupImplications :: Eq i => [([[i]], [i])] -> [([[i]],[[i]])] +groupImplications [] = [] +groupImplications (n:ns) = [ (fst n, fst n') + | n' <- filterU (not ... implies) + . filter (n `implies`) + $ ns + ] ++ groupImplications ns + where actual (iss,is) = foldr union [] iss `union` is + n `implies` m = actual n `contains` actual m + +isObvious :: Eq i => [[i]] -> [[i]] -> Bool +isObvious as bs = or [ a `contains` b + | a <- as + , b <- bs ] + +attachObviousness :: Eq i => [([[i]], [[i]])] -> [([[i]],[[i]],Bool)] +attachObviousness = map attachObviousness' + where attachObviousness' (as,bs) = (as,bs,isObvious as bs) + + +-- | Given a list of relations, generate a graphviz graph containing those relations. +-- Generate a dotfile from implications between groups. +genDotfileFromGI :: Show i + => [([[i]],[[i]],Bool)] + -> String +genDotfileFromGI = (\s -> "digraph G {\n" ++ s ++ "}\n") + . unlines + . map showEntry + where showG = unwords . map show + showEntry (iss,jss,p) = "\"" ++ showG iss ++ "\" -> \"" + ++ showG jss ++ "\"" + ++ if p + then " [ color = grey ]" + else "" + +-- | Equivalent to 'getResults' but returns a dotfile +getDotfile :: (Mutable a) + => [a] + -> Int -> Int -> a -> (a -> [Property]) + -> String +getDotfile ems m n f ps = genDotfileFromGI + . attachObviousness + . groupImplications + . map (\r -> (sets r, implied r)) + $ getResultsExtra ems f ps m n + +-- | Equivalent to report, but writes a dotfile to a file +writeDotfile :: (Mutable a) + => String + -> [a] + -> Int -> Int -> a -> (a -> [Property]) + -> IO () +writeDotfile fn ems m n f = writeFile fn . getDotfile ems m n f + +-- | Equivalent to report, but writes a dotfile to stdout +putDotfile :: (Mutable a) + => [a] + -> Int -> Int -> a -> (a -> [Property]) + -> IO () +putDotfile ems m n f = putStr . getDotfile ems m n f diff --git a/src/Test/FitSpec/Engine.hs b/src/Test/FitSpec/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/Engine.hs @@ -0,0 +1,278 @@ +-- | FitSpec: refining property-sets for functional testing +-- +-- This is the main engine, besides "Test.FitSpec.Mutable". +module Test.FitSpec.Engine + ( property + , Property + + , getResults + , getResultsExtra + , getResultsExtraTimeout + , Result (..) + , Results + + , propertiesNTests + , propertiesTestsExhausted + , propertiesToMap + , propertiesHold + , propertiesCE + + , minimal + , complete + + , reduceImplications + , filterNonCanon + , Conjecture (..) + , conjectures + ) +where + +import Test.LeanCheck.Error +import Test.FitSpec.Utils +import Data.Maybe (catMaybes, listToMaybe) +import Data.List ((\\),union,transpose) +import Test.FitSpec.Mutable + +-- | An encoded representation of a property suitable for use by FitSpec. +-- +-- Each list of strings is a printable representation of one possible choice of +-- argument values for the property. Each boolean indicate whether the +-- property holds for this choice. +type Property = [([String],Bool)] +type Properties = [Property] + +-- | Given a 'Testable' type (as defined by 'Test.LeanCheck'), returns a 'Property'. +-- +-- This function should be used on every property to create a property list to +-- be passed to 'report', 'reportWith', 'mainDefault' or 'mainWith'. +-- +-- > property $ \x y -> x + y < y + (x::Int) +property :: Testable a => a -> Property +property = results + +propertyHolds :: Int -> Property -> Bool +propertyHolds n = all snd . take n + +propertyCE :: Int -> Property -> Maybe String +propertyCE n = listToMaybe . map (unwords . fst) . filter (not . snd) . take n + +propertiesToMap :: [Property] -> Int -> [Bool] +propertiesToMap ps n = map (propertyHolds n) ps + +propertiesHold :: Int -> [Property] -> Bool +propertiesHold n = all (propertyHolds n) + +propertiesCE :: Int -> [Property] -> Maybe String +propertiesCE n = listToMaybe + . catMaybes + . zipWith (\n -> fmap ((show n ++ ": ") ++)) [1..] + . map (propertyCE n) + +propertiesNTests :: Int -> [Property] -> [Int] +propertiesNTests n = map (length . take n) + +propertiesTestsExhausted :: Int -> [Property] -> [Bool] +propertiesTestsExhausted n = map (<= n) . propertiesNTests (n+1) + +filterNonCanon :: [Result a] -> [Result a] +filterNonCanon [] = [] +filterNonCanon (r:rs) = (r:) + . filterNonCanon + . filter (not . null . sets) + . map (updateSets removeNonCanon) + $ rs + where removeNonCanon = filter (not . (\p' -> (p' `contains`) `any` tail (sets r))) + updateSets f r = r { sets = f (sets r) } + +reduceImplications :: [Result a] -> [Result a] +reduceImplications [] = [] +reduceImplications (r:rs) = r : map (r `reduce`) (reduceImplications rs) + where r `reduce` r' = if or [s `contained` s' | s <- sets r, s' <- sets r'] + then r' { implied = implied r' \\ implied r } + else r' + + +-- | A line of result for a single equivalence class of properties +-- with the exact same surviving mutants. +data Result a = Result + { sets :: [[Int]] -- ^ property-sets in the equivalence class + , implied :: [Int] -- ^ properties implied by this class + , survivors :: [a] -- ^ list of surviving mutants + , smallestSurvivor :: Maybe a -- ^ smallest surviving mutant, if any + , nSurvivors :: Int -- ^ number of surviving mutants + , nKilled :: Int -- ^ number of killed mutants + , totalMutants :: Int -- ^ total number of mutants generated and tested + , score :: Int -- ^ percentage of killed mutants, 0-100 + , maxTests :: Int -- ^ Requested number of tests (same for all rs.) + , mutantsExhausted :: Bool -- ^ mutants were exhausted + } +type Results a = [Result a] + + +-- | Return minimality and completeness results. See 'report'. +getResults :: (Mutable a) + => a -> (a -> [Property]) -> Int -> Int + -> Results a +getResults = getResultsExtra [] + +getResultsExtra :: (Mutable a) + => [a] + -> a -> (a -> [Property]) -> Int -> Int + -> Results a +getResultsExtra ems f ps nms nts = map (uncurry $ processRawResult mex nts) + $ getRawResults is pmap ms + where is = [1..(length $ ps f)] + pmap f = propertiesToMap (ps f) nts + ms' = take (nms+1) (tail $ mutants f) + mex = length ms' <= nms + ms = take nms ms' ++ ems + +getResultsExtraTimeout :: (Mutable a) + => Int + -> [a] + -> a -> (a -> [Property]) -> Int -> Int + -> IO (Results a) +getResultsExtraTimeout 0 ems f ps m n = return $ getResultsExtra ems f ps m n +getResultsExtraTimeout t ems f ps nm0 nt0 = lastTimeout t resultss + where + resultss = map fst + $ takeWhileIncreasingOn ((totalMutants . head) *** id) + [ (getResultsExtra ems f ps nm nt, propertiesNTests nt $ ps f) + | (nm,nt) <- iterate (incHalf *** incHalf) (nm0,nt0) ] + incHalf x = x + x `div` 2 + +processRawResult :: Bool -> Int -> [[Int]] -> [(a,Bool)] -> Result a +processRawResult mex nt iss mhs = Result + { sets = relevantPropertySets iss + , implied = relevantImplications iss + , survivors = ms + , smallestSurvivor = listToMaybe ms + , nSurvivors = ns + , nKilled = nk + , totalMutants = nm + , score = nk*100 `div` nm + , maxTests = nt + , mutantsExhausted = mex + } + where ms = [m | (m,h) <- mhs, h] + nm = length mhs + ns = length ms + nk = nm - ns + +minimal :: Results a -> Bool +minimal (r:_) = null (implied r) + && length (sets r) == 1 + +complete :: Results a -> Bool +complete (r:_) = nSurvivors r == 0 + +relevantPropertySets :: Eq i => [[i]] -> [[i]] +relevantPropertySets = filterU (not ... contained) . sortOn length + +relevantImplications :: Eq i => [[i]] -> [i] +relevantImplications iss = foldr union [] iss + \\ foldr union [] (relevantPropertySets iss) + +-- | Returns a description of property sets, grouping the ones that had the +-- same surviving mutants. The resulting list is ordered starting with the +-- least surviving mutants to the most surviving mutants. +-- +-- Arguments: +-- +-- * @is@: list of property ids (@length is == length (pmap x)@) +-- +-- * @pmap@: a property map +-- +-- * @ms@: list of mutants to apply to the property map +-- +-- Return a list of tuples containing: +-- +-- * a list of property sets +-- * a list of mutants paired with booleans indicating whether each survived +getRawResults :: [i] -> (a -> [Bool]) -> [a] -> [([[i]],[(a,Bool)])] +getRawResults is ps ms = (id *** (zip ms)) `map` getRawResults' is ps ms + +-- | Returns a description of property sets, grouping the ones that had the +-- same surviving mutants. The resulting list is ordered starting with the +-- least surviving mutants to the most surviving mutants. +-- +-- Arguments: +-- +-- * @is@: list of property ids (@length is == length (pmap x)@) +-- +-- * @pmap@: a property map +-- +-- * @ms@: list of mutants to apply to the property map +-- +-- Return a list of tuples containing: +-- +-- * a list of property sets +-- * a boolean list indicating whether a given mutant survived +getRawResults' :: [i] -> (a -> [Bool]) -> [a] -> [([[i]],[Bool])] +getRawResults' is pmap = sortOn (count id . snd) + . sortAndGroupFstBySnd + . zip (subsets is) + . transpose + . map (compositions . pmap) + +-- | 'nSurv' @props fs@ returns the number of values that match +-- compositions of properties on the property map. +-- +-- * @props@ should be a function from a value to a list of properties that +-- match that value (in the case of functions, functions that "survive" those +-- properties). +-- +-- * @fs@ is a list of values to be mapped over by @props@ +-- +-- > length (nSurvivors props fs) == 2 ^ (length (props fs)) +-- +-- This function is otherwise unused in this file. It is just a simpler +-- version of 'pssurv' to serve as documentation. +nSurv :: (a -> [Bool]) -> [a] -> [Int] +nSurv props = map (count id) + . transpose + . map (compositions . props) + + +data Conjecture = Conjecture + { isEq :: Bool + , isIm :: Bool + , cleft :: [Int] + , cright :: [Int] + , cscore :: Int + , cnKilled :: Int + , cnSurvivors :: Int + } deriving Show + +conjectures :: [Result a] -> [Conjecture] +conjectures = concatMap conjectures1 + . sortOn (abs . (50-) . score) -- closer to 50 the better! + . reduceImplications + . filterNonCanon + . reverse + +conjectures1 :: Result a -> [Conjecture] +conjectures1 r = [ p `eq` p' | p' <- ps ] + ++ [ p `im` i | (not.null) i ] + where + (p:ps) = sets r + i = implied r + eq = conj True + im = conj False + conj isE p p' = Conjecture + { isEq = isE + , isIm = not isE + , cleft = p + , cright = p' + , cscore = score r + , cnKilled = nKilled r + , cnSurvivors = nSurvivors r + } +-- TODO: improve implication score +-- implication score can be improved by +-- by separating each implication on its own: +-- [4] ==> [2,3] +-- become +-- [4] ==> [2] +-- [4] ==> [3] +-- Then evaluating percentage of occurences of True ==> True and other cases diff --git a/src/Test/FitSpec/Main.hs b/src/Test/FitSpec/Main.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/Main.hs @@ -0,0 +1,69 @@ +-- | Exports "main" functions for FitSpec. +-- They work exactly by 'report' and 'reportWith' but can be customized by +-- command line arguments. +-- +-- > main = mainWith args { ... } functions properties +{-# Language DeriveDataTypeable, StandaloneDeriving #-} +module Test.FitSpec.Main + ( mainWith + , defaultMain + , getArgs + , getArgsWith + , module Test.FitSpec.Report -- deprecated export, remove later + ) +where + +import Test.FitSpec.Report +import System.Console.CmdArgs hiding (args) +import qualified System.Console.CmdArgs as CA (args) +import Control.Monad (liftM) +import Test.FitSpec.Mutable +import Test.FitSpec.ShowMutable + +deriving instance Data ShowMutantAs +deriving instance Data Args +deriving instance Typeable ShowMutantAs +deriving instance Typeable Args + +annotate :: Args -> Args +annotate as = Args + { nMutants = nMutants as &= name "m" + &= help "(starting) number of function mutations" + , nTests = nTests as &= name "n" + &= help "(starting) number of test values (each prop.)" + , timeout = timeout as &= name "t" &= name "s" + &= help "timeout in seconds, 0 for just T*M" + , names = names as + &= ignore + , rows = rows as + &= help "how many rows of results to show" + , verbose = verbose as + &= help "activate verbose output" + , showMutantAs = showMutantAs as &= name "a" + &= help "how to show mutants (tuple / nestedtuple / definition / bindings)" + &= typ "type" + , extra = extra as &= CA.args + &= typ "extra arguments" + } &= summary "FitSpec" + &= program "program" + &= help "Refine property-sets for functional testing" + +getArgsWith :: Args -> IO Args +getArgsWith = cmdArgs . annotate + +getArgs :: IO Args +getArgs = getArgsWith args + +-- | Same as 'reportWith', but allow overriding of configuration via command +-- line arguments. +mainWith :: (Mutable a, ShowMutable a) + => Args + -> a -> (a -> [Property]) -> IO () +mainWith as f ps = do + as' <- getArgsWith as + reportWith as' f ps + +-- | Same as 'report', but allow configuration via command line arguments. +defaultMain :: (Mutable a, ShowMutable a) + => a -> (a -> [Property]) -> IO () +defaultMain = mainWith args diff --git a/src/Test/FitSpec/Mutable.hs b/src/Test/FitSpec/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/Mutable.hs @@ -0,0 +1,186 @@ +-- | Enumeration of function mutations +module Test.FitSpec.Mutable + ( Mutable (..) + , mutiersEq +--, mutantsIntegral + ) +where + +import Test.LeanCheck +import Data.List (intercalate, delete) +import Data.Maybe +import Test.LeanCheck.Error (errorToNothing) + +-- | This typeclass is similar to 'Listable'. +-- +-- A type is 'Mutable' when there exists a function that +-- is able to list mutations of a value. +-- Ideally: list all possible values without repetitions. +-- +-- Instances are usually defined by a 'mutiers' function that +-- given a value, returns tiers of mutants of that value: +-- the first tier contains the equivalent mutant, of size 0, +-- the second tier contains mutants of size 1, +-- the third tier contains mutants of size 2, +-- and so on. +-- +-- The equivalent mutant is the actual function without mutations. +-- +-- The size of a mutant is given by the sum of: +-- the number of mutated points (relations) and +-- the sizes of mutated arguments and results. +-- +-- To get only inequivalent mutants, +-- just take the 'tail' of either 'mutants' or 'mutiers': +-- +-- > tail mutants +-- +-- > tail mutiers +-- +-- Given that the underlying 'Listable' enumeration has no repetitions +-- parametric instances defined in this file will have no repeated mutants. +class Mutable a where + mutiers :: a -> [[a]] + mutants :: a -> [a] + mutiers = map (:[]) . mutants + mutants = concat . mutiers + {-# MINIMAL mutants | mutiers #-} + + +-- *** *** Instances for (non-functional) data types *** *** + +-- | Implementation of 'mutiers' for non-functional data types. +-- Use this to create instances for user-defined data types, e.g.: +-- +-- > instance MyData +-- > where mutiers = mutiersEq +-- +-- and for parametric datatypes: +-- +-- > instance (Eq a, Eq b) => MyDt a b +-- > where mutiers = mutiersEq +-- +-- Examples: +-- +-- > mutiersEq True = [[True], [False]] +-- > mutiersEq 2 = [[2], [0], [1], [], [3], [4], [5], [6], [7], [8], [9], ...] +-- > mutiersEq [1] = [[[1]], [[]], [[0]], [[0,0]], [[0,0,0],[0,1],[1,0],[-1]], ...] +mutiersEq :: (Listable a, Eq a) => a -> [[a]] +mutiersEq x = [x] : deleteT x tiers + +-- | > mutants () = [()] +instance Mutable () where mutiers = mutiersEq + +-- | > mutants 3 = [3,0,1,2,4,5,6,7,8,9,... +instance Mutable Int where mutiers = mutiersEq + +instance Mutable Char where mutiers = mutiersEq + +-- | > mutants True = [True,False] +instance Mutable Bool where mutiers = mutiersEq -- > mutants True=[True,False] + +-- | > mutants [0] = [ [0], [], [0,0], [1], ... +instance (Eq a, Listable a) => Mutable [a] where mutiers = mutiersEq + +-- | > mutants (Just 0) = [Just 0, Nothing, ... +instance (Eq a, Listable a) => Mutable (Maybe a) where mutiers = mutiersEq + +{- Alternative implementations for Mutable Ints and Lists. +-- These do not improve results significantly. +-- That is why I have kept the simpler mutations above. + +-- |- Generate mutants of an Integral value. +-- Alternates between successors and predecessors of the original number. +-- The enumeration starts "towards" zero. +mutantsIntegral :: Integral a => a -> [a] +mutantsIntegral i | i > 0 = [i..] +| tail [i,(i-1)..] + | otherwise = [i,(i-1)..] +| tail [i..] +-- NOTE: tail is there to avoid generating out of bound values +-- as (i-1) is usually safe while (i-2) is not. + +instance Mutable Int where mutants = mutantsIntegral + +instance (Listable a, Mutable a) => Mutable [a] + where mutiers [] = [ [] ] + : [ ] + : tail tiers + mutiers (x:xs) = [ (x:xs) ] + : [ [] ] + : tail (lsProductWith (:) (mutiers x) (mutiers xs)) +-- -} + + +-- *** *** Instances for functional types *** *** + +-- | Mutate a function at a single point. +-- The following two declarations are equivalent: +-- +-- > id' = id `mut` (0,1) +-- +-- > id' 0 = 1 +-- > id' x = x +mut :: Eq a => (a -> b) -> (a,b) -> (a -> b) +mut f (x',fx') = \x -> if x == x' + then fx' + else f x + +-- | Mutate a function at several points. +-- +-- > f `mutate` [(x,a),(y,b),(z,c)] = f `mut` (x,a) `mut` (y,b) `mut` (z,c) +mutate :: Eq a => (a -> b) -> [(a,b)] -> (a -> b) +mutate f ms = foldr (flip mut) f ms -- or: foldl mut f ms + +-- | Return tiers of possible mutations for a single point of a function. +-- If the function is undefined at that point, no mutations are provided. +-- This function does not return the null mutant. +-- +-- > (+1) `mutationsFor` 1 = [ [(1,0)], [(1,1)], [], [(1,3)], [(1,4)], ... +mutationsFor :: Mutable b => (a->b) -> a -> [[(a,b)]] +mutationsFor f x = case errorToNothing (f x) of + Nothing -> [] + Just fx -> ((,) x) `mapT` tail (mutiers fx) + +-- | Returns tiers of mutants on a selection of arguments of a function. +-- Will only return the null mutant from an empty selection of arguments. +tiersMutantsOn :: (Eq a, Mutable b) => (a->b) -> [a] -> [[a->b]] +tiersMutantsOn f xs = mutate f `mapT` products (map (mutationsFor f) xs) + +-- | +-- > mutants not = +-- > [ not +-- > , \p -> case p of False -> False; _ -> not p +-- > , \p -> case p of True -> True; _ -> not p +-- > , \p -> case p of False -> False; True -> True +-- > ] +instance (Eq a, Listable a, Mutable b) => Mutable (a -> b) where + mutiers f = tiersMutantsOn f `concatMapT` setsOf tiers + + +-- *** *** Instances for tuples *** *** + +-- | > mutants (0,1) = [(0,1),(0,0),(1,1),(0,-1),...] +instance (Mutable a, Mutable b) => Mutable (a,b) where + mutiers (f,g) = mutiers f >< mutiers g + +instance (Mutable a, Mutable b, Mutable c) => Mutable (a,b,c) where + mutiers (f,g,h) = productWith (\f' (g',h') -> (f',g',h')) + (mutiers f) (mutiers (g,h)) + +instance (Mutable a, Mutable b, Mutable c, Mutable d) + => Mutable (a,b,c,d) where + mutiers (f,g,h,i) = productWith (\f' (g',h',i') -> (f',g',h',i')) + (mutiers f) (mutiers (g,h,i)) + +instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e) + => Mutable (a,b,c,d,e) where + mutiers (f,g,h,i,j) = productWith (\f' (g',h',i',j') -> (f',g',h',i',j')) + (mutiers f) (mutiers (g,h,i,j)) + +-- | For Mutable tuple instances greater than sixtuples, see +-- "FitSpec.Mutable.Tuples". Despite being hidden in this Haddock +-- documentation, 7-tuples up to 12-tuples are exported by "Test.FitSpec". +instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, Mutable f) + => Mutable (a,b,c,d,e,f) where + mutiers (f,g,h,i,j,k) = productWith (\f' (g',h',i',j',k') -> + (f',g',h',i',j',k')) + (mutiers f) (mutiers (g,h,i,j,k)) diff --git a/src/Test/FitSpec/Mutable/Tuples.hs b/src/Test/FitSpec/Mutable/Tuples.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/Mutable/Tuples.hs @@ -0,0 +1,62 @@ +-- | Mutable instances: septuples up to 12-tuples +-- +-- This is part of a Hack that allows those instances to be hidden from Haddock. +-- Otherwise Haddock documentation will look very ugly. +module Test.FitSpec.Mutable.Tuples () where + +import Test.FitSpec.Mutable +import Test.LeanCheck (productWith) + +instance (Mutable a, Mutable b, Mutable c, Mutable d, + Mutable e, Mutable f, Mutable g) + => Mutable (a,b,c,d,e,f,g) where + mutiers (f,g,h,i,j,k,l) = productWith (\f' (g',h',i',j',k',l') -> + (f',g',h',i',j',k',l')) + (mutiers f) + (mutiers (g,h,i,j,k,l)) + +instance (Mutable a, Mutable b, Mutable c, Mutable d, + Mutable e, Mutable f, Mutable g, Mutable h) + => Mutable (a,b,c,d,e,f,g,h) where + mutiers (f,g,h,i,j,k,l,m) = productWith (\f' (g',h',i',j',k',l',m') -> + (f',g',h',i',j',k',l',m')) + (mutiers f) + (mutiers (g,h,i,j,k,l,m)) + +instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, + Mutable f, Mutable g, Mutable h, Mutable i) + => Mutable (a,b,c,d,e,f,g,h,i) where + mutiers (f,g,h,i,j,k,l,m,n) = + productWith (\f' (g',h',i',j',k',l',m',n') -> + (f',g',h',i',j',k',l',m',n')) + (mutiers f) + (mutiers (g,h,i,j,k,l,m,n)) + +instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, + Mutable f, Mutable g, Mutable h, Mutable i, Mutable j) + => Mutable (a,b,c,d,e,f,g,h,i,j) where + mutiers (f,g,h,i,j,k,l,m,n,o) = + productWith (\f' (g',h',i',j',k',l',m',n',o') -> + (f',g',h',i',j',k',l',m',n',o')) + (mutiers f) + (mutiers (g,h,i,j,k,l,m,n,o)) + +instance (Mutable a, Mutable b, Mutable c, Mutable d, + Mutable e, Mutable f, Mutable g, Mutable h, + Mutable i, Mutable j, Mutable k) + => Mutable (a,b,c,d,e,f,g,h,i,j,k) where + mutiers (f,g,h,i,j,k,l,m,n,o,p) = + productWith (\f' (g',h',i',j',k',l',m',n',o',p') -> + (f',g',h',i',j',k',l',m',n',o',p')) + (mutiers f) + (mutiers (g,h,i,j,k,l,m,n,o,p)) + +instance (Mutable a, Mutable b, Mutable c, Mutable d, + Mutable e, Mutable f, Mutable g, Mutable h, + Mutable i, Mutable j, Mutable k, Mutable l) + => Mutable (a,b,c,d,e,f,g,h,i,j,k,l) where + mutiers (f,g,h,i,j,k,l,m,n,o,p,q) = + productWith (\f' (g',h',i',j',k',l',m',n',o',p',q') -> + (f',g',h',i',j',k',l',m',n',o',p',q')) + (mutiers f) + (mutiers (g,h,i,j,k,l,m,n,o,p,q)) diff --git a/src/Test/FitSpec/PrettyPrint.hs b/src/Test/FitSpec/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/PrettyPrint.hs @@ -0,0 +1,141 @@ +-- | Poor man's pretty printing library +-- +-- This module has somewhat inefficient implementations that could be improved +-- in the future. i.e.: heavy use of '(++)'. +module Test.FitSpec.PrettyPrint + ( beside + , above + , showTuple + , table + , columns + , showQuantity + , showEach + , headToUpper + ) +where + +import Data.List (intercalate,transpose,isSuffixOf) +import Data.Char (toUpper) + +showQuantity :: Int -> String -> String +showQuantity 1 what = "1 " ++ what +showQuantity n what = show n ++ " " ++ pluralize what + +showEach :: Show a => String -> [a] -> String +showEach what [x] = what ++ " " ++ show x +showEach what xs = "each of " ++ pluralize what ++ " " + ++ intercalate ", " (map show $ init xs) + ++ " and " + ++ show (last xs) + +-- | Pluralizes a word. +-- Is not comprehensive (and may never be), +-- add missing cases as they are found. +-- +-- > pluralize "test case" == "test cases" +-- > pluralize "property" == "properties" +pluralize :: String -> String +pluralize s | s `ew` "se" = s ++ "s" + | s `ew` "n" = s ++ "s" + | s `ew` "y" = init s ++ "ies" + | otherwise = s + where ew = flip isSuffixOf + + +-- | Appends two Strings side by side, line by line +-- +-- > beside ["asdf\nqw\n","zxvc\nas"] == +-- > "asdfzxvc\n\ +-- > \qw as\n" +beside :: String -> String -> String +beside cs ds = unlines $ zipWith (++) (normalize ' ' css) dss + where [css,dss] = normalize "" [lines cs,lines ds] + +-- | Append two Strings on top of each other, adding line breaks *when needed*. +above :: String -> String -> String +above cs ds = if last cs == '\n' || head ds == '\n' + then cs ++ ds + else cs ++ '\n':ds + +-- | Show elements of a list as a tuple. If there are multiple lines in any of +-- the strings, tuple is printed multiline. +-- +-- > showTuple ["asdf\nqwer\n","zxvc\nasdf\n"] == +-- > "( asdf\n\ +-- > \ qwer\n\ +-- > \, zxvc\n\ +-- > \ asdf )\n" +-- +-- > showTuple ["asdf","qwer"] == "(asdf,qwer)" +showTuple :: [String] -> String +showTuple [] = "" +showTuple [s] = s +showTuple (s:ss) = + if any ('\n' `elem`) (s:ss) + then "( " `beside` s + ++ init (concatMap (", " `beside`) ss) + ++ " )\n" + else "(" ++ intercalate "," (s:ss) ++ ")" + +-- | Formats a table using a given separator. +-- +-- > table " " [ ["asdf", "qwer", "zxvc\nzxvc"] +-- > , ["0", "1", "2"] +-- > , ["123", "456\n789", "3"] ] == +-- > "asdf qwer zxvc\n\ +-- > \ zxvc\n\ +-- > \0 1 2\n\ +-- > \123 456 3\n\ +-- > \ 789\n\" +table :: String -> [[String]] -> String +table s [] = "" +table s sss = unlines + . map (removeTrailing ' ') + . map (intercalate s) + . transpose + . map (normalize ' ') + . foldr1 (zipWith (++)) + . map (normalize "" . map lines) + . normalize "" + $ sss + +-- | Given a separator, format strings in columns +-- +-- > columns " | " ["asdf", "qw\nzxcv", "as\ndf"] == +-- > "asdf | qw | as\n\ +-- > \ | zxcv | df\n" +columns :: String -> [String] -> String +columns s = unlines + . map (removeTrailing ' ') + . map (intercalate s) + . transpose + . map (normalize ' ') + . normalize "" + . map lines + +-- | Fits a list to a certain width by appending a certain value +-- +-- > fit ' ' 6 "str" == "str " +-- +-- > fit 0 6 [1,2,3] == [1,2,3,0,0,0] +fit :: a -> Int -> [a] -> [a] +fit x n xs = xs ++ replicate (n - length xs) x + +-- | normalize makes all list the same length by adding a value +-- +-- > normalize ["asdf","qw","er"] == normalize ["asdf","qw ","er "] +normalize :: a -> [[a]] -> [[a]] +normalize x xs = map (x `fit` maxLength xs) xs + +-- | Given a list of lists returns the maximum length +maxLength :: [[a]] -> Int +maxLength = maximum . (0:) . map length + +removeTrailing :: Eq a => a -> [a] -> [a] +removeTrailing x = reverse + . dropWhile (==x) + . reverse + +headToUpper :: [Char] -> [Char] +headToUpper [] = [] +headToUpper (c:cs) = toUpper c : cs diff --git a/src/Test/FitSpec/Report.hs b/src/Test/FitSpec/Report.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/Report.hs @@ -0,0 +1,246 @@ +module Test.FitSpec.Report + ( report + , reportWith + , reportWithExtra + , Args(..) + , args + , fixargs + , Property + , ShowMutantAs(..) + ) +where + +import Data.List (intercalate, intersperse) +import Data.Maybe (fromMaybe) + +import Test.FitSpec.Engine +import Test.FitSpec.Mutable +import Test.FitSpec.ShowMutable +import Test.FitSpec.Utils +import Test.FitSpec.PrettyPrint + +-- | How to show mutants. Use this to fill 'showMutantAs'. +data ShowMutantAs = Tuple | NestedTuple + | Definition | Bindings + +-- | Extra arguments / configuration for 'reportWith'. +-- See 'args' for default values. +data Args = Args + { nMutants :: Int -- ^ (starting) number of function mutations + , nTests :: Int -- ^ (starting) number of test values (for each prop.) + , timeout :: Int -- ^ timeout in seconds, 0 for just 'nTests' * 'nMutants' + , names :: [String] -- ^ names of functions: @["foo x y","goo x y"]@ + + -- advanced options: + , verbose :: Bool -- ^ whether to show detailed results + , showMutantAs :: ShowMutantAs -- ^ how to show mutants + , rows :: Maybe Int -- ^ number of surviving mutants to show + , extra :: [String] -- ^ ignored argument (user defined meaning) + } + +-- | Default arguments for 'reportWith': +-- +-- * @nMutants = 500@, start with 500 mutants +-- +-- * @nTests = 1000@, start with 1000 test values +-- +-- * @timeout = 5@, keep incresing the number of mutants +-- until 5 seconds elapse +-- +-- * @names = []@, default function call template: +-- +-- > ["f x y z", "g x y z", "h x y z", ...] +args :: Args +args = Args { nMutants = 500 + , nTests = 1000 + , timeout = 5 -- seconds + , names = [] + , verbose = False + , showMutantAs = Tuple + , rows = Nothing + , extra = [] + } + +-- | Non timed-out default arguments. +-- Make conjectures based on a fixed number of mutants and tests, e.g.: +-- +-- > reportWith (fixargs 100 200) f pmap +-- +-- This is just a shorthand, see: +-- +-- > fixargs nm nt = args { nMutants = nm, nTests = nt, timeout = 0 } +-- +-- > (fixargs nm nt) { nMutants = 500, nTests = 1000, timeout = 5 } = args +fixargs :: Int -> Int -> Args +fixargs nm nt = args + { nMutants = nm + , nTests = nt + , timeout = 0 + } + +showMutant :: ShowMutable a => Args -> a -> a -> String +showMutant as = showMutantByType (showMutantAs as) (names as) + where + showMutantByType Tuple = showMutantAsTuple + showMutantByType NestedTuple = showMutantNested + showMutantByType Definition = showMutantDefinition + showMutantByType Bindings = showMutantBindings + +-- | Report results generated by FitSpec. +-- Uses standard configuration (see 'args'). +-- Needs a function to be mutated and a property map. +-- Example (specification of boolean negation): +-- +-- > properties not = +-- > [ property $ \p -> not (not p) == p +-- > , property $ \p -> not (not (not p)) == not p +-- > ] +-- > +-- > main = report not properties +report :: (Mutable a, ShowMutable a) + => a -> (a -> [Property]) -> IO () +report = reportWith args + + +-- | Same as 'report' but can be configured via 'Args' ('args' or 'fixargs'), +-- e.g.: +-- +-- > reportWith args { timeout = 10 } fun properties +reportWith :: (Mutable a, ShowMutable a) + => Args -> a -> (a -> [Property]) -> IO () +reportWith = reportWithExtra [] + + +-- | Same as 'reportWith', but accepts a list of manually defined (extra) +-- mutants to be tested alongside those automatically generated. +reportWithExtra :: (Mutable a, ShowMutable a) + => [a] -> Args -> a -> (a -> [Property]) -> IO () +reportWithExtra extraMutants args f properties = do + let nm = nMutants args + nt = nTests args + case propertiesCE nt (properties f) of + Nothing -> reportWithExtra' extraMutants args f properties + Just ce -> do + putStrLn $ "ERROR: The original function-set does not follow property set for " + ++ show nt ++ " tests" + putStrLn $ "Counter-example to property " ++ ce + putStrLn $ "Aborting." + +-- | Same as 'reportWithExtra', does not abort if the original function does not +-- follow the property set. +reportWithExtra' :: (Mutable a, ShowMutable a) + => [a] -> Args -> a -> (a -> [Property]) -> IO () +reportWithExtra' extraMutants args f properties = do + results <- getResultsExtraTimeout (timeout args) + extraMutants + f properties + (nMutants args) (nTests args) + + let nm = totalMutants $ head results + nt = maxTests $ head results + nts = propertiesNTests nt (properties f) + tex = and $ propertiesTestsExhausted nt (properties f) + mex = mutantsExhausted $ head results + apparent | tex && mex = "" + | otherwise = "apparent " + putStrLn . headToUpper $ apparent ++ qualifyCM results ++ " specification based on" + putStrLn $ showNumberOfTestsAndMutants tex mex nts nm False + + let showR | verbose args = showDetailedResults + | otherwise = showResults + putStrLn $ showR (rows args) (showMutant args f) results + + +showResults :: Maybe Int -> (a -> String) + -> [Result a] -> String +showResults mlimit showMutant rs@(r:_) = completeness + ++ "\n" ++ minimality + where + showMutants ms = init . unlines $ map showMutant ms + completeness = show (nSurvivors r) ++ " survivors (" + ++ show (score r) ++ "% killed)" + ++ case take (fromMaybe 1 mlimit) $ survivors r of + [] -> ".\n" + [m] -> ", smallest:\n" + ++ " " `beside` showMutant m + ms -> ", " ++ show (length ms) ++ " smallest:\n" + ++ " " `beside` showMutants ms + minimality = "apparent minimal property subsets: " + ++ (unwords . map showPropertySet $ sets r) ++ "\n" + ++ case showConjectures False rs of + "" -> "No conjectures.\n" + cs -> "conjectures: " `beside` cs + + +showDetailedResults :: Maybe Int -> (a -> String) + -> [Result a] -> String +showDetailedResults mlimit showMutant rs = completeness + ++ "\n" ++ minimality + where + completeness = table " " . intersperse ["\n"] + . ([ "Property\n sets" + , "#Survivors\n (%Killed)" + , "Smallest or simplest\n surviving mutant" + ]:) + . map showResult + . maybe id take mlimit + $ rs + showResult r = [ unwords . map showPropertySet $ sets r + , show (nSurvivors r) ++ " (" ++ show (score r) ++ "%)" + , maybe "" showMutant $ smallestSurvivor r + ] + minimality = case showConjectures True rs of + "" -> "No conjectures.\n" + cs -> "Conjectures:\n" ++ cs + + +showNumberOfTestsAndMutants :: Bool -> Bool -> [Int] -> Int -> Bool -> String +showNumberOfTestsAndMutants tex mex nts nm ssum = numTests ++ numMutants + where + mexS | mex = " (exhausted)" + | otherwise = "" + numMutants = "for each of " ++ showQuantity nm "mutant variation" ++ mexS ++ ".\n" + numTests | ssum = showQuantity (sum nts) "test case" + ++ (if tex then " (exhausted)" else "") + ++ "\n" + | otherwise = unlines + . (++ ["(test cases exhausted)" | tex]) + . sortGroupAndCollapse fst snd testsForProps + $ zip nts [1..] + testsForProps n ps = showQuantity n "test case" + ++ " for " ++ showEach "property" ps + +showPropertySet :: Show i => [i] -> String +showPropertySet = (\s -> "{" ++ s ++ "}") . intercalate "," . map show + + +-- | Show conjectures derived from results +showConjectures :: Bool -> [Result a] -> String +showConjectures showVeryWeak = table " " + . map showConjecture + . filter (\r -> showVeryWeak + || cnKilled r /= 0 + && cnSurvivors r /= 0) + . conjectures + +showConjecture :: Conjecture -> [String] +showConjecture Conjecture {isEq=eq, cleft=l, cright=r, cscore=s} = + [ showPropertySet l + , if eq then " = " else "==>" + , showPropertySet r + , " " + , show s ++ "% killed" + , sMeaning + ] + where sMeaning | s < 1 || 99 < s = "(very weak)" + | s < 11 || 89 < s = "(weak)" + | s < 33 || 67 < s = "(mild)" + | otherwise = "(strong)" -- the closer to 50 the better + +qualifyCM :: Results a -> String +qualifyCM rs | c && m = "complete and minimal" + | c = "complete but non-minimal" + | m = "minimal but incomplete" + | otherwise = "incomplete and non-minimal" + where c = complete rs + m = minimal rs diff --git a/src/Test/FitSpec/ShowMutable.hs b/src/Test/FitSpec/ShowMutable.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/ShowMutable.hs @@ -0,0 +1,362 @@ +-- | Show mutant variations +module Test.FitSpec.ShowMutable + ( ShowMutable (..) + , mutantSEq + , showMutantAsTuple + , showMutantNested + , showMutantDefinition + , showMutantBindings + , MutantS () + , mutantSTuple + ) +where + +import Test.FitSpec.PrettyPrint +import Test.LeanCheck.Error (errorToNothing, Listable(..)) +import Data.Maybe (mapMaybe,isNothing) +import Control.Monad (join) +import Data.List (intercalate,tails) +import Data.Char (isLetter) + + +-- | Show a Mutant as a tuple of lambdas. +-- +-- > > putStrLn $ showMutantAsTuple ["p && q","not p"] ((&&),not) ((||),id) +-- > ( \p q -> case (p,q) of +-- > (False,False) -> True +-- > _ -> p && q +-- >, \p -> case p of +-- > False -> False +-- > True -> True +-- > _ -> not p ) +-- +-- Can be easily copy pasted into an interactive session for manipulation. +-- On GHCi, use @:{@ and @:}@ to allow multi-line expressions and definitions. +showMutantAsTuple :: ShowMutable a => [String] -> a -> a -> String +showMutantAsTuple names f f' = showMutantSAsTuple names + $ flatten + $ mutantS f f' + +-- | Show a Mutant as the list of bindings that differ from the original +-- function(s). +-- +-- > > putStrLn $ showMutantBindings ["p && q","not p"] ((&&),not) ((==),id) +-- > False && False = True +-- > not False = False +-- > not True = True +-- +-- Can possibly be copied into the source of the original function for +-- manipulation. +showMutantBindings :: ShowMutable a => [String] -> a -> a -> String +showMutantBindings names f f' = showMutantSBindings False names + $ flatten + $ mutantS f f' + +-- | Show a Mutant as a new complete top-level definition, with a prime +-- appended to the name of the mutant. +-- +-- > > putStrLn $ showMutantDefinition ["p && q","not p"] ((&&),not) ((==),id) +-- > False &&- False = True +-- > p &&- q = p && q +-- > not' False = False +-- > not' True = True +-- > not' p = not p +showMutantDefinition :: ShowMutable a => [String] -> a -> a -> String +showMutantDefinition names f f' = showMutantSBindings True names + $ flatten + $ mutantS f f' + +-- | Show a Mutant as a tuple of nested lambdas. +-- Very similar to 'showMutantAsTuple', but the underlying data structure is +-- not flatten: so the output is as close as possible to the underlying +-- representation. +showMutantNested :: ShowMutable a => [String] -> a -> a -> String +showMutantNested names f f' = showMutantSAsTuple names + $ mutantS f f' + +-- | Show a Mutant without providing a default name. +-- An alias for @showMutantAsTuple []@. +showMutant :: ShowMutable a => a -> a -> String +showMutant = showMutantAsTuple [] + + +-- | Default function names (when none given): +-- +-- > f g h f' g' h' f'' g'' h'' +defaultFunctionNames :: [String] +defaultFunctionNames = ["f","g","h"] ++ map (++"'") defaultFunctionNames + +-- | Default names in a call (function and variables): +-- +-- > f x y z w x' y' z' w' x'' y'' z'' w'' ... +defaultNames :: [String] +defaultNames = head defaultFunctionNames : defVarNames + where defVarNames = ["x","y","z","w"] ++ map (++"'") defVarNames + + +-- | Types that can have their mutation shown. +-- Has only one function 'mutantS' that returns a simple AST ('MutantS') +-- representing the mutant. A standard implementation of 'mutantS' for 'Eq' +-- types is given by 'mutantSEq'. +class ShowMutable a where + mutantS :: a -> a -> MutantS + +-- | For a given type @Type@ instance of @Eq@ and @Show@, +-- define the 'ShowMutable' instance as: +-- +-- > instance ShowMutable Type +-- > where mutantS = mutantSEq +mutantSEq :: (Eq a, Show a) + => a -> a -> MutantS +mutantSEq x x' = if x == x' + then Unmutated $ show x + else Atom $ show x' + +instance ShowMutable () where mutantS = mutantSEq +instance ShowMutable Int where mutantS = mutantSEq +instance ShowMutable Char where mutantS = mutantSEq +instance ShowMutable Bool where mutantS = mutantSEq +instance (Eq a, Show a) => ShowMutable [a] where mutantS = mutantSEq +instance (Eq a, Show a) => ShowMutable (Maybe a) where mutantS = mutantSEq + +instance (Listable a, Show a, ShowMutable b) => ShowMutable (a->b) where + -- TODO: let the user provide how many values should be tried when printing + mutantS f f' = Function + . take 10 + . filter (not . isUnmutated . snd) + . mapMaybe bindingFor + . take 200 + $ list + where bindingFor x = fmap ((,) [show x]) + $ errorToNothing (mutantS (f x) (f' x)) + +instance (ShowMutable a, ShowMutable b) => ShowMutable (a,b) where + mutantS (f,g) (f',g') = Tuple [ mutantS f f' + , mutantS g g' ] + +instance (ShowMutable a, ShowMutable b, ShowMutable c) + => ShowMutable (a,b,c) where + mutantS (f,g,h) (f',g',h') = Tuple [ mutantS f f' + , mutantS g g' + , mutantS h h' ] + + +-- | (Show) Structure of a mutant. +-- This format is intended for processing then pretty-printing. +data MutantS = Unmutated String + | Atom String + | Tuple [MutantS] + | Function [([String],MutantS)] + deriving Show + +-- | Check if a 'MutantS' is null +isUnmutated :: MutantS -> Bool +isUnmutated (Unmutated _) = True +isUnmutated (Tuple ms) = all isUnmutated ms +isUnmutated (Function bs) = all (isUnmutated . snd) bs +isUnmutated _ = False + +-- | Check if a 'MutantS' is a function. +isFunction :: MutantS -> Bool +isFunction (Function _) = True +isFunction _ = False + +-- | Flatten a MutantS by merging nested 'Function's. +flatten :: MutantS -> MutantS +flatten (Tuple ms) = Tuple $ map flatten ms +flatten (Function [([],s)]) = flatten s +flatten (Function (([],s):_)) = error "flatten: ambiguous value" +flatten (Function bs) = let bs' = map (mapSnd flatten) bs in + if any (not . isFunction . snd) bs' + then Function bs' + else Function + $ take 10 + $ concatMap (\(as,Function bs'') -> map (mapFst (as++)) bs'') bs' +flatten m = m + + +-- | Show a nameless mutant. +-- Functions should not (but can) be shown using this. +showMutantS :: MutantS -> String +showMutantS (Unmutated s) = s +showMutantS (Atom s) = s +showMutantS (Tuple ms) = showTuple $ map showMutantS ms +showMutantS (Function bs) = showLambda ["??"] bs + +-- | Show top-level (maybe tuple) named 'MutantS' as a tuple. +showMutantSAsTuple :: [String] -> MutantS -> String +showMutantSAsTuple ns (Tuple ms) = showTuple $ zipWith show1 (ns +- defaultFunctionNames) ms + where show1 n (Unmutated _) = n + show1 n (Function bs) = showLambda (fvnames n) bs + show1 _ m = showMutantS m +showMutantSAsTuple ns m = showMutantSAsTuple ns (Tuple [m]) + +-- | Show top-level (maybe tuple) named 'MutantS' as a bindings. +-- In general, you want to 'flatten' the 'MutantS' before applying this +-- function. +showMutantSBindings :: Bool -> [String] -> MutantS -> String +showMutantSBindings new ns (Tuple ms) = concatMap (uncurry show1) + $ zip (ns ++ defaultFunctionNames) ms + where show1 _ (Unmutated s) = "" + show1 _ (Function []) = "" + show1 n (Function bs) = showBindings new (fvnames n) bs + show1 n m = let fn = head $ fvnames n + fn' | new = prime fn + | otherwise = fn + in (apply fn' [] ++ " = ") + `beside` showMutantS m +showMutantSBindings new ns m = showMutantSBindings new ns (Tuple [m]) + + +-- | Given a list with the function and variable names and a list of bindings, +-- show a function as a case expression enclosed in a lambda. +showLambda :: [String] -> [([String],MutantS)] -> String +showLambda [] [] = "undefined {- (err?) unmutated -}" +showLambda (n:_) [] = apply n [] +showLambda _ [([],m)] = showMutantS m +showLambda _ (([],_):_) = "undefined {- (err?) ambiguous value -}" +showLambda ns bs = (("\\" ++ unwords bound ++ " -> ") `beside`) + $ "case " ++ showTuple bound ++ " of\n" + ++ " " `beside` cases + where + cases = concatMap (\(as,r) -> (showTuple as ++ " -> ") `beside` showResult r) bs + ++ "_ -> " ++ apply fn bound + showResult (Function bs') = showLambda (apply fn bound:unbound) bs' + showResult m = showMutantS m + unbound = drop (length bound) vns + bound = zipWith const vns (fst $ head bs) + (fn:vns) = ns +- defaultNames + +-- | Given a list with the function and variable names and a list of bindings, +-- show function binding declarations. +-- +-- The 'new' boolean argument indicates whether if the function should be shown +-- as a new definition. +showBindings :: Bool -> [String] -> [([String],MutantS)] -> String +showBindings new ns bs = + table " " $ (uncurry showBind `map` bs) + ++ [words (apply fn' bound) ++ ["=", apply fn bound] | new] + where + showBind [a1,a2] r | isInfix fn' = [a1, fn', a2, "=", showMutantS r] + showBind as r = [fn'] ++ as ++ ["=", showMutantS r] + fn' | new = prime fn + | otherwise = fn + bound = zipWith const vns (fst $ head bs) + (fn:vns) = ns +- defaultNames + + +-- | Separate function from variable names in a simple Haskell expr. +-- +-- > fvarnames "f x y" == ["f","x","y"] +-- > fvarnames "aa bb cc dd" == ["aa","bb","cc","dd"] +-- +-- When there are three lexemes, the function checks for a potential infix +-- operator in the middle. +-- +-- > fvarnames "x + y" == ["(+)","x","y"] +-- +-- This function always returns a "head" +-- +-- > fvarnames "" == ["f"] +fvnames :: String -> [String] +fvnames = fvns' . words + where fvns' :: [String] -> [String] + fvns' [a,o,b] | isInfix o = o:[a,b] + fvns' [] = defaultNames + fvns' fvs = fvs + +-- | Apply a function ('String') to a list of variables ('[String]'). +-- +-- For the sake of clarity, in the following examples, double-quotes are omitted: +-- > apply f == f +-- > apply f x == f x +-- > apply f x y == f x y +-- > apply (+) == (+) +-- > apply (+) x == (+) x +-- > apply (+) x y == (+) x y +-- > apply + == (+) +-- > apply + x == (+) x +-- > apply + x y == (x + y) +-- > apply + x y z == (+) x y z +apply :: String -> [String] -> String +apply f [x,y] | isInfix f = unwords [x,f,y] +apply f xs = if isInfix f + then unwords (toPrefix f:xs) + else unwords (f:xs) + +-- | Check if a function / operator is infix +-- +-- > isInfix "foo" == False +-- > isInfix "(+)" == False +-- > isInfix "`foo`" == True +-- > isInfix "+" == True +isInfix :: String -> Bool +isInfix (c:cs) = c /= '(' && not (isLetter c) + +-- | Transform an infix operator into an infix function: +-- +-- > toPrefix "`foo`" == "foo" +-- > toPrefix "+" == "(+)" +toPrefix :: String -> String +toPrefix ('`':cs) = init cs +toPrefix cs = '(':cs ++ ")" + +-- Primeify the name of a function by appending prime @'@ to functions and +-- minus @-@ to operators. +-- +-- > prime "(+)" == "(+-)" +-- > prime "foo" == "foo'" +-- > prime "`foo`" == "`foo'`" +-- > prime "*" == "*- +prime :: String -> String +prime ('`':cs) = '`':init cs ++ "'`" -- `foo` to `foo'` +prime ('(':cs) = '(':init cs ++ "-)" -- (+) to (+-) +prime cs | isInfix cs = cs ++ "-" -- + to +- + | otherwise = cs ++ "'" -- foo to foo' + + +mapFst :: (a->b) -> (a,c) -> (b,c) +mapFst f (x,y) = (f x,y) + +mapSnd :: (a->b) -> (c,a) -> (c,b) +mapSnd f (x,y) = (x,f y) + +-- | @xs +- ys@ superimposes @xs@ over @ys@. +-- +-- [1,2,3] +- [0,0,0,0,0,0,0] == [1,2,3,0,0,0,0] +-- [x,y,z] +- [a,b,c,d,e,f,g] == [x,y,z,d,e,f,g] +-- "asdf" +- "this is a test" == "asdf is a test" +(+-) :: Eq a => [a] -> [a] -> [a] +xs +- ys = xs ++ drop (length xs) ys + + +-- Instances of ShowMutable for up to 6-tuples are given here: + +instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d) + => ShowMutable (a,b,c,d) where + mutantS (f,g,h,i) (f',g',h',i') = Tuple [ mutantS f f' + , mutantS g g' + , mutantS h h' + , mutantS i i' ] + +instance (ShowMutable a, ShowMutable b, ShowMutable c, + ShowMutable d, ShowMutable e) + => ShowMutable (a,b,c,d,e) where + mutantS (f,g,h,i,j) (f',g',h',i',j') = Tuple [ mutantS f f' + , mutantS g g' + , mutantS h h' + , mutantS i i' + , mutantS j j' ] + +instance (ShowMutable a, ShowMutable b, ShowMutable c, + ShowMutable d, ShowMutable e, ShowMutable f) + => ShowMutable (a,b,c,d,e,f) where + mutantS (f,g,h,i,j,k) (f',g',h',i',j',k') = Tuple [ mutantS f f' + , mutantS g g' + , mutantS h h' + , mutantS i i' + , mutantS j j' + , mutantS k k' ] + +mutantSTuple :: [MutantS] -> MutantS +mutantSTuple = Tuple diff --git a/src/Test/FitSpec/ShowMutable/Tuples.hs b/src/Test/FitSpec/ShowMutable/Tuples.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/ShowMutable/Tuples.hs @@ -0,0 +1,98 @@ +-- | ShowMutable instances: septuples up to 12-tuples +-- +-- This is part of a Hack that allows those instances to be hidden from Haddock. +-- Otherwise Haddock documentation will look very ugly. +module Test.FitSpec.ShowMutable.Tuples () where + +import Test.FitSpec.ShowMutable + +instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, + ShowMutable e, ShowMutable f, ShowMutable g) + => ShowMutable (a,b,c,d,e,f,g) where + mutantS (f,g,h,i,j,k,l) (f',g',h',i',j',k',l') = mutantSTuple + [ mutantS f f' + , mutantS g g' + , mutantS h h' + , mutantS i i' + , mutantS j j' + , mutantS k k' + , mutantS l l' ] + +instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, + ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h) + => ShowMutable (a,b,c,d,e,f,g,h) where + mutantS (f,g,h,i,j,k,l,m) (f',g',h',i',j',k',l',m') = mutantSTuple + [ mutantS f f' + , mutantS g g' + , mutantS h h' + , mutantS i i' + , mutantS j j' + , mutantS k k' + , mutantS l l' + , mutantS m m' ] + +instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, + ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, + ShowMutable i) + => ShowMutable (a,b,c,d,e,f,g,h,i) where + mutantS (f,g,h,i,j,k,l,m,n) (f',g',h',i',j',k',l',m',n') = mutantSTuple + [ mutantS f f' + , mutantS g g' + , mutantS h h' + , mutantS i i' + , mutantS j j' + , mutantS k k' + , mutantS l l' + , mutantS m m' + , mutantS n n' ] + +instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, + ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, + ShowMutable i, ShowMutable j) + => ShowMutable (a,b,c,d,e,f,h,g,i,j) where + mutantS (f,g,h,i,j,k,l,m,n,o) (f',g',h',i',j',k',l',m',n',o') = mutantSTuple + [ mutantS f f' + , mutantS g g' + , mutantS h h' + , mutantS i i' + , mutantS j j' + , mutantS k k' + , mutantS l l' + , mutantS m m' + , mutantS n n' + , mutantS o o' ] + +instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, + ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, + ShowMutable i, ShowMutable j, ShowMutable k) + => ShowMutable (a,b,c,d,e,f,g,h,i,j,k) where + mutantS (f,g,h,i,j,k,l,m,n,o,p) (f',g',h',i',j',k',l',m',n',o',p') = mutantSTuple + [ mutantS f f' + , mutantS g g' + , mutantS h h' + , mutantS i i' + , mutantS j j' + , mutantS k k' + , mutantS l l' + , mutantS m m' + , mutantS n n' + , mutantS o o' + , mutantS p p' ] + +instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, + ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, + ShowMutable i, ShowMutable j, ShowMutable k, ShowMutable l) + => ShowMutable (a,b,c,d,e,f,g,h,i,j,k,l) where + mutantS (f,g,h,i,j,k,l,m,n,o,p,q) (f',g',h',i',j',k',l',m',n',o',p',q') = mutantSTuple + [ mutantS f f' + , mutantS g g' + , mutantS h h' + , mutantS i i' + , mutantS j j' + , mutantS k k' + , mutantS l l' + , mutantS m m' + , mutantS n n' + , mutantS o o' + , mutantS p p' + , mutantS q q' ] diff --git a/src/Test/FitSpec/TestTypes.hs b/src/Test/FitSpec/TestTypes.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/TestTypes.hs @@ -0,0 +1,43 @@ +-- | FitSpec's Test Types: +-- 'Nat', +-- 'Int2', 'Int3', 'Int4', +-- 'UInt2', 'UInt3', 'UInt4'. +-- +-- This module basically re-exports LeanCheck's Test.Types module +-- and defines 'Mutable' and 'ShowMutable' instances for the types +-- defined there. +module Test.FitSpec.TestTypes (module Test.LeanCheck.Utils.Types) where + +import Test.FitSpec.Mutable +import Test.FitSpec.ShowMutable +import Test.LeanCheck.Utils.Types + +-- {- Standard implementation: +instance Mutable Nat where mutiers = mutiersEq +instance Mutable Int1 where mutiers = mutiersEq +instance Mutable Int2 where mutiers = mutiersEq +instance Mutable Int3 where mutiers = mutiersEq +instance Mutable Int4 where mutiers = mutiersEq +instance Mutable Word1 where mutiers = mutiersEq +instance Mutable Word2 where mutiers = mutiersEq +instance Mutable Word3 where mutiers = mutiersEq +instance Mutable Word4 where mutiers = mutiersEq +-- -} +{- Alternative implementation: +instance Mutable Nat where mutants = mutantsIntegral +instance Mutable Int2 where mutants = mutantsIntegral +instance Mutable Int3 where mutants = mutantsIntegral +instance Mutable Int4 where mutants = mutantsIntegral +instance Mutable Word2 where mutants = mutantsIntegral +instance Mutable Word3 where mutants = mutantsIntegral +instance Mutable Word4 where mutants = mutantsIntegral +-- -} +instance ShowMutable Nat where mutantS = mutantSEq +instance ShowMutable Int1 where mutantS = mutantSEq +instance ShowMutable Int2 where mutantS = mutantSEq +instance ShowMutable Int3 where mutantS = mutantSEq +instance ShowMutable Int4 where mutantS = mutantSEq +instance ShowMutable Word1 where mutantS = mutantSEq +instance ShowMutable Word2 where mutantS = mutantSEq +instance ShowMutable Word3 where mutantS = mutantSEq +instance ShowMutable Word4 where mutantS = mutantSEq diff --git a/src/Test/FitSpec/Utils.hs b/src/Test/FitSpec/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Test/FitSpec/Utils.hs @@ -0,0 +1,133 @@ +-- | General purpose utility functions for FitSpec +{-# LANGUAGE CPP #-} +module Test.FitSpec.Utils + ( (...) + , uncurry3 + , count + , compositions + , subsets + , contained + , contains + , filterU + , sortAndGroupOn + , sortAndGroupFstBySnd + , sortGroupAndCollapse + , takeWhileIncreasing + , takeWhileIncreasingOn + , lastTimeout + , sortOn + , (***) + ) +where + +#if __GLASGOW_HASKELL__ <= 704 +import Prelude hiding (catch) +#endif +import System.IO.Unsafe (unsafePerformIO) +import Control.Exception ( Exception + , SomeException + , ArithException + , ArrayException + , ErrorCall + , PatternMatchFail + , catch + , catches + , Handler (Handler) + , evaluate + ) +import Data.Function (on) +import Data.Ord (comparing) +import Data.List (groupBy,sortBy) +import Data.IORef (newIORef, readIORef, writeIORef) +import Control.Concurrent (forkIO, threadDelay, killThread) +import Control.Monad (liftM) + +-- | Compose composed with compose operator. +-- +-- > (f ... g) x y === f (g x y) +(...) :: (c->d) -> (a->b->c) -> a -> b -> d +(...) = (.) . (.) +-- f ... g = \x y -> f (g x y) + +uncurry3 :: (a->b->c->d) -> (a,b,c) -> d +uncurry3 f (x,y,z) = f x y z + +count :: (a -> Bool) -> [a] -> Int +count p = length . filter p + +-- | 'compositions' @bs@ returns all compositions formed by taking values of @bs@ +compositions :: [Bool] -> [Bool] +compositions = map and . subsets + +-- | 'subsets' @xs@ returns the list of sublists formed by taking values of @xs@ +subsets :: [a] -> [[a]] +subsets [] = [[]] +subsets (x:xs) = map (x:) (subsets xs) ++ subsets xs + +-- TODO: rename contained and contains to subset and superset? + +-- | Check if all elements of a list is contained in another list +contained :: Eq a => [a] -> [a] -> Bool +xs `contained` ys = all (`elem` ys) xs + +contains :: Eq a => [a] -> [a] -> Bool +contains = flip contained + +-- | 'filterU' filter greater-later elements in a list according to a partial +-- ordering relation. +-- +-- > filterU (notContained) [[1],[2],[1,2,3],[3,4,5]] == [[1],[2],[3,4,5]] +filterU :: (a -> a -> Bool) -> [a] -> [a] +filterU f [] = [] +filterU f (x:xs) = x : filter (f x) (filterU f xs) + +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = sortBy (compare `on` f) + +sortAndGroupOn :: Ord b => (a -> b) -> [a] -> [[a]] +sortAndGroupOn f = groupBy ((==) `on` f) + . sortOn f + +sortGroupAndCollapse :: Ord b + => (a -> b) -> (a -> c) -> (b -> [c] -> d) + -> [a] -> [d] +sortGroupAndCollapse f g h = map collapse + . sortAndGroupOn f + where collapse (x:xs) = f x `h` map g (x:xs) + +sortAndGroupFstBySnd :: Ord b => [(a,b)] -> [([a],b)] +sortAndGroupFstBySnd = sortGroupAndCollapse snd fst (flip (,)) + +-- | Takes values from a list while the values increase. If the original list +-- is non-empty, the returning list will also be non-empty +takeWhileIncreasing :: (a -> a -> Ordering) -> [a] -> [a] +takeWhileIncreasing _ [] = [] +takeWhileIncreasing _ [x] = [x] +takeWhileIncreasing cmp (x:y:xs) = x : case x `cmp` y of + LT -> takeWhileIncreasing cmp (y:xs) + _ -> [] + + +takeWhileIncreasingOn :: Ord b => (a -> b) -> [a] -> [a] +takeWhileIncreasingOn f = takeWhileIncreasing (compare `on` f) + + +-- | @lastTimeout s xs@ will take the last value of @xs@ it is able evaluate +-- before @s@ seconds elapse. +lastTimeout :: Int -> [a] -> IO a +lastTimeout _ [] = error "lastTimeout: empty list" +lastTimeout 0 (x:_) = return x -- no time to lose +lastTimeout s (x:xs) = do + r <- newIORef x + tid <- forkIO $ keepImproving r xs + threadDelay (s*1000000) -- TODO: change to waitForThread!!! + killThread tid + readIORef r + where keepImproving _ [] = return () + keepImproving r (x:xs) = do + evaluate x + writeIORef r x + keepImproving r xs + +(***) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d) +f *** g = \(x,y) -> (f x, g y) diff --git a/tests/test-derive.hs b/tests/test-derive.hs --- a/tests/test-derive.hs +++ b/tests/test-derive.hs @@ -2,7 +2,7 @@ import System.Exit (exitFailure) import Data.List (elemIndices,sort) -import FitSpec +import Test.FitSpec data D0 = D0 deriving (Show,Eq,Ord) data D1 a = D1 a deriving (Show,Eq,Ord) @@ -29,7 +29,7 @@ data Set a = Set [a] deriving (Show,Eq,Ord) instance (Ord a, Listable a) => Listable (Set a) where - tiers = consFromSet Set + tiers = setCons Set deriveMutableE [''Ord] ''Set diff --git a/tests/test-mutate.hs b/tests/test-mutate.hs --- a/tests/test-mutate.hs +++ b/tests/test-mutate.hs @@ -2,8 +2,8 @@ import Data.List (elemIndices, sort) import Data.Tuple (swap) -import FitSpec -import FitSpec.Utils (contained) +import Test.FitSpec +import Test.FitSpec.Utils (contained) import Test.LeanCheck.Error (errorToNothing, errorToFalse) import Test.LeanCheck.Function.ListsOfPairs (functionPairs, defaultFunPairsToFunction) diff --git a/tests/test-showmutable.hs b/tests/test-showmutable.hs --- a/tests/test-showmutable.hs +++ b/tests/test-showmutable.hs @@ -4,9 +4,9 @@ import Data.List (elemIndices, sort) import Data.Tuple (swap) -import FitSpec -import FitSpec.ShowMutable -import FitSpec.PrettyPrint +import Test.FitSpec +import Test.FitSpec.ShowMutable +import Test.FitSpec.PrettyPrint import Test.LeanCheck.Error (errorToNothing) import Test.LeanCheck.Utils.TypeBinding diff --git a/tests/test-utils.hs b/tests/test-utils.hs new file mode 100644 --- /dev/null +++ b/tests/test-utils.hs @@ -0,0 +1,27 @@ +import System.Exit (exitFailure) +import Data.List (elemIndices,sortBy) + +import Data.Function + +import Test.LeanCheck +import Test.FitSpec.Utils + +main :: IO () +main = + case elemIndices False (tests 500) of + [] -> putStrLn "Tests passed!" + is -> do putStrLn ("Failed tests:" ++ show is) + exitFailure + +tests :: Int -> [Bool] +tests n = + [ True + + , sortOn snd [(1,3),(2,2),(3,1)] == [(3,1),(2,2),(1,3)] + , holds n $ (propSortOn fst :: [(Int,Int)] -> Bool) + , holds n $ (propSortOn snd :: [(Int,Int)] -> Bool) + , holds n $ (propSortOn abs :: [Int] -> Bool) + ] + +propSortOn :: (Eq a, Ord b) => (a -> b) -> [a] -> Bool +propSortOn f xs = sortOn f xs == sortBy (compare `on` f) xs