fitspec (empty) → 0.2.0
raw patch · 35 files changed
+3875/−0 lines, 35 filesdep +basedep +cmdargsdep +leanchecksetup-changed
Dependencies added: base, cmdargs, leancheck, pretty, template-haskell
Files
- CREDITS.md +22/−0
- FitSpec.hs +106/−0
- FitSpec/Derive.hs +161/−0
- FitSpec/Dot.hs +70/−0
- FitSpec/Engine.hs +278/−0
- FitSpec/Main.hs +69/−0
- FitSpec/Most.hs +2/−0
- FitSpec/Mutable.hs +186/−0
- FitSpec/Mutable/Tuples.hs +62/−0
- FitSpec/PrettyPrint.hs +141/−0
- FitSpec/Report.hs +246/−0
- FitSpec/ShowMutable.hs +362/−0
- FitSpec/ShowMutable/Tuples.hs +98/−0
- FitSpec/TestTypes.hs +43/−0
- FitSpec/Utils.hs +133/−0
- LICENSE +30/−0
- README.md +151/−0
- Setup.hs +2/−0
- bench/avltrees.hs +79/−0
- bench/bools.hs +56/−0
- bench/digraphs.hs +166/−0
- bench/heaps.hs +109/−0
- bench/id.hs +34/−0
- bench/list.hs +73/−0
- bench/mergeheaps.hs +105/−0
- bench/pretty.hs +56/−0
- bench/sets.hs +64/−0
- bench/setsofsets.hs +69/−0
- bench/sieve.hs +77/−0
- bench/sorting.hs +71/−0
- bench/spring.hs +70/−0
- fitspec.cabal +170/−0
- tests/test-derive.hs +69/−0
- tests/test-mutate.hs +194/−0
- tests/test-showmutable.hs +251/−0
+ CREDITS.md view
@@ -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).
+ FitSpec.hs view
@@ -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
+ FitSpec/Derive.hs view
@@ -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
+ FitSpec/Dot.hs view
@@ -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
+ FitSpec/Engine.hs view
@@ -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
+ FitSpec/Main.hs view
@@ -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
+ FitSpec/Most.hs view
@@ -0,0 +1,2 @@+-- | Deprecated, import 'FitSpec' instead+module FitSpec.Most (module FitSpec) where import FitSpec
+ FitSpec/Mutable.hs view
@@ -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))
+ FitSpec/Mutable/Tuples.hs view
@@ -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))
+ FitSpec/PrettyPrint.hs view
@@ -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
+ FitSpec/Report.hs view
@@ -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
+ FitSpec/ShowMutable.hs view
@@ -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
+ FitSpec/ShowMutable/Tuples.hs view
@@ -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' ]
+ FitSpec/TestTypes.hs view
@@ -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
+ FitSpec/Utils.hs view
@@ -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)
+ LICENSE view
@@ -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.
+ README.md view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/avltrees.hs view
@@ -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
+ bench/bools.hs view
@@ -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
+ bench/digraphs.hs view
@@ -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 <refinement-id>+--+--+-- 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
+ bench/heaps.hs view
@@ -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
+ bench/id.hs view
@@ -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)
+ bench/list.hs view
@@ -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+
+ bench/mergeheaps.hs view
@@ -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
+ bench/pretty.hs view
@@ -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
+ bench/sets.hs view
@@ -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)
+ bench/setsofsets.hs view
@@ -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)
+ bench/sieve.hs view
@@ -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<y && strictlyOrdered (y:xs)++elemO :: Ord a => 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
+ bench/sorting.hs view
@@ -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
+ bench/spring.hs view
@@ -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))
+ fitspec.cabal view
@@ -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 <rudy@matela.com.br>+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
+ tests/test-derive.hs view
@@ -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
+ tests/test-mutate.hs view
@@ -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
+ tests/test-showmutable.hs view
@@ -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"] ]