diff --git a/CREDITS.md b/CREDITS.md new file mode 100644 --- /dev/null +++ b/CREDITS.md @@ -0,0 +1,22 @@ +Credits +======= + +Rudy Matela: + original implementation of FitSpec. + +Colin Runciman: + improvements in library interface and code; + set and digraph examples; + the name "FitSpec". + +Thanks to: + +* Jonas Duregård + for presenting a black-box mutation testing technique at HIW2014 + inspiring me (Rudy) to start working on it + (cf. https://www.youtube.com/watch?v=ROKxri62WYQ); + for discussions; + for an alternative way to enumerate mutants (see patterns folder). + +* Nick Smallbone + for the "Heap" example (adapted from the QuickSpec tool package). diff --git a/FitSpec.hs b/FitSpec.hs new file mode 100644 --- /dev/null +++ b/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 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.Check + ) +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.Check diff --git a/FitSpec/Derive.hs b/FitSpec/Derive.hs new file mode 100644 --- /dev/null +++ b/FitSpec/Derive.hs @@ -0,0 +1,161 @@ +-- | Experimental module for deriving Mutable instances +-- +-- Needs GHC and Template Haskell (tested on GHC 7.4, 7.6, 7.8 and 7.10) +-- +-- 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.Check + ) +where + +import FitSpec.Mutable +import FitSpec.ShowMutable + +import Test.Check +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 + TyConI (DataD _ _ ks _ _) -> ks + TyConI (NewtypeD _ _ ks _ _) -> ks + _ -> 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 + where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds + ac d _ = d diff --git a/FitSpec/Dot.hs b/FitSpec/Dot.hs new file mode 100644 --- /dev/null +++ b/FitSpec/Dot.hs @@ -0,0 +1,70 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/FitSpec/Engine.hs @@ -0,0 +1,278 @@ +-- | 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.Check.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 new file mode 100644 --- /dev/null +++ b/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 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 new file mode 100644 --- /dev/null +++ b/FitSpec/Most.hs @@ -0,0 +1,2 @@ +-- | Deprecated, import 'FitSpec' instead +module FitSpec.Most (module FitSpec) where import FitSpec diff --git a/FitSpec/Mutable.hs b/FitSpec/Mutable.hs new file mode 100644 --- /dev/null +++ b/FitSpec/Mutable.hs @@ -0,0 +1,186 @@ +-- | Enumeration of function mutations +module FitSpec.Mutable + ( Mutable (..) + , mutiersEq +--, mutantsIntegral + ) +where + +import Test.Check +import Data.List (intercalate, delete) +import Data.Maybe +import Test.Check.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 new file mode 100644 --- /dev/null +++ b/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 FitSpec.Mutable.Tuples () where + +import FitSpec.Mutable +import Test.Check (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 new file mode 100644 --- /dev/null +++ b/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 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 new file mode 100644 --- /dev/null +++ b/FitSpec/Report.hs @@ -0,0 +1,246 @@ +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 new file mode 100644 --- /dev/null +++ b/FitSpec/ShowMutable.hs @@ -0,0 +1,362 @@ +-- | Show mutant variations +module FitSpec.ShowMutable + ( ShowMutable (..) + , mutantSEq + , showMutantAsTuple + , showMutantNested + , showMutantDefinition + , showMutantBindings + , MutantS () + , mutantSTuple + ) +where + +import FitSpec.PrettyPrint +import Test.Check.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 new file mode 100644 --- /dev/null +++ b/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 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 new file mode 100644 --- /dev/null +++ b/FitSpec/TestTypes.hs @@ -0,0 +1,43 @@ +-- | 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.Types) where + +import FitSpec.Mutable +import FitSpec.ShowMutable +import Test.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 new file mode 100644 --- /dev/null +++ b/FitSpec/Utils.hs @@ -0,0 +1,133 @@ +-- | 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015-2016, Rudy Matela + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Rudy Matela nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,151 @@ +FitSpec +======= + +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. + +Installing FitSpec +------------------ + +To install the latest FitSpec version from Hackage, just: + + $ cabal install fitspec + +Pre-requisites are [cmdargs], [pretty] and [leancheck]. +They should be automatically resolved and installed by [Cabal]. + + +Using FitSpec +------------- + +As an example, consider the following properties describing a `sort` function: + + prop_ordered xs = ordered (sort xs) + prop_length xs = length (sort xs) == length xs + prop_elem x xs = elem x (sort xs) == elem x xs + prop_notElem x xs = notElem x (sort xs) == notElem x xs + prop_min x xs = head (sort (x:xs)) == minimum (x:xs) + +We provide the above properties to FitSpec in the following program: + + import FitSpec + import Data.List + + 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 -> head (sort (x:xs)) == minimum (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]) + properties + +The above program reports, after a few seconds, that our property set is +apparently *neither minimal nor complete*. + + $ ./fitspec-sort + 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) + +*Completeness:* Of 4000 mutants, 3 survive testing against our 5 properties. +The surviving mutant is clearly not a valid implementation of `sort`, but +indeed satisfies those properties. As a specification, the property set is +*incomplete* as it omits to require that sorting preserves the number of +occurrences of each element value: `\x xs -> count x (sort xs) == count x xs` + +*Minimality:* +So far as testing has revealed, properties 3 and 4 are equivalent and property +5 follows from 1 and 3 (conjectures). It is *up to the user* to check whether +these conjectures are true. Indeed they are, so in future testing we could +safely omit properties 4 and 5. + +*Refinement:* If we omit redundant properties, and add a property to kill the +surviving mutant, our refined properties are: + + properties sort = + [ \xs -> ordered (sort xs) + , \xs -> length (sort xs) == length xs + , \x xs -> elem x (sort xs) == elem x xs + , \x xs -> count x (sort xs) == count x xs + ] + +(The implementation of `count` is left as an exercise to the reader.) + +FitSpec now reports: + + Apparent complete but non-minimal specification based on + 4000 test cases for each of properties 1, 2, 3 and 4 + for each of 4000 mutant variations. + + 0 survivors (100% killed). + + apparent minimal property subsets: {1,4} + conjectures: {4} ==> {2,3} 99% killed (weak) + +As reported, properties 2 and 3 are implied by property 4, since that is true, +we can safely remove properties 2 and 3 to arrive at a minimal and complete +propety set. + + +### User-defined datatypes + +If you want to use FitSpec to analyse functions over user-defined datatypes, +those datatypes should be made instances of the [Listable], [Mutable] and +[ShowMutable] typeclasses. Check the Haddock documentation of each class for +how to define instances manually. If datatypes do not follow a data invariant, +instances can be automatically derived using [TH] by: + + deriveMutable ''DataType + + +More documentation +------------------ + +For more examples, see the [eg](eg) and [bench](bench) folders. + +For further documentation, consult the [doc](doc) folder and [FitSpec API] +documentation on Hackage. + +(TODO: link to a possible future FitSpec paper goes here) + + +[Listable]: https://hackage.haskell.org/package/leancheck/docs/Test-Check.html#t:Listable +[Mutable]: https://hackage.haskell.org/package/fitspec/docs/FitSpec.html#t:Mutable +[ShowMutable]: https://hackage.haskell.org/package/fitspec/docs/FitSpec.html#t:ShowMutable +[FitSpec API]: https://hackage.haskell.org/package/fitspec/docs/FitSpec.html + +[leancheck]: https://hackage.haskell.org/package/leancheck +[cmdargs]: https://hackage.haskell.org/package/cmdargs +[pretty]: https://hackage.haskell.org/package/pretty + +[TH]: https://wiki.haskell.org/Template_Haskell +[Cabal]: https://www.haskell.org/cabal diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/avltrees.hs b/bench/avltrees.hs new file mode 100644 --- /dev/null +++ b/bench/avltrees.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +import FitSpec +import Test.Check +import AVLTree +import Data.List (sort,nubBy) + +#if __GLASGOW_HASKELL__ >= 706 +import Prelude hiding (insert,find) +#endif + +-- TODO: separate testing of data invariants from properties over trees. + +-- This instance could be made more efficient by choosing +-- 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) + +instance (Ord a, Listable a) => Mutable (Tree a) where + mutiers = mutiersEq + +instance (Ord a, Show a, Listable a) => ShowMutable (Tree a) where + mutantS = mutantSEq + + +-- * Tree Invariants: + +ordered :: Ord a => Tree a -> Bool +ordered = ordList . flatten + where ordList (x:y:xs) = x < y && ordList (y:xs) + ordList _ = True + +balanced :: Tree a -> Bool +balanced Empty = True +balanced t@(Node _ lst _ rst) = abs (bf t) < 2 && balanced lst && balanced rst + +underHeightLimit :: Tree a -> Bool +underHeightLimit t = n <= 2^h - 1 + where n = nElem t + h = height t + 1 + +-- | Compares the height stored in the tree to an explicitly implemented version +correctHeight :: Tree a -> Bool +correctHeight t = height t == explicitHeight t + where + explicitHeight Empty = -1 + explicitHeight (Node _ lt _ gt) = max (height lt) (height gt) + 1 + +-- Our tiers enumeration guarantees that no mutant will produce a Tree not +-- following the invariants. So 1-8 will always be reported as uneeded. +properties :: (Ord a, Show a, Listable a) + => (a -> Tree a -> Tree a) + -> (a -> Tree a -> Tree a) + -> (a -> Tree a -> Maybe a) + -> [Property] +properties insert remove find = + [ property $ \x t -> ordered (insert x t) -- 1 + , property $ \x t -> ordered (remove x t) -- 2 + , property $ \x t -> balanced (insert x t) -- 3 + , property $ \x t -> balanced (remove x t) -- 4 + , property $ \x t -> underHeightLimit (insert x t) -- 5 + , property $ \x t -> underHeightLimit (remove x t) -- 6 + , property $ \x t -> correctHeight (insert x t) -- 7 + , property $ \x t -> correctHeight (remove x t) -- 8 + , property $ \x t -> find x (insert x t) == Just x -- 9 + , property $ \x t -> find x (remove x t) == Nothing -- 10 + ] + +type Insert a = a -> Tree a -> Tree a + +main :: IO () +main = + reportWith args { names = ["insert x t","remove x t","find x t"] + , timeout = 0 } + (insert :: Insert Word2, remove, find) + (uncurry3 properties) + +uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d +uncurry3 f = \(x,y,z) -> f x y z diff --git a/bench/bools.hs b/bench/bools.hs new file mode 100644 --- /dev/null +++ b/bench/bools.hs @@ -0,0 +1,56 @@ +import FitSpec + +propertiesN :: (Bool -> Bool) -> [Property] +propertiesN not = + [ property $ \p -> not (not p) == p + , property $ \p -> not p /= p + , property $ not True == False + ] + +propertiesNA :: (Bool -> Bool) -> (Bool -> Bool -> Bool) -> [Property] +propertiesNA not (&&) = + [ property $ \p -> not (not p) == p + , property $ \p q -> p && q == q && p + , property $ \p -> p && p == p + , property $ \p -> p && False == False + , property $ \p q r -> p && (q && r) == (p && q) && r + , property $ \p -> p && not p == False + , property $ \p -> p && not False == p + ] + +propertiesNAO :: (Bool->Bool) -> (Bool->Bool->Bool) -> (Bool->Bool->Bool) + -> [Property] +propertiesNAO not (&&) (||) = + [ property $ not True == False + , property $ \p -> not (not p) == p + + , property $ \p q -> p && q == q && p + , property $ \p -> p && p == p + , property $ \p -> p && True == p + , property $ \p -> p && False == False + , property $ \p q r -> p && (q && r) == q && (p && r) + + , property $ \p q -> p || q == q || p + , property $ \p -> p || p == p + , property $ \p -> p || True == True + , property $ \p -> p || False == p + , property $ \p q r -> p || (q || r) == q || (p || r) + + , property $ \p q -> p && (p || q) == p + , property $ \p q -> p || (p && q) == p + , property $ \p -> p && not p == False + ] + +main = do + as <- getArgsWith args { names = ["not p","p && q","p || q"] + , nMutants = 100 + , nTests = 100 + , timeout = 0 } + let run f ps = reportWith as f ps + case concat $ extra as of + "nao" -> run (not,(&&),(||)) (uncurry3 propertiesNAO) + "na" -> run (not,(&&)) (uncurry propertiesNA) + _ -> run not propertiesN + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (x,y,z) = f x y z diff --git a/bench/digraphs.hs b/bench/digraphs.hs new file mode 100644 --- /dev/null +++ b/bench/digraphs.hs @@ -0,0 +1,166 @@ +-- This program applies FitSpec to the Digraph library. +-- +-- Usage: +-- analyse properties about membership functions: +-- ./digraphs [options] m +-- +-- analyse properties about ispath and subgraph functions: +-- ./digraphs [options] ps +-- +-- +-- This program is more complicated than it should, as it: +-- * allows switching between two function-tuples/property-sets -- 'digraphs m' or 'digraphs ps'; +-- * 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 Data.List ((\\)) +import qualified Data.List as L (delete) +import Control.Monad + +instance (Ord a, Listable a) => Listable (Digraph a) where + tiers = concatMapT graphs $ setsOf tiers + where + graphs ns = mapT (D . zip ns) + $ listsOfLength (length ns) (setsOf $ toTiers ns) + +-- Our digraph instance above is too complicated. +-- Simple reference implementation: +listDigraphsInneficient :: (Ord a, Listable a) => [Digraph a] +listDigraphsInneficient = concat tiers' + where + tiers' = cons1 D `suchThat` okDigraph `ofWeight` 0 + +-- Tests Listable Digraph listable instance +-- by comparing to an equivalent inneficient implementation: +-- +-- > tiers === tiersDigraphsInneficient +listableOK :: Bool +listableOK = and + [ holds 10000 $ \d -> okDigraph (d :: Digraph A) -- sound + , take 100 list `subset` (listDigraphsInneficient :: [Digraph A]) -- sound + , take 100 (listDigraphsInneficient :: [Digraph A]) `subset` list -- complete + ] + where xs `subset` ys = all (`elem` ys) xs + +-- For debugging the digraphs instance +putDigraphs :: Int -> IO () +putDigraphs n = putStrLn . unlines . map (unlines . map show) + $ take n (tiers :: [[Digraph A]]) + + +instance (Ord a, Listable a) => Mutable (Digraph a) where mutiers = mutiersEq + +instance (Ord a, Show a, Listable a) => ShowMutable (Digraph a) where + mutantS = mutantSEq + + + +type Preds a = a -> Digraph a -> [a] +type Succs a = a -> Digraph a -> [a] +type IsNode a = a -> Digraph a -> Bool +type IsEdge a = a -> a -> Digraph a -> Bool + +type TyM a = (Preds a, Succs a, IsNode a, IsEdge a) + +-- | properties about membership in a digraph +propertiesM :: (Ord a, Eq a, Show a, Listable a) => TyM a -> [Property] +propertiesM (preds, succs, isNode, isEdge) = + [ property $ \d t -> D.strictOrder (preds t d) + , property $ \d s -> D.strictOrder (succs s d) + , property $ \d s t -> (s `elem` preds t d) == (t `elem` succs s d) + , property $ \d s t -> (t `elem` succs s d) == isEdge s t d + , property $ \d s t -> isEdge s t d ==> (isNode s d && isNode t d) + , property $ \d s -> isNode s d == (s `elem` D.nodes d) + ] + +functionsM :: Ord a => TyM a +functionsM = (preds,succs,isNode,isEdge) + + +type IsPath a = a -> a -> Digraph a -> Bool +type Subgraph a = [a] -> Digraph a -> Digraph a + +type TyPS a = (IsPath a, Subgraph a) + +-- | properties abouth path and subgraph +propertiesPS :: (Ord a, Eq a, Show a, Listable a) => TyPS a -> [Property] +propertiesPS (isPath, subgraph) = + [ property $ \n d -> isPath n n d == isNode n d + , property $ \n1 n2 n3 d -> isPath n1 n2 d && isPath n2 n3 d ==> isPath n1 n3 d + , property $ \d -> subgraph (D.nodes d) d == d + , property $ \ns1 ns2 d -> subgraph ns1 (subgraph ns2 d) == subgraph ns2 (subgraph ns1 d) + , property $ \n1 n2 ns d -> isPath n1 n2 (subgraph ns d) ==> isPath n1 n2 d + + -- 5-7 + , property $ \n1 n2 d -> isPath n1 n2 d ==> isNode n1 d && isNode n2 d + , property $ \n1 n2 d -> isPath n1 n2 d && n1 /= n2 ==> + any (\n1' -> n1' /= n1 && isPath n1' n2 d) (succs n1 d) + , property $ \n1 n2 d -> n1 /= n2 ==> + isPath n1 n2 d == + let d' = subgraph (nodes d \\ [n1]) d in + any (\n1' -> isPath n1' n2 d') + (succs n1 d) + + -- 8-9 + , property $ \n ns d -> isNode n (subgraph ns d) == (isNode n d && n `elem` ns) + , property $ \n1 n2 ns d -> isEdge n1 n2 (subgraph ns d) + == (isEdge n1 n2 d && n1 `elem` ns && n2 `elem` ns) + ] + +functionsPS :: Ord a => TyPS a +functionsPS = (isPath, subgraph) + + + +extraMutantsM :: Ord a => [TyM a] +extraMutantsM = [] + +extraMutantsPS :: Ord a => [TyPS a] +extraMutantsPS = drop 1 + [ (isPath, subgraph) + , (\n1 n2 d -> isNode n1 d && isNode n2 d, subgraph) + , (isPath, \ns d -> D []) + ] + +-- Choosen node-label test type. +type A = Nat + +main = do + unless listableOK + $ putStrLn "WARNING: Listable Digraph is broken! (read my source.)" + + as <- getArgsWith args { names = [ "isPath n1 n2 d" + , "subgraph ns d" ] } + + let (pset,step) = case extra as of + (p:s:_) -> (p ,read s) + [p] -> (p ,0) + [] -> ("m",0) + + case pset of + "m" -> + mainWith as { names = [ "preds n d" + , "succs n d" + , "isNode n d" + , "isEdge s t d" ] } + (functionsM :: TyM A) + propertiesM + + "ps" -> + let is = case step of + 0 -> [ ] + 1 -> [0,1,2,3,4 ] + 2 -> [0,1,2,3,4,5,6 ] + 3 -> [0,1,2,3,4,5,6, 8,9] + 4 -> [0,1,2,3,4,5, 7,8,9] + 5 -> [0, 7,8,9] + _ -> [0,1,2,3,4,5,6,7,8,9] -- not an actual step + in + mainWith as { names = [ "isPath n1 n2 d" + , "subgraph ns d" ] } + (functionsPS :: TyPS A) + ((!!! is) . propertiesPS) + +(!!!) :: [a] -> [Int] -> [a] +xs !!! is = map (xs !!) is diff --git a/bench/heaps.hs b/bench/heaps.hs new file mode 100644 --- /dev/null +++ b/bench/heaps.hs @@ -0,0 +1,109 @@ +{-# Language DeriveDataTypeable, NoMonomorphismRestriction #-} +import System.Console.CmdArgs hiding (args) +import FitSpec +import Prelude hiding (null) +import qualified Data.List as L +import Data.Maybe (listToMaybe) +import Heap +import Control.Monad (unless) + +instance (Ord a, Listable a) => Listable (Heap a) where + tiers = consFromAscendingList fromList + +-- a good property to assure that the above does not leave out elements is: +-- +-- \xs ys = xs `permutation` ys <==> fromList xs == fromList ys +-- `asTypeOf` (undefined :: Heap a) + +instance (Ord a, Listable a) => Mutable (Heap a) where + mutiers = mutiersEq + +instance (Ord a, Show a, Listable a) => ShowMutable (Heap a) where + mutantS = mutantSEq + +-- Alias for type (they are repeated a lot) +type Insert a = a -> Heap a -> Heap a +type DeleteMin a = Heap a -> Heap a +type Merge a = Heap a -> Heap a -> Heap a +type Ty a = (Insert a, DeleteMin a, Merge a) + +properties :: (Ord a, Show a, Listable a) + => Insert a + -> DeleteMin a + -> Merge a + -> [Property] +properties insert' deleteMin' merge' = + [ property $ \x y h -> insert' x (insert' y h) == insert' y (insert' x h) -- 1 + , property $ \h x -> null (insert' x h) == False -- 2 + , property $ \x h -> L.insert x (toList h) == toList (insert' x h) -- 3 + + , property $ \h h1 -> merge' h h1 == merge' h1 h -- 4 + , property $ \h -> merge' h Nil == h -- 5 + , property $ \h h1 h2 -> merge' h (merge' h1 h2) == merge' h1 (merge' h h2) -- 6 + , property $ \h -> not (null h) ==> findMin (merge' h h) == findMin h -- 7 + , property $ \h -> null (merge' h h) == null h -- 8 + , property $ \h h1 -> (null h && null h1) == null (merge' h h1) -- 9 + + , property $ \h h1 x -> merge' h (insert' x h1) == insert' x (merge' h h1) -- 10 + , property $ \h -> not (null h) ==> merge' h (deleteMin' h) == deleteMin' (merge' h h) -- 11 + , property $ \x -> deleteMin' (insert' x Nil) == Nil -- 12 + ] + +sargs = args + { timeout = 0 + , nMutants = 500 + , nTests = 500 + , names = ["insert x h","deleteMin h","merge h h'"] +--, extraMutants = take 0 [(uncurry maxInsert,maxDeleteMin,uncurry maxMerge)] } + } + +fns :: Ord a => Ty a +fns = (insert, deleteMin, merge) + +em :: (Bounded a, Ord a) => [Ty a] +em = take 3 + [ (maxInsert, maxDeleteMin, maxMerge) + , (insert, deleteMin, crazyMerge) + , (\i h -> Nil, deleteMin, merge) + ] + +main :: IO () +main = do + as <- getArgsWith sargs + let run f = reportWithExtra em as f (uncurry3 properties) + case concat (extra as) of +-- "bool" -> run (fns :: Ty Bool) +-- "bools" -> run (fns :: Ty [Bool]) + "i" -> run (fns :: Ty Int) + "i1" -> run (fns :: Ty Int1) + "i2" -> run (fns :: Ty Int2) + "i3" -> run (fns :: Ty Int3) + "w1" -> run (fns :: Ty Word1) + "w2" -> run (fns :: Ty Word2) + "w3" -> run (fns :: Ty Word3) + "unit" -> run (fns :: Ty ()) + "" -> run (fns :: Ty Word2) + + +maxInsert :: Ord a => a -> Heap a -> Heap a +maxInsert x h = maxMerge h (branch x Nil Nil) + +maxDeleteMin :: Ord a => Heap a -> Heap a +maxDeleteMin (Branch _ _ l r) = maxMerge l r +maxDeleteMin Nil = Nil + +maxMerge :: Ord a => Heap a -> Heap a -> Heap a +maxMerge Nil h = h +maxMerge h Nil = h +maxMerge h1@(Branch _ x1 l1 r1) h2@(Branch _ x2 l2 r2) + | x1 >= x2 = branch x1 (maxMerge l1 h2) r1 + | otherwise = maxMerge h2 h1 + +uncurry3 :: (a->b->c->d) -> (a,b,c) -> d +uncurry3 f (x,y,z) = f x y z + +crazyMerge :: (Bounded a, Ord a) => Heap a -> Heap a -> Heap a +crazyMerge Nil Nil = Nil +crazyMerge Nil h = h +crazyMerge h Nil = h +crazyMerge h h1 = insert maxBound $ merge h h1 diff --git a/bench/id.hs b/bench/id.hs new file mode 100644 --- /dev/null +++ b/bench/id.hs @@ -0,0 +1,34 @@ +-- Example benchmark that mutation tests properties over the function id +import System.Console.CmdArgs hiding (args) +import FitSpec + +type Ty a = a -> a + +-- The property map +properties :: (Eq a, Show a, Listable a) => Ty a -> [Property] +properties id = + [ property $ \x -> id x == x + , property $ \x -> id x == id x + , property $ \x -> (id . id) x == x + ] + +sargs :: Args +sargs = args + { names = ["id x"] + , nMutants = 1000 + , nTests = 2000 + , timeout = 0 + } + +main :: IO () +main = do + as <- getArgsWith sargs + let run f = reportWith as f properties + case concat (extra as) of + "bool" -> run (id :: Ty Bool) + "bools" -> run (id :: Ty [Bool]) + "int" -> run (id :: Ty Int) + "int2" -> run (id :: Ty UInt2) + "int3" -> run (id :: Ty UInt3) + "unit" -> run (id :: Ty ()) + "" -> run (id :: Ty UInt2) diff --git a/bench/list.hs b/bench/list.hs new file mode 100644 --- /dev/null +++ b/bench/list.hs @@ -0,0 +1,73 @@ +import System.Console.CmdArgs hiding (args) +import FitSpec +import Data.List +import Test.Check + +type Cons a = a -> [a] -> [a] +type Head a = [a] -> a +type Tail a = [a] -> [a] +type Append a = [a] -> [a] -> [a] +type Ty a = ( Cons a + , Head a + , Tail a + , Append a + ) + +-- The property map +properties :: (Eq a, Show a, Listable a) + => Cons a + -> Head a + -> Tail a + -> Append a + -> [Property] +properties (-:) head tail (++) = + [ property $ \xs -> [] ++ xs == xs && xs == xs ++ [] + , property $ \x xs -> head (x-:xs) == x + , property $ \x xs -> tail (x-:xs) == xs + , property $ \xs -> null (xs ++ xs) == null xs + , property $ \xs ys zs -> (xs ++ ys) ++ zs == xs ++ (ys ++ zs) + , property $ \x xs ys -> x-:(xs ++ ys) == (x-:xs) ++ ys + ] + + +fns :: Ty a +fns = ((:),head,tail,(++)) + +sargs :: Args +sargs = args + { names = ["(:) x xs","head xs","tail xs","(++) xs ys"] + , nMutants = 1000 + , nTests = 1000 + , timeout = 0 + } + +--, extraMutants = takeWhile (const False) +-- [ ((:),head,tail,(++-)) +-- , ((:),head,tail,(++--)) +-- ] + +main :: IO () +main = do + as <- getArgsWith sargs + let run f = reportWith as f (uncurry4 properties) + case concat (extra as) of + "bool" -> run (fns :: Ty Bool) + "bools" -> run (fns :: Ty [Bool]) + "int" -> run (fns :: Ty Int) + "int2" -> run (fns :: Ty UInt2) + "int3" -> run (fns :: Ty UInt3) + "unit" -> run (fns :: Ty ()) + "" -> run (fns :: Ty UInt2) + +-- Some manual mutants +(++-) :: [a] -> [a] -> [a] +xs ++- ys = [] + +(++--) :: [a] -> [a] -> [a] +xs ++-- ys = if length xs > length ys + then xs + else ys + +uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e +uncurry4 f (x,y,z,w) = f x y z w + diff --git a/bench/mergeheaps.hs b/bench/mergeheaps.hs new file mode 100644 --- /dev/null +++ b/bench/mergeheaps.hs @@ -0,0 +1,105 @@ +{-# Language DeriveDataTypeable, NoMonomorphismRestriction #-} +import System.Console.CmdArgs hiding (args) +import FitSpec +import Prelude hiding (null) +import qualified Data.List as L +import Data.Maybe (listToMaybe) +import Heap +import Control.Monad (unless) + +instance (Ord a, Listable a) => Listable (Heap a) where + tiers = consFromAscendingList fromList + +instance (Ord a, Listable a) => Mutable (Heap a) where + mutiers = mutiersEq + +instance (Ord a, Show a, Listable a) => ShowMutable (Heap a) where + mutantS = mutantSEq + +type Merge a = Heap a -> Heap a -> Heap a +type Ty a = Merge a + +properties :: (Ord a, Show a, Listable a) + => Merge a + -> [Property] +properties merge = + [ property $ \h h1 -> merge h h1 == merge h1 h + , property $ \h -> merge h Nil == h + , property $ \x h h1 -> merge h (insert x h1) == insert x (merge h h1) + , property $ \h h1 h2 -> merge h (merge h1 h2) == merge h1 (merge h h2) + , property $ \h -> notNull h ==> findMin (merge h h) == findMin h + , property $ \h -> null (merge h h) == null h + , property $ \h -> notNull h ==> merge h (deleteMin h) == deleteMin (merge h h) + , property $ \h h1 -> (null h && null h1) == null (merge h h1) +--, property $ \xs ys -> merge (fromList xs) (fromList ys) == fromList (xs++ys) +--, property $ \h h1 -> mergeLists (toList h) (toList h1) == toList (merge h h1) + ] + where notNull = not . null + +sargs = args + { timeout = 0 + , nMutants = 500 + , nTests = 500 + , names = ["merge h h'"] + } + +em :: (Bounded a, Ord a) => [Ty a] +em = take 4 + [ (\_ _ -> Nil) + , maxMerge + , crazyMerge + , mergeEqNil + ] + +main :: IO () +main = do + as <- getArgsWith sargs + let run f = reportWithExtra em as f properties + case concat (extra as) of + "bool" -> run (merge :: Ty Bool) + "bools" -> run (merge :: Ty [Bool]) + "i" -> run (merge :: Ty Int) + "i1" -> run (merge :: Ty Int1) + "i2" -> run (merge :: Ty Int2) + "i3" -> run (merge :: Ty Int3) + "w1" -> run (merge :: Ty Word1) + "w2" -> run (merge :: Ty Word2) + "w3" -> run (merge :: Ty Word3) + "unit" -> run (merge :: Ty ()) + "" -> run (merge :: Ty Word2) + + +maxInsert :: Ord a => a -> Heap a -> Heap a +maxInsert x h = maxMerge h (branch x Nil Nil) + +maxDeleteMin :: Ord a => Heap a -> Heap a +maxDeleteMin (Branch _ _ l r) = maxMerge l r +maxDeleteMin Nil = Nil + +maxMerge :: Ord a => Heap a -> Heap a -> Heap a +maxMerge Nil h = h +maxMerge h Nil = h +maxMerge h1@(Branch _ x1 l1 r1) h2@(Branch _ x2 l2 r2) + | x1 >= x2 = branch x1 (maxMerge l1 h2) r1 + | otherwise = maxMerge h2 h1 + +uncurry3 :: (a->b->c->d) -> (a,b,c) -> d +uncurry3 f (x,y,z) = f x y z + +crazyMerge :: (Bounded a, Ord a) => Heap a -> Heap a -> Heap a +crazyMerge Nil Nil = Nil +crazyMerge Nil h = h +crazyMerge h Nil = h +crazyMerge h h1 = insert maxBound $ merge h h1 + +mergeEqNil :: (Ord a) => Heap a -> Heap a -> Heap a +mergeEqNil h h1 | h == h1 = Nil + | otherwise = merge h h1 + +-- Only necessary for crazyMerge + bools to compile +-- (it won't run, because it won't be able to PRINT surviving +-- mutants). +-- all other types should work fine +instance Bounded a => Bounded [a] where + minBound = [] + maxBound = repeat maxBound diff --git a/bench/pretty.hs b/bench/pretty.hs new file mode 100644 --- /dev/null +++ b/bench/pretty.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} +import FitSpec +import Test.Check +import Text.PrettyPrint + +#if __GLASGOW_HASKELL__ < 710 +-- pretty <= 1.1.1.1 (bundled with GHC <= 7.8) does not provide this instance +-- pretty >= 1.1.2.0 (bundled with GHC >= 7.10) does provide this instance +instance Eq Doc where + d == d' = show d == show d' +#endif + +instance Listable Doc where + tiers = cons1 text -- TODO: Improve this + +instance Mutable Doc where + mutiers = mutiersEq + +instance ShowMutable Doc where + mutantS = mutantSEq + +properties :: (Doc->Doc->Doc) -> (Doc->Doc->Doc) -> (Int->Doc->Doc) -> [Property] +properties (<>) ($$) nest = + [ property $ \x y z -> (x <> y) <> z == x <> (y <> z) + , property $ \x y z -> (x $$ y) $$ z == x $$ (y $$ z) + , property $ \x -> x <> text "" == x + , property $ \x k y -> nest k (x $$ y) == nest k x $$ nest k y + , property $ \x k y -> nest k (x <> y) == nest k x <> y + , property $ \x k y -> x <> nest k y == x <> y + , property $ \x k k' -> nest k (nest k' x) == nest (k+k') x + , property $ \x -> nest 0 x == x + , property $ \x y z -> (x $$ y) <> z == x $$ (y <> z) + , property $ \s y z -> text s <> ((text "" <> y) $$ z) == (text s <> y) $$ nest (length s) z + , property $ \s t -> text s <> text t == text (s ++ t) + ] + +propertiesQS :: (Doc->Doc->Doc) -> (Doc->Doc->Doc) -> (Int->Doc->Doc) -> [Property] +propertiesQS (<>) ($$) nest = + [ property $ \x y z -> (x <> y) <> z == x <> (y <> z) + , property $ \x y z -> (x $$ y) $$ z == x $$ (y $$ z) + , property $ \x y z -> (x $$ y) <> z == x $$ (y <> z) + , property $ \x k y -> x <> nest k y == x <> y + , property $ \x k y -> nest k (x <> y) == nest k x <> y + , property $ \x k y -> nest k (x $$ y) == nest k x $$ nest k y + , property $ \x k k' -> nest k (nest k' x) == nest k' (nest k x) + ] + +main = do + as <- getArgs + let run ps = reportWith as ((<>),($$),nest) (uncurry3 ps) + case concat (extra as) of + "qs" -> run propertiesQS + "" -> run properties + +uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d +uncurry3 f = \(x,y,z) -> f x y z diff --git a/bench/sets.hs b/bench/sets.hs new file mode 100644 --- /dev/null +++ b/bench/sets.hs @@ -0,0 +1,64 @@ +import Set +import FitSpec hiding ((\/)) + + +instance (Ord a, Listable a) => Listable (Set a) where + tiers = consFromSet set + +instance (Ord a, Listable a) => Mutable (Set a) where + mutiers = mutiersEq + +instance (Ord a, Show a, Listable a) => ShowMutable (Set a) where + mutantS = mutantSEq + + +type Elem a = a -> Set a -> Bool + + +-- The property map. +-- In a real program applying FitSpec, the 'Int' parameter would not exist. +-- It is here so we can re-run the steps taken in creating the final +-- property list (by @properties 3@). +properties 0 ((<~), insertS, deleteS, (/\), (\/), subS) = + [ + ] +properties 1 ((<~), insertS, deleteS, (/\), (\/), subS) = + [ property $ \x s -> x <~ insertS x s + , property $ \x s -> not (x <~ deleteS x s) + , property $ \x s t -> (x <~ (s \/ t)) == ((x <~ s) || (x <~ t)) + , property $ \x s t -> (x <~ (s /\ t)) == ((x <~ s) && (x <~ t)) + , property $ \s t -> subS s (s \/ t) + , property $ \s t -> subS (s /\ t) s + , property $ \s t -> (s \/ t) == (t \/ s) + , property $ \s t -> (s /\ t) == (t /\ s) + ] +properties 2 ((<~), insertS, deleteS, (/\), (\/), subS) = + [ property $ \x s -> x <~ insertS x s + , property $ \x s -> not (x <~ deleteS x s) + , property $ \x s t -> (x <~ (s \/ t)) == ((x <~ s) || (x <~ t)) + , property $ \x s t -> (x <~ (s /\ t)) == ((x <~ s) && (x <~ t)) + , property $ \s t -> subS s t == allS (<~ t) s + ] +properties _ ((<~), insertS, deleteS, (/\), (\/), subS) = + [ property $ \x y s -> x <~ insertS y s == (x == y || x <~ s) + , property $ \x y s -> x <~ deleteS y s == (x <~ s && x /= y) + , property $ \x s t -> (x <~ (s \/ t)) == ((x <~ s) || (x <~ t)) + , property $ \x s t -> (x <~ (s /\ t)) == ((x <~ s) && (x <~ t)) + , property $ \s t -> subS s t == allS (<~ t) s + ] +-- If we add (\\) to the functions under test, this property should follow: +-- \x s t -> (x <~ (s \\ t)) == ((x <~ s) && not (x <~ t)) + + +main :: IO () +main = do + as <- getArgs + let psid = case concat . extra $ as of "" -> 0; cs -> read cs + mainWith as { names = [ "x <~ s" + , "insertS x s" + , "deleteS x s" + , "s /\\ t" + , "s \\/ t" + , "subS s t" ] } + ((<~)::Elem Word2, insertS, deleteS, (/\), (\/), subS) + (properties psid) diff --git a/bench/setsofsets.hs b/bench/setsofsets.hs new file mode 100644 --- /dev/null +++ b/bench/setsofsets.hs @@ -0,0 +1,69 @@ +import Set +import FitSpec hiding ((\/)) + + +instance (Ord a, Listable a) => Listable (Set a) where + tiers = consFromSet set + +instance (Ord a, Listable a) => Mutable (Set a) where + mutiers = mutiersEq + +instance (Ord a, Show a, Listable a) => ShowMutable (Set a) where + mutantS = mutantSEq + +-- The Mutable and ShowMutable instances could be alternatively derived by: +-- deriveMutable 'Set + + +-- Type of functions under test +type PowerS a = Set a -> Set (Set a) +type PartitionsS a = Set a -> Set (Set (Set a)) +type Ty a = (PowerS a, PartitionsS a) + + +-- The property map. +-- In a real program applying FitSpec, the 'Int' parameter would not exist. +-- It is here so we can re-run the steps taken in creating the final +-- property list (by @properties 5@). +properties :: (Ord a, Eq a, Show a, Listable a) + => Int -> Ty a -> [Property] +properties 0 (powerS,partitionsS) = + [ + ] +properties 1 (powerS,partitionsS) = + [ property $ \s t -> (t <~ powerS s) == subS t s + , property $ \s -> allS (allS (`subS` s)) (partitionsS s) + ] +properties 2 (powerS,partitionsS) = + [ property $ \s t -> (t <~ powerS s) == subS t s + , property $ \s -> allS (allS (`subS` s)) (partitionsS s) + , property $ \s -> nonEmptyS (partitionsS s) + ] +properties 3 (powerS,partitionsS) = + [ property $ \s t -> (t <~ powerS s) == subS t s + , property $ \s -> allS (allS (`subS` s)) (partitionsS s) + , property $ \s -> nonEmptyS (partitionsS s) + , property $ \s -> allS (allS (\t -> nonEmptyS t && subS t s)) (partitionsS s) + ] +-- Ommited on paper -- we changed 4th to: +--, property $ \s -> allS (\p -> unionS p == s && allS nonEmptyS p) (partitionsS s) +properties _ (powerS,partitionsS) = + [ property $ \s t -> (t <~ powerS s) == subS t s + , property $ \s p -> (p <~ partitionsS s) == + ( unionS p == s && + allS nonEmptyS p && + sum (map sizeS (elemList p)) == sizeS s ) + ] + + +fns :: Ord a => Ty a +fns = (powerS, partitionsS) + +main :: IO () +main = do + as <- getArgs + let psid = read . concat . extra $ as + mainWith as { names = [ "powerS s" + , "partitionsS s" ] } + (fns::Ty Word2) + (properties psid) diff --git a/bench/sieve.hs b/bench/sieve.hs new file mode 100644 --- /dev/null +++ b/bench/sieve.hs @@ -0,0 +1,77 @@ +-- Example benchmark that mutation tests properties over an infinite list of primes +import System.Console.CmdArgs hiding (args) +import FitSpec +import Data.Maybe + +-- The code under test +primes :: [Int] +primes = sieve [2..] + where sieve (p:ns) = p : sieve [n | n <- ns, n `mod` p /= 0] + +-- Some auxiliary functions +strictlyOrdered [] = True +strictlyOrdered [x] = True +strictlyOrdered (x:y:xs) = x a -> [a] -> Bool +x `elemO` [] = False +x `elemO` (x':xs) = case x `compare` x' of + LT -> False -- would already have appeared int the list + EQ -> True + GT -> x `elemO` xs +infix 4 `elemO` + +notElemO :: Ord a => a -> [a] -> Bool +notElemO = (not .) . elemO +infix 4 `notElemO` + +-- The property map +properties :: [Int] -> [Property] +properties primes = + [ property $ listToMaybe primes == Just 2 -- start with two +--, property $ length (take n primes) == n -- infinite +--, property $ allUnique (take n primes) +--, property $ strictlyOrdered (take n primes) + , property $ \x -> x `elemO` primes + ==> x*x `notElemO` primes + , property $ \x y -> x `elemO` primes + && y `elemO` primes + ==> x*y `notElemO` primes +--, property $ \i' -> let i = fromIntegral (i'::Nat) +-- p = primes !! i +-- ps = drop (i+1) primes +-- in p > 1 ==> all (\p' -> p' `mod` p /= 0) (take n ps) + , property $ \x y -> x `elemO` primes + && y `elemO` primes + && x /= y + ==> x `mod` y /= 0 +--, all prime (take n primes) -- sound +--, all (`elemO` primes) [ x | x <- [1..n], prime x ] -- complete + ] + where prime x = x > 1 + && all (\p -> p > 0 && x `mod` p /= 0) + (takeWhile (\p -> p*p <= x) primes) + + +prime x = x > 1 && all (\p -> p `mod` x /= 0) (takeWhile (\p -> p*p <= x) primes) + +sargs :: Args +sargs = args + { nMutants = 20000 + , nTests = 100 + , timeout = 0 + } +--, showMutantN = \_ _ -> showInfinite +--where showInfinite xs | not . null $ drop 10 xs = (init . show $ take 10 xs) ++ "..." +-- | otherwise = show xs + +main :: IO () +main = mainWith sargs primes properties + +allUnique :: Ord a => [a] -> Bool +allUnique [] = True +allUnique (x:xs) = x `notElem` xs + && allUnique lesser + && allUnique greater + where lesser = filter (< x) xs + greater = filter (> x) xs diff --git a/bench/sorting.hs b/bench/sorting.hs new file mode 100644 --- /dev/null +++ b/bench/sorting.hs @@ -0,0 +1,71 @@ +import Data.List +import FitSpec + + +ordered :: Ord a => [a] -> Bool +ordered [] = True +ordered [_] = True +ordered (x:y:xs) = x <= y && ordered (y:xs) + +permutation :: Eq a => [a] -> [a] -> Bool +[] `permutation` [] = True +(_:_) `permutation` [] = False +[] `permutation` (_:_) = False +(x:xs) `permutation` ys = x `elem` ys && xs `permutation` delete x ys + +count :: Eq a => a -> [a] -> Int +count x = length . filter (==x) + + +properties :: (Ord a, Show a, Listable a) + => ([a] -> [a]) -> [Property] +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 -> count x (sort xs) == count x xs + , property $ \xs -> permutation xs (sort xs) + , property $ \x xs -> insert x (sort xs) == sort (x:xs) + ] + + +sargs :: Args +sargs = args + { names = ["sort xs"] + , timeout = 0 + , nMutants = 1000 + , nTests = 1000 + } +--, extraMutants = take 0 +-- . concat +-- . lsmap (. sort) +-- $ cons2 (\y ys -> (++ (y:ys))) -- prepend non-empty list +-- \++/ cons2 (\y ys -> ((y:ys) ++)) -- append non-empty list + +type Ty a = [a] -> [a] + +main :: IO () +main = do + as <- getArgsWith sargs + let run f = reportWith as f properties + case concat $ extra as of + "bool" -> run (sort :: Ty Bool) + "bools" -> run (sort :: Ty [Bool]) + "int" -> run (sort :: Ty Int) + "i1" -> run (sort :: Ty Int1) + "i2" -> run (sort :: Ty Int2) + "i3" -> run (sort :: Ty Int3) + "w1" -> run (sort :: Ty Word1) + "w2" -> run (sort :: Ty Word2) + "w3" -> run (sort :: Ty Word3) + "unit" -> run (sort :: Ty ()) + "" -> run (sort :: Ty Word2) + t -> putStrLn $ "unknown type " ++ t + +-- This hack is only necessary when using sortCounter as a manual mutant +instance Bounded a => Bounded [a] where + minBound = [] + maxBound = repeat maxBound -- non terminating upper bound + +sortCounter :: (Bounded a, Ord a) => [a] -> [a] +sortCounter = (++ [maxBound]) . sort diff --git a/bench/spring.hs b/bench/spring.hs new file mode 100644 --- /dev/null +++ b/bench/spring.hs @@ -0,0 +1,70 @@ +import System.Console.CmdArgs hiding (args) +import FitSpec +import Data.List + +type Add a = a -> a -> a +type Prod a = a -> a -> a +type Ty a = ( Add a + , Prod a ) + +properties :: (Listable a, Show a, Eq a, Num a) + => Add a + -> Prod a + -> [Property] +properties (+) (*) = + [ property $ \x y -> x + y == y + x + , property $ \x y z -> x + (y + z) == (x + y) + z + , property $ \x -> x + 0 == x + , property $ \x -> 0 + x == x + + , property $ \x y -> x * y == y * x + , property $ \x y z -> x * (y * z) == (x * y) * z + , property $ \x -> x * 1 == x + , property $ \x -> 1 * x == x + + , property $ \x y z -> x * (y + z) == (x * y) + (x * z) + , property $ \x y z -> (y + z) * x == (y * x) + (z * x) + ] + + +fns :: Integral a => Ty a +fns = ((+),(*)) + + +sargs :: Args +sargs = + args { timeout = 0 + , nMutants = 1000 + , nTests = 1000 + , names = [ "x + y", "x * y" ] + } +-- , extraMutants = +-- let ems = [ \x y -> x+y+1 +-- , \x y -> x*y+x*y +-- , \x y -> x+y+x+y +-- , (+++) +-- , min +-- , max +-- -- another good example would be +-- -- || and && defined over integers +-- ] +-- in drop 1 [ (s,p) +-- | False -- was useExtra +-- , s <- (+):(*):ems +-- , p <- (*):(+):ems +-- ] + +main :: IO () +main = do + as <- getArgsWith sargs + let run f = reportWith as f (uncurry properties) + case concat (extra as) of + "int" -> run (fns :: Ty Int) + "int2" -> run (fns :: Ty UInt2) + "int3" -> run (fns :: Ty UInt3) + "" -> run (fns :: Ty UInt2) + +(+++) :: (Show a, Read a, Integral a) => a -> a -> a +x +++ 0 = x +0 +++ y = y +x +++ y = read (show x ++ show (abs y)) diff --git a/fitspec.cabal b/fitspec.cabal new file mode 100644 --- /dev/null +++ b/fitspec.cabal @@ -0,0 +1,170 @@ +name: fitspec +version: 0.2.0 +synopsis: refining property sets for testing Haskell programs +description: + 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. + +homepage: https://github.com/rudymatela/fitspec#readme +license: BSD3 +license-file: LICENSE +author: Rudy Matela, Colin Runciman +maintainer: Rudy Matela +category: Testing +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: README.md CREDITS.md + +source-repository head + type: git + location: https://github.com/rudymatela/fitspec + +source-repository this + type: git + location: https://github.com/rudymatela/fitspec + tag: v0.2.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 + build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell + hs-source-dirs: . + default-language: Haskell2010 + + +test-suite mutate + type: exitcode-stdio-1.0 + main-is: test-mutate.hs + hs-source-dirs: ., 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + default-language: Haskell2010 + type: exitcode-stdio-1.0 diff --git a/tests/test-derive.hs b/tests/test-derive.hs new file mode 100644 --- /dev/null +++ b/tests/test-derive.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TemplateHaskell #-} +import System.Exit (exitFailure) +import Data.List (elemIndices,sort) + +import FitSpec + +data D0 = D0 deriving (Show,Eq,Ord) +data D1 a = D1 a deriving (Show,Eq,Ord) +data D2 a b = D2 a b deriving (Show,Eq,Ord) +data D3 a b c = D3 a b c deriving (Show,Eq,Ord) +data C1 a = C11 a | C10 deriving (Show,Eq,Ord) +data C2 a b = C22 a b | C21 a | C20 deriving (Show,Eq,Ord) +data I a b = a :+ b deriving (Show,Eq,Ord) +deriveMutable ''D0 +deriveMutable ''D1 +deriveMutable ''D2 +deriveMutable ''D3 +deriveMutable ''C1 +deriveMutable ''C2 +deriveMutable ''I + +-- Those should have no effect (instance already exists): +{- uncommenting those should generate warnings +deriveMutable ''Bool +deriveMutable ''Maybe +deriveMutable ''Either +-} + +data Set a = Set [a] deriving (Show,Eq,Ord) + +instance (Ord a, Listable a) => Listable (Set a) where + tiers = consFromSet Set + +deriveMutableE [''Ord] ''Set + +main :: IO () +main = + case elemIndices False (tests 100) of + [] -> putStrLn "Tests passed!" + is -> do putStrLn ("Failed tests:" ++ show is) + exitFailure + +type Id a = a -> a + +tests n = + [ True + , allUnique $ concat $ showNewMutants1 (id :: Id D0) 7 + , allUnique $ concat $ showNewMutants1 (id :: Id (D1 UInt2)) 7 + , allUnique $ concat $ showNewMutants1 (id :: Id (D2 UInt2 UInt2)) 7 + , allUnique $ concat $ showNewMutants1 (id :: Id (D3 UInt2 UInt2 UInt2)) 7 + , allUnique $ concat $ showNewMutants1 (id :: Id (C1 UInt2)) 7 + , allUnique $ concat $ showNewMutants1 (id :: Id (C2 UInt2 UInt2)) 7 + , allUnique $ concat $ showNewMutants1 (id :: Id (I UInt2 UInt2)) 7 + , allUnique $ concat $ showNewMutants1 (id :: Id (Set UInt2)) 7 + ] + +showNewMutants1 :: (ShowMutable a, Mutable a) + => a -> Int -> [[String]] +showNewMutants1 f n = mapT (showMutantAsTuple [] f) + $ take n + $ mutiers f + +allUnique :: Ord a => [a] -> Bool +allUnique [] = True +allUnique (x:xs) = x `notElem` xs + && allUnique lesser + && allUnique greater + where lesser = filter (< x) xs + greater = filter (> x) xs diff --git a/tests/test-mutate.hs b/tests/test-mutate.hs new file mode 100644 --- /dev/null +++ b/tests/test-mutate.hs @@ -0,0 +1,194 @@ +import System.Exit (exitFailure) +import Data.List (elemIndices, sort) +import Data.Tuple (swap) + +import FitSpec +import FitSpec.Utils (contained) +import Test.Check.Error (errorToNothing, errorToFalse) +import Test.Check.Function.ListsOfPairs (functionPairs, defaultFunPairsToFunction) + + + +main :: IO () +main = + case elemIndices False tests of + [] -> putStrLn "Tests passed!" + is -> do putStrLn ("Failed tests:" ++ show is) + exitFailure + +-- NOTE: +-- the lsMutantsEqOld property only *actually* hold for functions returning +-- lists when using mutiersEq as the implementation of mutiers for [a] + +tests = map errorToFalse + [ True + + , mutiersEqOld (sort :: [Int] -> [Int]) 5 + , mutiersEqOld (sort :: [Bool] -> [Bool]) 3 -- was 5 + , mutiersEqOld (sort :: [Char] -> [Char]) 5 + , mutiersEqOld (sort :: [()] -> [()]) 10 + + , mutiersEqOld (head :: [Int] -> Int) 6 + , mutiersEqOld (head :: [Bool] -> Bool) 6 + , mutiersEqOld (tail :: [Int] -> [Int]) 6 + , mutiersEqOld (tail :: [Bool] -> [Bool]) 4 -- was 6 + + , mutiersEqOld (uncurry (++) :: ([Int],[Int]) -> [Int]) 4 + , mutiersEqOld (uncurry (++) :: ([Bool],[Bool]) -> [Bool]) 4 + , mutiersEqOld (uncurry (++) :: ([Char],[Char]) -> [Char]) 4 + + , mutiersEqOld not 10 + , mutiersEqOld (uncurry (&&)) 10 + , mutiersEqOld (uncurry (||)) 10 + + , mutiersEqOld (uncurry (+) :: (Int,Int) -> Int) 6 + , mutiersEqOld (uncurry (+) :: (Nat,Nat) -> Nat) 6 + , mutiersEqOld (uncurry (*) :: (Int,Int) -> Int) 6 + , mutiersEqOld (uncurry (*) :: (Nat,Nat) -> Nat) 6 + + -- These actually do not hold for later values in the enumeration + -- The actual way in which values are enumerated makes the enumerations + -- inherently different. + , mutiers2EqOld ((++) :: [Int] -> [Int] -> [Int]) 4 + , mutiers2EqOld ((++) :: [Bool] -> [Bool] -> [Bool]) 3 + , mutiers2EqOld ((++) :: [Char] -> [Char] -> [Char]) 4 + + , allUnique $ concat $ showOldMutants1 (sort :: [Int] -> [Int]) 7 + , allUnique $ concat $ showNewMutants1 (sort :: [Int] -> [Int]) 7 + , allUnique $ concat $ showOldMutants2 ((++) :: [Int] -> [Int] -> [Int]) 7 + , allUnique $ concat $ showNewMutants2 ((++) :: [Int] -> [Int] -> [Int]) 7 + + , allUnique $ concat $ showOldMutants1 (swap :: (Int,Int) -> (Int,Int)) 7 + , allUnique $ concat $ showNewMutants1 (swap :: (Int,Int) -> (Int,Int)) 7 + , allUnique $ concat $ showOldMutants1 (swap :: (Bool,Bool) -> (Bool,Bool)) 7 + , allUnique $ concat $ showNewMutants1 (swap :: (Bool,Bool) -> (Bool,Bool)) 7 + + , allUnique $ concat $ showOldMutants2 ((,) :: Int -> Bool -> (Int,Bool)) 7 + , allUnique $ concat $ showNewMutants2 ((,) :: Int -> Bool -> (Int,Bool)) 7 + , allUnique $ concat $ showNewMutants2 ((,) :: Bool -> Int -> (Bool,Int)) 7 + + {- + , checkBindingsOfLength 7 2 ((,) :: Bool -> Bool -> (Bool,Bool)) + , checkBindingsOfLength 7 2 ((,) :: Int -> Int -> (Int,Int)) + , checkBindingsOfLength 7 1 (swap :: (Bool,Bool) -> (Bool,Bool)) + , checkBindingsOfLength 4 1 (swap :: (Bool,Bool) -> (Bool,Bool),sort :: [Int] -> [Int]) + -} + + , holds 25 (uniqueMutants 100 :: [Bool] -> Bool) + , holds 25 (mutantsInListing 100 :: [Bool] -> Bool) + , holds 25 (listingInMutants 100 :: [Bool] -> Bool) + , holds 25 (uniqueMutants 100 :: [Int] -> Bool) + , holds 25 (mutantsInListing 100 :: [Int] -> Bool) + , holds 25 (listingInMutants 100 :: [Int] -> Bool) + , holds 25 (uniqueMutants 100 :: [()] -> Bool) + , holds 25 (mutantsInListing 100 :: [()] -> Bool) + , holds 25 (listingInMutants 100 :: [()] -> Bool) + , holds 25 (uniqueMutants 100 :: Bool -> Bool) + , holds 25 (mutantsInListing 100 :: Bool -> Bool) + , holds 25 (listingInMutants 100 :: Bool -> Bool) + , holds 25 (uniqueMutants 100 :: Int -> Bool) + , holds 25 (mutantsInListing 100 :: Int -> Bool) + , holds 25 (listingInMutants 100 :: Int -> Bool) + , holds 25 (uniqueMutants 100 :: () -> Bool) + , holds 25 (mutantsInListing 100 :: () -> Bool) + , holds 25 (listingInMutants 100 :: () -> Bool) + ] + + +uniqueMutants :: (Ord a, Listable a, Mutable a) => Int -> a -> Bool +uniqueMutants n = allUnique . take n . mutants + +mutantsInListing :: (Eq a, Listable a, Mutable a) => Int -> a -> Bool +mutantsInListing n x = take n (mutants x) `contained` list + +listingInMutants :: (Eq a, Listable a, Mutable a) => Int -> a -> Bool +listingInMutants n x = take n list `contained` mutants x + + +{- does not work as for the new interface for mutantS +checkBindingsOfLength :: (Mutable a, ShowMutable a) + => Int -> Int -> a -> Bool +checkBindingsOfLength n len f = (all . all) (bindingsOfLength len) + . concat + . take n + . mapT (mutantS f) + $ mutiers f +-} + + +bindingsOfLength :: Int -> [([String],String)] -> Bool +bindingsOfLength n = all ((== n) . length . fst) + +mutiersEqOld :: ( Show a, Show b + , Eq a, Eq b + , Listable a, Listable b + , Mutable b, ShowMutable b ) + => (a -> b) -> Int -> Bool +mutiersEqOld f n = showOldMutants1 f n == showNewMutants1 f n + + +mutiers2EqOld :: ( Eq a, Eq b, Eq c + , Show a, Show b, Show c + , Listable a, Listable b, Listable c + , Mutable c, ShowMutable b, ShowMutable c ) + => (a -> b -> c) -> Int -> Bool +mutiers2EqOld f n = showOldMutants2 f n == showNewMutants2 f n + + +showOldMutants1 :: ( Eq a, Eq b + , Show a, Show b + , Listable a, Listable b + , ShowMutable b ) + => (a -> b) -> Int -> [[String]] +showOldMutants1 f n = mapT (showMutantAsTuple [] f) + $ take n + $ mutiersOld f + +showNewMutants1 :: (ShowMutable a, Mutable a) + => a -> Int -> [[String]] +showNewMutants1 f n = mapT (showMutantAsTuple [] f) + $ take n + $ mutiers f + +showOldMutants2 :: ( Eq a, Eq b, Eq c + , Show a, Show b, Show c + , Listable a, Listable b, Listable c + , ShowMutable c ) + => (a -> b -> c) -> Int -> [[String]] +showOldMutants2 f = showOldMutants1 (uncurry f) + +showNewMutants2 :: ( Eq a, Eq b, Eq c + , Show a, Show b, Show c + , Listable a, Listable b, Mutable c + , ShowMutable c ) + => (a -> b -> c) -> Int -> [[String]] +showNewMutants2 f n = mapT (showMutantAsTuple [] uf . uncurry) + $ take n + $ mutiers f + where uf = uncurry f + +mutiersOld :: (Eq a, Eq b, Listable a, Listable b) + => (a -> b) -> [[a -> b]] +mutiersOld f = mapT (defaultFunPairsToFunction f) + $ functionPairs tiers tiers `suchThat` canonicalMutation f + +canonicalMutation :: Eq b => (a -> b) -> [(a, b)] -> Bool +-- This simple version on the line below +-- is one that does not deal with partially undefined functions. +-- canonicalMutation f = all (\(a,r) -> f a /= r) +canonicalMutation f = all different + where + -- the errorToNothing here deals partial functions (error/undefined) + -- We define that mutating undefined values is noncanonical + different (a,r) = case errorToNothing $ f a of + Just r' -> r' /= r + Nothing -> False -- for our purposes, + -- undefined is equal to anything + +allUnique :: Ord a => [a] -> Bool +allUnique [] = True +allUnique (x:xs) = x `notElem` xs + && allUnique lesser + && allUnique greater + where lesser = filter (< x) xs + greater = filter (> x) xs diff --git a/tests/test-showmutable.hs b/tests/test-showmutable.hs new file mode 100644 --- /dev/null +++ b/tests/test-showmutable.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +import System.Exit (exitFailure) +import System.Environment (getArgs) +import Data.List (elemIndices, sort) +import Data.Tuple (swap) + +import FitSpec +import FitSpec.ShowMutable +import FitSpec.PrettyPrint +import Test.Check.Error (errorToNothing) +import Test.TypeBinding + +main :: IO () +main = do + as <- System.Environment.getArgs + let n = case as of [] -> 10 + (s:_) -> read s + -- n == 10 -- 1s on zero + -- n == 32 -- 4s on zero + -- n == 100 -- 15s on zero + -- n == 200 -- 30s on zero + case elemIndices False (tests n) of + [] -> putStrLn "Tests passed!" + is -> do putStrLn ("Failed tests:" ++ show is) + exitFailure + +-- Below, some of the tests are marked as failing: +-- They simply fail because there are too many values +-- being tested (the showMutant function only approximates +-- the printing of a mutant) +-- There is a TODO in the other file related to this +-- to allow configuration of how many values should be +-- tried when enumerating the mutants. +tests n = + [ True + + , holds n $ prop_0 -:> int + , holds n $ prop_0 -:> bool + , holds n $ prop_0 -:> char + , holds n $ prop_0 -:> string + , fails n $ prop_0 -:> (int,int) + + , holds n $ prop_00 -:> (int,int) + , holds n $ prop_00 -:> (bool,int) + , holds n $ prop_00 -:> (int,bool) + , holds n $ prop_00 -:> (string,char) + , holds n $ prop_00 -:> (char,string) + + , h1 $ id -:> int + , h1 $ id -:> bool + , h1 $ id -:> (int,int) + , h1 $ id -:> (bool,int) + , h1 $ id -:> (int,bool) + , h1 $ id -:> (bool,bool) + , h1 $ id -:> (int,int,int) + , h1 $ id -:> (int,(int,int)) + , h1 $ id -:> ((int,int),int) + , h1 $ const True -:> int -- fails (500 tests)! + , h1 $ const (0::Int) -:> bool + , h1 $ swap -:> (int,bool) + , h1 $ swap -:> (bool,int) + , h1 $ swap -:> (int,(int,int)) + , h1 $ swap -:> ((int,int),int) + + , h2 $ const -: int >- int >- und + , h2 $ const -: int >- bool >- und + , h2 $ const -: bool >- int >- und -- fails (1000 tests)! + , h2 $ (+) -:> int + , hI $ (+) -:> int + , h2 $ (*) -:> int + , h2 $ (&&) + , h2 $ (||) + , h2 $ (:) -:> int -- fails (2000 tests)! + , h2 $ (++) -:> [int] -- fails (3000 tests)! + + , h11 (id -:> int) (id ->: bool) + , h11 (id -:> bool) (id ->: int) + , h11 (swap -:> ((int,int),int)) (swap ->: (int,(int,int))) + + , h111 (id -:> int) (id ->: bool) (id ->: char) + , h111 (id -:> bool) (id ->: char) (id ->: int) + , h111 (swap -:> ((int,int),(int,int))) + (swap -:> ((int,int),int)) + (swap -:> (int,(int,int))) + + , h11' (id -:> int) (id ->: bool) (id ->: char) + , h11' (id -:> bool) (id ->: char) (id ->: int) + , h11' (swap -:> ((int,int),(int,int))) + (swap -:> ((int,int),int)) + (swap -:> (int,(int,int))) + ] + where h1 = holds n . prop_1 + h2 = holds n . prop_2 + hI = holds n . prop_I + h11 f = holds n . prop_11 f + h111 f g = holds n . prop_111 f g + h11' f g = holds n . prop_11' f g + +-- prop_N, asserts the format of a mutation of a value of N arguments +-- prop_MN, asserts the format of a pair of values of M and N arguments +-- prop_MNO, asserts the format of a triple of values + +prop_0 :: (Eq a, Show a, Listable a, ShowMutable a) + => a -> a -> Bool +prop_0 x x' | x == x' = s == "x" + | otherwise = s == show x' + where s = showMutantAsTuple ["x"] x x' + +prop_00 :: ( Eq a, Show a, Listable a, ShowMutable a + , Eq b, Show b, Listable b, ShowMutable b ) + => (a,b) -> (a,b) -> Bool +prop_00 (x,y) (x',y') | x == x' && y == y' = s == "(x,y)" + | x == x' = s == "(x," ++ show y' ++ ")" + | y == y' = s == "(" ++ show x' ++ ",y)" + | otherwise = s == "(" ++ show x' + ++ "," ++ show y' ++ ")" + where s = showMutantAsTuple ["x","y"] (x,y) (x',y') + +prop_1 :: ( Eq a, Show a, Listable a, ShowMutable a + , Eq b, Show b, Listable b, ShowMutable b ) + => (a->b) -> a -> b -> Bool +prop_1 f x fx = fx /= f x + ==> showMutantAsTuple ["f x"] f (mutate f x fx) == showMutantF "f" x fx + && showMutantDefinition ["f x"] f (mutate f x fx) == showMutantB "f" x fx + +prop_11 :: ( Eq a, Show a, Listable a, ShowMutable a + , Eq b, Show b, Listable b, ShowMutable b + , Eq c, Show c, Listable c, ShowMutable c + , Eq d, Show d, Listable d, ShowMutable d ) + => (a->b) -> (c->d) -> a -> b -> c -> d -> Bool +prop_11 f g x fx y gy = fx /= f x && gy /= g y + ==> showMutantAsTuple ["f x","g x"] (f,g) (mutate f x fx, mutate g y gy) + == showTuple [showMutantF "f" x fx, showMutantF "g" y gy] + && showMutantDefinition ["f x","g x"] (f,g) (mutate f x fx, mutate g y gy) + == concat [showMutantB "f" x fx, showMutantB "g" y gy] + +prop_111 :: ( Eq a, Show a, Listable a, ShowMutable a + , Eq b, Show b, Listable b, ShowMutable b + , Eq c, Show c, Listable c, ShowMutable c + , Eq d, Show d, Listable d, ShowMutable d + , Eq e, Show e, Listable e, ShowMutable e + , Eq f, Show f, Listable f, ShowMutable f ) + => (a->b) -> (c->d) -> (e->f) -> a -> b -> c -> d -> e -> f -> Bool +prop_111 f g h x fx y gy z hz = fx /= f x + && gy /= g y + && hz /= h z + ==> showMutantAsTuple ["f x","g x","h x"] (f,g,h) + ( mutate f x fx + , mutate g y gy + , mutate h z hz ) + == showTuple [ showMutantF "f" x fx + , showMutantF "g" y gy + , showMutantF "h" z hz ] + && showMutantDefinition ["f x","g x","h x"] (f,g,h) + ( mutate f x fx + , mutate g y gy + , mutate h z hz ) + == concat [ showMutantB "f" x fx + , showMutantB "g" y gy + , showMutantB "h" z hz ] + +prop_11' :: ( Eq a, Show a, Listable a, ShowMutable a + , Eq b, Show b, Listable b, ShowMutable b + , Eq c, Show c, Listable c, ShowMutable c + , Eq d, Show d, Listable d, ShowMutable d + , Eq e, Show e, Listable e, ShowMutable e + , Eq f, Show f, Listable f, ShowMutable f ) + => (a->b) -> (c->d) -> (e->f) -> a -> b -> c -> d -> e -> f -> Bool +prop_11' f g h x fx y gy z hz = fx /= f x + && gy /= g y + && hz /= h z + ==> showMutantAsTuple ["f x","g x","h x"] (f,(g,h)) + ( mutate f x fx + , ( mutate g y gy + , mutate h z hz ) ) + == showTuple [ showMutantF "f" x fx + , showTuple [ showMutantF "(??)" y gy + , showMutantF "(??)" z hz ] ] + && showMutantDefinition ["f x","g x","h x"] (f,(g,h)) + ( mutate f x fx + , ( mutate g y gy + , mutate h z hz ) ) + == concat [ showMutantB "f" x fx + , "g' = " + `beside` showTuple [ showMutantF "(??)" y gy + , showMutantF "(??)" z hz ] ] + +prop_2 :: ( Eq a, Show a, Listable a, ShowMutable a + , Eq b, Show b, Listable b, ShowMutable b + , Eq c, Show c, Listable c, ShowMutable c ) + => (a->b->c) -> a -> b -> c -> Bool +prop_2 f x y fxy = fxy /= f x y ==> + showMutantAsTuple ["f x y"] f (mutate2 f x y fxy) == showMutantF2 "f" x y fxy && + showMutantDefinition ["f x y"] f (mutate2 f x y fxy) == showMutantB2 "f" x y fxy + + +prop_I :: ( Eq a, Show a, Listable a, ShowMutable a + , Eq b, Show b, Listable b, ShowMutable b + , Eq c, Show c, Listable c, ShowMutable c ) + => (a->b->c) -> a -> b -> c -> Bool +prop_I f x y fxy = fxy /= f x y ==> + showMutantAsTuple ["x + y"] f (mutate2 f x y fxy) == showMutantI "+" x y fxy && + showMutantDefinition ["x + y"] f (mutate2 f x y fxy) == showMutantBI "+" x y fxy + +mutate :: Eq a => (a -> b) -> a -> b -> (a -> b) +mutate f x y x' | x' == x = y + | otherwise = f x' + +mutate2 :: (Eq a, Eq b) => (a -> b -> c) -> a -> b -> c -> (a -> b -> c) +mutate2 f x y z = curry (mutate (uncurry f) (x,y) z) + +-- | Show a mutant of a function of one argument +showMutantF :: (Show a, Show b) + => String -> a -> b -> String +showMutantF f x y = "\\x -> case x of\n" + ++ " " ++ show x ++ " -> " ++ show y ++ "\n" + ++ " _ -> " ++ f ++ " x\n" + +-- | Show a mutant of a function of two arguments +showMutantF2 :: (Show a, Show b, Show c) + => String -> a -> b -> c -> String +showMutantF2 f x y z = "\\x y -> case (x,y) of\n" + ++ " (" ++ show x ++ "," ++ show y ++ ") -> " + ++ show z ++ "\n" + ++ " _ -> " ++ f ++ " x y\n" + +showMutantB :: (Show a, Show b) + => String -> a -> b -> String +showMutantB f x fx = table " " + [ [f ++ "'", show x, "=", show fx] + , [f ++ "'", "x", "=", f ++ " x"] ] + +showMutantB2 :: (Show a, Show b, Show c) + => String -> a -> b -> c -> String +showMutantB2 f x y fxy = table " " + [ [f ++ "'", show x, show y, "=", show fxy] + , [f ++ "'", "x", "y", "=", f ++ " x y"] ] + +-- | Show a mutant of an infix +showMutantI :: (Show a, Show b, Show c) + => String -> a -> b -> c -> String +showMutantI o x y z = "\\x y -> case (x,y) of\n" + ++ " (" ++ show x ++ "," ++ show y ++ ") -> " + ++ show z ++ "\n" + ++ " _ -> x " ++ o ++ " y\n" + +showMutantBI :: (Show a, Show b, Show c) + => String -> a -> b -> c -> String +showMutantBI o x y fxy = table " " + [ [show x, o ++ "-", show y, "=", show fxy] + , ["x", o ++ "-", "y", "=", "x " ++ o ++ " y"] ]