fitspec 0.2.2 → 0.3.0

raw patch · 47 files changed

+2058/−2033 lines, 47 filesdep ~leancheckPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: leancheck

API changes (from Hackage documentation)

Files

• FitSpec.hs +0/−106
• FitSpec/Derive.hs +0/−172
• FitSpec/Dot.hs +0/−70
• FitSpec/Engine.hs +0/−278
• FitSpec/Main.hs +0/−69
• FitSpec/Most.hs +0/−2
• FitSpec/Mutable.hs +0/−186
• FitSpec/Mutable/Tuples.hs +0/−62
• FitSpec/PrettyPrint.hs +0/−141
• FitSpec/Report.hs +0/−246
• FitSpec/ShowMutable.hs +0/−362
• FitSpec/ShowMutable/Tuples.hs +0/−98
• FitSpec/TestTypes.hs +0/−43
• FitSpec/Utils.hs +0/−133
• README.md +1/−1
• TODO.md +0/−6
• bench/avltrees.hs +2/−2
• bench/bools.hs +1/−1
• bench/digraphs.hs +1/−1
• bench/heaps.hs +2/−2
• bench/id.hs +1/−1
• bench/list.hs +1/−1
• bench/mergeheaps.hs +2/−2
• bench/pretty.hs +1/−1
• bench/sets.hs +2/−2
• bench/setsofsets.hs +2/−2
• bench/sieve.hs +1/−1
• bench/sorting.hs +1/−1
• bench/spring.hs +1/−1
• fitspec.cabal +39/−33
• src/Test/FitSpec.hs +106/−0
• src/Test/FitSpec/Derive.hs +172/−0
• src/Test/FitSpec/Dot.hs +70/−0
• src/Test/FitSpec/Engine.hs +278/−0
• src/Test/FitSpec/Main.hs +69/−0
• src/Test/FitSpec/Mutable.hs +186/−0
• src/Test/FitSpec/Mutable/Tuples.hs +62/−0
• src/Test/FitSpec/PrettyPrint.hs +141/−0
• src/Test/FitSpec/Report.hs +246/−0
• src/Test/FitSpec/ShowMutable.hs +362/−0
• src/Test/FitSpec/ShowMutable/Tuples.hs +98/−0
• src/Test/FitSpec/TestTypes.hs +43/−0
• src/Test/FitSpec/Utils.hs +133/−0
• tests/test-derive.hs +2/−2
• tests/test-mutate.hs +2/−2
• tests/test-showmutable.hs +3/−3
• tests/test-utils.hs +27/−0

@@ -1,106 +0,0 @@--- | FitSpec: refining property-sets for functional testing------ FitSpec provides automated assistance in the task of refining test properties--- for Haskell functions.  FitSpec tests mutant variations of functions under test--- against a given property set, recording any surviving mutants that pass all--- tests.  FitSpec then reports:------ * /surviving mutants:/---   indicating incompleteness of properties,---   prompting the user to amend a property or to add a new one;--- * /conjectures:/---   indicating redundancy in the property set,---   prompting the user to remove properties so to reduce the cost of testing.------ Example, refining a @sort@ specification:------ > import FitSpec--- > import Data.List (sort)--- >--- > properties sort =--- >   [ property $ \xs   -> ordered (sort xs)--- >   , property $ \xs   -> length (sort xs) == length xs--- >   , property $ \x xs -> elem x (sort xs) == elem x xs--- >   , property $ \x xs -> notElem x (sort xs) == notElem x xs--- >   , property $ \x xs -> minimum (x:xs) == head (sort (x:xs))--- >   ]--- >   where--- >   ordered (x:y:xs) = x <= y && ordered (y:xs)--- >   ordered _        = True--- >--- > main = mainWith args { names = ["sort xs"]--- >                      , nMutants = 4000--- >                      , nTests   = 4000--- >                      , timeout  = 0--- >                      }--- >                 (sort::[Word2]->[Word2])------ The above program reports the following:------ > Apparent incomplete and non-minimal specification based on--- > 4000 test cases for each of properties 1, 2, 3, 4 and 5--- > for each of 4000 mutant variations.--- >--- > 3 survivors (99% killed), smallest:--- >   \xs -> case xs of--- >            [0,0,1] -> [0,1,1]--- >            _ -> sort xs--- >--- > apparent minimal property subsets:  {1,2,3} {1,2,4}--- > conjectures:  {3}    =  {4}     96% killed (weak)--- >               {1,3} ==> {5}     98% killed (weak)-module FitSpec-  (-  -- * Encoding properties-    Property-  , property--  -- * Configuring reports-  , Args (..), ShowMutantAs (..)-  , args-  , fixargs--  -- * Reporting results-  , report-  , reportWith-  , reportWithExtra--  -- ** Parsing command line arguments-  , mainWith-  , defaultMain-  , getArgs-  , getArgsWith--  -- * Mutable types-  , Mutable (..)-  , mutiersEq--  , ShowMutable (..)-  , mutantSEq-  , showMutantAsTuple-  , showMutantDefinition-  , showMutantNested-  , showMutantBindings--  -- * Automatic derivation-  , deriveMutable-  , deriveMutableE--  -- * Re-export modules-  , module FitSpec.TestTypes-  , module Test.LeanCheck-  )-where--import FitSpec.Engine-import FitSpec.Report-import FitSpec.Main--import FitSpec.Mutable-import FitSpec.Mutable.Tuples-import FitSpec.ShowMutable-import FitSpec.ShowMutable.Tuples-import FitSpec.Derive-import FitSpec.TestTypes--import Test.LeanCheck

@@ -1,172 +0,0 @@--- | Experimental module for deriving Mutable instances------ Needs GHC and Template Haskell--- (tested on GHC 7.4, 7.6, 7.8, 7.10 and 8.0)------ Despite Mutable instances being actually very simple, this module can be--- used to derive those.  However, it will not work on all cases: when that--- happens, you should write your instances manually.-{-# LANGUAGE TemplateHaskell, CPP #-}-module FitSpec.Derive-  ( deriveMutable-  , deriveMutableE-  , module FitSpec.Mutable-  , module FitSpec.ShowMutable-  , module Test.LeanCheck-  )-where--import FitSpec.Mutable-import FitSpec.ShowMutable--import Test.LeanCheck-import Language.Haskell.TH-import Control.Monad (when, unless, liftM, liftM2)--#if __GLASGOW_HASKELL__ < 706--- reportWarning was only introduced in GHC 7.6 / TH 2.8-reportWarning :: String -> Q ()-reportWarning = report False-#endif--deriveListableIfNeeded :: Name -> DecsQ-deriveListableIfNeeded t = do-  is <- t `isInstanceOf` ''Listable-  if is-    then return []-    else deriveListable t---- | Derives a Mutable instance for a given type ('Name').-deriveMutable :: Name -> DecsQ-deriveMutable = deriveMutableE []---- | Derives a Mutable instance for a given type ('Name') using a given context---   for all type variables.-deriveMutableE :: [Name] -> Name -> DecsQ-deriveMutableE cs t = do-  is <- t `isInstanceOf` ''Mutable-  if is-    then do-      reportWarning $ "Instance Mutable " ++ show t-                   ++ " already exists, skipping derivation"-      return []-    else do-      cd <- canDeriveMutable t-      unless cd (fail $ "Unable to derive Mutable " ++ show t)-      liftM2 (++) (deriveListableIfNeeded t) (reallyDeriveMutable cs t)---- | Checks whether it is possible to derive a Mutable instance.-canDeriveMutable :: Name -> Q Bool-canDeriveMutable t = (t `isInstanceOf` ''Eq)-                 &&& (t `isInstanceOf` ''Show)-  where (&&&) = liftM2 (&&)--reallyDeriveMutable :: [Name] -> Name -> DecsQ-reallyDeriveMutable cs t = do-  (nt,vs) <- normalizeType t-#if __GLASGOW_HASKELL__ >= 710-  cxt <- sequence [ [t| $(conT c) $(return v) |]-#else-  cxt <- sequence [ classP c [return v]-#endif-                  | v <- vs, c <- ''Eq:''Listable:''Show:cs ]-#if __GLASGOW_HASKELL__ >= 708-  cxt |=>| [d| instance Mutable $(return nt)-                 where mutiers = mutiersEq-               instance ShowMutable $(return nt)-                 where mutantS = mutantSEq |]-#else-  return [ InstanceD-             cxt-             (AppT (ConT ''Mutable) nt)-             [ValD (VarP 'mutiers) (NormalB (VarE 'mutiersEq)) []]-         , InstanceD-             cxt-             (AppT (ConT ''ShowMutable) nt)-             [ValD (VarP 'mutantS) (NormalB (VarE 'mutantSEq)) []]-         ]-#endif----- * Template haskell utilities---- Normalizes a type by applying it to necessary type variables, making it--- accept "zero" parameters.  The normalized type is tupled with a list of--- necessary type variables.------ Suppose:------ > data DT a b c ... = ...------ Then, in pseudo-TH:------ > normalizeType [t|DT|] == Q (DT a b c ..., [a, b, c, ...])-normalizeType :: Name -> Q (Type, [Type])-normalizeType t = do-  ar <- typeArity t-  vs <- newVarTs ar-  return (foldl AppT (ConT t) vs, vs)-  where-    newNames :: [String] -> Q [Name]-    newNames = mapM newName-    newVarTs :: Int -> Q [Type]-    newVarTs n = liftM (map VarT)-               $ newNames (take n . map (:[]) $ cycle ['a'..'z'])---- Normalizes a type by applying it to units (`()`) while possible.------ > normalizeTypeUnits ''Int    === [t| Int |]--- > normalizeTypeUnits ''Maybe  === [t| Maybe () |]--- > normalizeTypeUnits ''Either === [t| Either () () |]-normalizeTypeUnits :: Name -> Q Type-normalizeTypeUnits t = do-  ar <- typeArity t-  return (foldl AppT (ConT t) (replicate ar (TupleT 0)))---- Given a type name and a class name,--- returns whether the type is an instance of that class.-isInstanceOf :: Name -> Name -> Q Bool-isInstanceOf tn cl = do-  ty <- normalizeTypeUnits tn-  isInstance cl [ty]---- | Given a type name, return the number of arguments taken by that type.--- Examples in partially broken TH:------ > arity ''Int        === Q 0--- > arity ''Int->Int   === Q 0--- > arity ''Maybe      === Q 1--- > arity ''Either     === Q 2--- > arity ''Int->      === Q 1------ This works for Data's and Newtype's and it is useful when generating--- typeclass instances.-typeArity :: Name -> Q Int-typeArity t = do-  ti <- reify t-  return . length $ case ti of-#if __GLASGOW_HASKELL__ < 800-    TyConI (DataD    _ _ ks _ _) -> ks-    TyConI (NewtypeD _ _ ks _ _) -> ks-#else-    TyConI (DataD    _ _ ks _ _ _) -> ks-    TyConI (NewtypeD _ _ ks _ _ _) -> ks-#endif-    _                            -> error $ "error (arity): symbol "-                                         ++ show t-                                         ++ " is not a newtype or data"---- Append to instance contexts in a declaration.------ > sequence [[|Eq b|],[|Eq c|]] |=>| [t|instance Eq a => Cl (Ty a) where f=g|]--- > == [t| instance (Eq a, Eq b, Eq c) => Cl (Ty a) where f = g |]-(|=>|) :: Cxt -> DecsQ -> DecsQ-c |=>| qds = do ds <- qds-                return $ map (`ac` c) ds-#if __GLASGOW_HASKELL__ < 800-  where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds-        ac d                   _  = d-#else-  where ac (InstanceD o c ts ds) c' = InstanceD o (c++c') ts ds-        ac d                     _  = d-#endif

@@ -1,70 +0,0 @@--- | Generate dotfiles (graphviz)-module FitSpec.Dot where--import FitSpec-import FitSpec.Engine-import FitSpec.Utils-import Data.List---- | Given a list of pairs of property groups and their implications,---   return implications between groups (transitive cases are ommitted).-groupImplications :: Eq i => [([[i]], [i])] -> [([[i]],[[i]])]-groupImplications [] = []-groupImplications (n:ns) = [ (fst n, fst n')-                           | n' <- filterU (not ... implies)-                                 . filter (n `implies`)-                                 $ ns-                           ] ++ groupImplications ns-  where actual (iss,is) = foldr union [] iss `union` is-        n `implies` m = actual n `contains` actual m--isObvious :: Eq i => [[i]] -> [[i]] -> Bool-isObvious as bs = or [ a `contains` b-                     | a <- as-                     , b <- bs ]--attachObviousness :: Eq i => [([[i]], [[i]])] -> [([[i]],[[i]],Bool)]-attachObviousness = map attachObviousness'-  where attachObviousness' (as,bs) = (as,bs,isObvious as bs)----- | Given a list of relations, generate a graphviz graph containing those relations.---   Generate a dotfile from implications between groups.-genDotfileFromGI :: Show i-                 => [([[i]],[[i]],Bool)]-                 -> String-genDotfileFromGI = (\s -> "digraph G {\n" ++ s ++ "}\n")-                 . unlines-                 . map showEntry-  where showG = unwords . map show-        showEntry (iss,jss,p) = "\"" ++ showG iss ++ "\" -> \""-                                     ++ showG jss ++ "\""-                             ++ if p-                                  then " [ color = grey ]"-                                  else ""---- | Equivalent to 'getResults' but returns a dotfile-getDotfile :: (Mutable a)-           => [a]-           -> Int -> Int -> a -> (a -> [Property])-           -> String-getDotfile ems m n f ps = genDotfileFromGI-                        . attachObviousness-                        . groupImplications-                        . map (\r -> (sets r, implied r))-                        $ getResultsExtra ems f ps m n---- | Equivalent to report, but writes a dotfile to a file-writeDotfile :: (Mutable a)-             => String-             -> [a]-             -> Int -> Int -> a -> (a -> [Property])-             -> IO ()-writeDotfile fn ems m n f = writeFile fn . getDotfile ems m n f---- | Equivalent to report, but writes a dotfile to stdout-putDotfile :: (Mutable a)-           => [a]-           -> Int -> Int -> a -> (a -> [Property])-           -> IO ()-putDotfile ems m n f = putStr . getDotfile ems m n f

@@ -1,278 +0,0 @@--- | FitSpec: refining property-sets for functional testing------ This is the main engine, besides FitSpec.Mutable.-module FitSpec.Engine-  ( property-  , Property--  , getResults-  , getResultsExtra-  , getResultsExtraTimeout-  , Result (..)-  , Results--  , propertiesNTests-  , propertiesTestsExhausted-  , propertiesToMap-  , propertiesHold-  , propertiesCE--  , minimal-  , complete--  , reduceImplications-  , filterNonCanon-  , Conjecture (..)-  , conjectures-  )-where--import Test.LeanCheck.Error-import FitSpec.Utils-import Data.Maybe (catMaybes, listToMaybe)-import Data.List ((\\),union,transpose)-import FitSpec.Mutable---- | An encoded representation of a property suitable for use by FitSpec.------ Each list of strings is a printable representation of one possible choice of--- argument values for the property.  Each boolean indicate whether the--- property holds for this choice.-type Property = [([String],Bool)]-type Properties = [Property]---- | Given a 'Testable' type (as defined by 'Test.Check'), returns a 'Property'.------ This function should be used on every property to create a property list to--- be passed to 'report', 'reportWith', 'mainDefault' or 'mainWith'.------ > property $ \x y -> x + y < y + (x::Int)-property :: Testable a => a -> Property-property = results--propertyHolds :: Int -> Property -> Bool-propertyHolds n = all snd . take n--propertyCE :: Int -> Property -> Maybe String-propertyCE n = listToMaybe . map (unwords . fst) . filter (not . snd) . take n--propertiesToMap :: [Property] -> Int -> [Bool]-propertiesToMap ps n = map (propertyHolds n) ps--propertiesHold :: Int -> [Property] -> Bool-propertiesHold n = all (propertyHolds n)--propertiesCE :: Int -> [Property] -> Maybe String-propertiesCE n = listToMaybe-               . catMaybes-               . zipWith (\n -> fmap ((show n ++ ":  ") ++)) [1..]-               . map (propertyCE n)--propertiesNTests :: Int -> [Property] -> [Int]-propertiesNTests n = map (length . take n)--propertiesTestsExhausted :: Int -> [Property] -> [Bool]-propertiesTestsExhausted n = map (<= n) . propertiesNTests (n+1)--filterNonCanon :: [Result a] -> [Result a]-filterNonCanon [] = []-filterNonCanon (r:rs) = (r:)-                      . filterNonCanon-                      . filter (not . null . sets)-                      . map (updateSets removeNonCanon)-                      $ rs-  where removeNonCanon = filter (not . (\p' -> (p' `contains`) `any` tail (sets r)))-        updateSets f r = r { sets = f (sets r) }--reduceImplications :: [Result a] -> [Result a]-reduceImplications [] = []-reduceImplications (r:rs) = r : map (r `reduce`) (reduceImplications rs)-  where r `reduce` r' = if or [s `contained` s' | s <- sets r, s' <- sets r']-                          then r' { implied = implied r' \\ implied r }-                          else r'----- | A line of result for a single equivalence class of properties---   with the exact same surviving mutants.-data Result a = Result-  { sets             :: [[Int]] -- ^ property-sets in the equivalence class-  , implied          :: [Int]   -- ^ properties implied by this class-  , survivors        :: [a]     -- ^ list of surviving mutants-  , smallestSurvivor :: Maybe a -- ^ smallest surviving mutant, if any-  , nSurvivors       :: Int -- ^ number of surviving mutants-  , nKilled          :: Int -- ^ number of killed mutants-  , totalMutants     :: Int -- ^ total number of mutants generated and tested-  , score            :: Int -- ^ percentage of killed mutants, 0-100-  , maxTests         :: Int -- ^ Requested number of tests (same for all rs.)-  , mutantsExhausted :: Bool -- ^ mutants were exhausted-  }-type Results a = [Result a]----- | Return minimality and completeness results.  See 'report'.-getResults :: (Mutable a)-           => a -> (a -> [Property]) -> Int -> Int-           -> Results a-getResults = getResultsExtra []--getResultsExtra :: (Mutable a)-                => [a]-                -> a -> (a -> [Property]) -> Int -> Int-                -> Results a-getResultsExtra ems f ps nms nts = map (uncurry $ processRawResult mex nts)-                                 $ getRawResults is pmap ms-  where is = [1..(length $ ps f)]-        pmap f = propertiesToMap (ps f) nts-        ms' = take (nms+1) (tail $ mutants f)-        mex = length ms' <= nms-        ms = take nms ms' ++ ems--getResultsExtraTimeout :: (Mutable a)-                       => Int-                       -> [a]-                       -> a -> (a -> [Property]) -> Int -> Int-                       -> IO (Results a)-getResultsExtraTimeout 0 ems f ps m n = return $ getResultsExtra ems f ps m n-getResultsExtraTimeout t ems f ps nm0 nt0 = lastTimeout t resultss-  where-    resultss = map fst-             $ takeWhileIncreasingOn ((totalMutants . head) *** id)-             [ (getResultsExtra ems f ps nm nt, propertiesNTests nt $ ps f)-             | (nm,nt) <- iterate (incHalf *** incHalf) (nm0,nt0) ]-    incHalf x = x + x `div` 2--processRawResult :: Bool -> Int -> [[Int]] -> [(a,Bool)] -> Result a-processRawResult mex nt iss mhs = Result-  { sets      = relevantPropertySets iss-  , implied   = relevantImplications iss-  , survivors = ms-  , smallestSurvivor = listToMaybe ms-  , nSurvivors   = ns-  , nKilled      = nk-  , totalMutants = nm-  , score        = nk*100 `div` nm-  , maxTests     = nt-  , mutantsExhausted = mex-  }-  where ms = [m | (m,h) <- mhs, h]-        nm = length mhs-        ns = length ms-        nk = nm - ns--minimal :: Results a -> Bool-minimal (r:_) = null (implied r)-             && length (sets r) == 1--complete :: Results a -> Bool-complete (r:_) = nSurvivors r == 0--relevantPropertySets :: Eq i => [[i]] -> [[i]]-relevantPropertySets = filterU (not ... contained) . sortOn length--relevantImplications :: Eq i => [[i]] -> [i]-relevantImplications iss = foldr union [] iss-                        \\ foldr union [] (relevantPropertySets iss)---- | Returns a description of property sets, grouping the ones that had the---   same surviving mutants.  The resulting list is ordered starting with the---   least surviving mutants to the most surviving mutants.------ Arguments:------ * @is@: list of property ids (@length is == length (pmap x)@)------ * @pmap@: a property map------ * @ms@: list of mutants to apply to the property map------ Return a list of tuples containing:------   * a list of property sets---   * a list of mutants paired with booleans indicating whether each survived-getRawResults :: [i] -> (a -> [Bool]) -> [a] -> [([[i]],[(a,Bool)])]-getRawResults is ps ms = (id *** (zip ms)) `map` getRawResults' is ps ms---- | Returns a description of property sets, grouping the ones that had the---   same surviving mutants.  The resulting list is ordered starting with the---   least surviving mutants to the most surviving mutants.------ Arguments:------ * @is@: list of property ids (@length is == length (pmap x)@)------ * @pmap@: a property map------ * @ms@: list of mutants to apply to the property map------ Return a list of tuples containing:------   * a list of property sets---   * a boolean list indicating whether a given mutant survived-getRawResults' :: [i] -> (a -> [Bool]) -> [a] -> [([[i]],[Bool])]-getRawResults' is pmap = sortOn (count id . snd)-                       . sortAndGroupFstBySnd-                       . zip (subsets is)-                       . transpose-                       . map (compositions . pmap)---- | 'nSurv' @props fs@ returns the number of values that match---   compositions of properties on the property map.------ * @props@ should be a function from a value to a list of properties that---   match that value (in the case of functions, functions that "survive" those---   properties).------ * @fs@ is a list of values to be mapped over by @props@------ > length (nSurvivors props fs)  ==  2 ^ (length (props fs))------ This function is otherwise unused in this file.  It is just a simpler--- version of 'pssurv' to serve as documentation.-nSurv :: (a -> [Bool]) -> [a] -> [Int]-nSurv props = map (count id)-            . transpose-            . map (compositions . props)---data Conjecture = Conjecture-  { isEq        :: Bool-  , isIm        :: Bool-  , cleft       :: [Int]-  , cright      :: [Int]-  , cscore      :: Int-  , cnKilled    :: Int-  , cnSurvivors :: Int-  } deriving Show--conjectures :: [Result a] -> [Conjecture]-conjectures = concatMap conjectures1-            . sortOn (abs . (50-) . score) -- closer to 50 the better!-            . reduceImplications-            . filterNonCanon-            . reverse--conjectures1 :: Result a -> [Conjecture]-conjectures1 r = [ p `eq` p' | p' <- ps ]-              ++ [ p `im` i  | (not.null) i ]-  where-    (p:ps) = sets r-    i      = implied r-    eq     = conj True-    im     = conj False-    conj isE p p' = Conjecture-      { isEq        = isE-      , isIm        = not isE-      , cleft       = p-      , cright      = p'-      , cscore      = score r-      , cnKilled    = nKilled r-      , cnSurvivors = nSurvivors r-      }--- TODO: improve implication score--- implication score can be improved by--- by separating each implication on its own:---   [4] ==> [2,3]--- become---   [4] ==> [2]---   [4] ==> [3]--- Then evaluating percentage of occurences of True ==> True and other cases

@@ -1,69 +0,0 @@--- | Exports "main" functions for FitSpec.--- They work exactly by 'report' and 'reportWith' but can be customized by--- command line arguments.------ > main = mainWith args { ... } functions properties-{-# Language DeriveDataTypeable, StandaloneDeriving #-}-module FitSpec.Main-  ( mainWith-  , defaultMain-  , getArgs-  , getArgsWith-  , module FitSpec.Report -- deprecated export, remove later-  )-where--import FitSpec.Report-import System.Console.CmdArgs hiding (args)-import qualified System.Console.CmdArgs as CA (args)-import Control.Monad (liftM)-import FitSpec.Mutable-import FitSpec.ShowMutable--deriving instance Data ShowMutantAs-deriving instance Data Args-deriving instance Typeable ShowMutantAs-deriving instance Typeable Args--annotate :: Args -> Args-annotate as = Args-  { nMutants     = nMutants     as  &= name "m"-      &= help "(starting) number of function mutations"-  , nTests       = nTests       as  &= name "n"-      &= help "(starting) number of test values (each prop.)"-  , timeout      = timeout      as  &= name "t" &= name "s"-      &= help "timeout in seconds, 0 for just T*M"-  , names        = names        as-      &= ignore-  , rows         = rows         as-      &= help "how many rows of results to show"-  , verbose      = verbose      as-      &= help "activate verbose output"-  , showMutantAs = showMutantAs as  &= name "a"-      &= help "how to show mutants (tuple / nestedtuple / definition / bindings)"-      &= typ  "type"-  , extra        = extra        as  &= CA.args-      &= typ "extra arguments"-  } &= summary "FitSpec"-    &= program "program"-    &= help "Refine property-sets for functional testing"--getArgsWith :: Args -> IO Args-getArgsWith = cmdArgs . annotate--getArgs :: IO Args-getArgs = getArgsWith args---- | Same as 'reportWith', but allow overriding of configuration via command---   line arguments.-mainWith :: (Mutable a, ShowMutable a)-         => Args-         -> a -> (a -> [Property]) -> IO ()-mainWith as f ps = do-  as' <- getArgsWith as-  reportWith as' f ps---- | Same as 'report', but allow configuration via command line arguments.-defaultMain :: (Mutable a, ShowMutable a)-            => a -> (a -> [Property]) -> IO ()-defaultMain = mainWith args

@@ -1,2 +0,0 @@--- | Deprecated, import 'FitSpec' instead-module FitSpec.Most (module FitSpec) where import FitSpec

@@ -1,186 +0,0 @@--- | Enumeration of function mutations-module FitSpec.Mutable-  ( Mutable (..)-  , mutiersEq---, mutantsIntegral-  )-where--import Test.LeanCheck-import Data.List (intercalate, delete)-import Data.Maybe-import Test.LeanCheck.Error (errorToNothing)---- | This typeclass is similar to 'Listable'.------ A type is 'Mutable' when there exists a function that--- is able to list mutations of a value.--- Ideally: list all possible values without repetitions.------ Instances are usually defined by a 'mutiers' function that--- given a value, returns tiers of mutants of that value:---   the first  tier contains the equivalent mutant, of size 0,---   the second tier contains mutants of size 1,---   the third  tier contains mutants of size 2,---   and so on.------ The equivalent mutant is the actual function without mutations.------ The size of a mutant is given by the sum of:---   the number of mutated points (relations) and---   the sizes of mutated arguments and results.------ To get only inequivalent mutants,--- just take the 'tail' of either 'mutants' or 'mutiers':------ > tail mutants------ > tail mutiers------ Given that the underlying 'Listable' enumeration has no repetitions--- parametric instances defined in this file will have no repeated mutants.-class Mutable a where-  mutiers :: a -> [[a]]-  mutants :: a -> [a]-  mutiers = map (:[]) . mutants-  mutants = concat . mutiers-  {-# MINIMAL mutants | mutiers #-}----- *** *** Instances for (non-functional) data types *** ***---- | Implementation of 'mutiers' for non-functional data types.--- Use this to create instances for user-defined data types, e.g.:------ > instance MyData--- >   where mutiers = mutiersEq------ and for parametric datatypes:------ > instance (Eq a, Eq b) => MyDt a b--- >   where mutiers = mutiersEq------ Examples:------ > mutiersEq True = [[True], [False]]--- > mutiersEq 2   = [[2], [0], [1], [], [3], [4], [5], [6], [7], [8], [9], ...]--- > mutiersEq [1] = [[[1]], [[]], [[0]], [[0,0]], [[0,0,0],[0,1],[1,0],[-1]], ...]-mutiersEq :: (Listable a, Eq a) => a -> [[a]]-mutiersEq x = [x] : deleteT x tiers---- | > mutants () = [()]-instance Mutable ()   where mutiers = mutiersEq---- | > mutants 3 = [3,0,1,2,4,5,6,7,8,9,...-instance Mutable Int  where mutiers = mutiersEq--instance Mutable Char where mutiers = mutiersEq---- | > mutants True = [True,False]-instance Mutable Bool where mutiers = mutiersEq -- > mutants True=[True,False]---- | > mutants [0] = [ [0], [], [0,0], [1], ...-instance (Eq a, Listable a) => Mutable [a]       where mutiers = mutiersEq---- | > mutants (Just 0) = [Just 0, Nothing, ...-instance (Eq a, Listable a) => Mutable (Maybe a) where mutiers = mutiersEq--{- Alternative implementations for Mutable Ints and Lists.--- These do not improve results significantly.--- That is why I have kept the simpler mutations above.---- |- Generate mutants of an Integral value.--- Alternates between successors and predecessors of the original number.--- The enumeration starts "towards" zero.-mutantsIntegral :: Integral a => a -> [a]-mutantsIntegral i | i > 0     = [i..] +| tail [i,(i-1)..]-                  | otherwise = [i,(i-1)..] +| tail [i..]--- NOTE: tail is there to avoid generating out of bound values---       as (i-1) is usually safe while (i-2) is not.--instance Mutable Int  where mutants = mutantsIntegral--instance (Listable a, Mutable a) => Mutable [a]-  where mutiers []     = [ [] ]-                       : [ ]-                       : tail tiers-        mutiers (x:xs) = [ (x:xs) ]-                       : [ [] ]-                       : tail (lsProductWith (:) (mutiers x) (mutiers xs))--- -}----- *** *** Instances for functional types *** ***---- | Mutate a function at a single point.--- The following two declarations are equivalent:------ > id' = id `mut` (0,1)------ > id' 0 = 1--- > id' x = x-mut :: Eq a => (a -> b) -> (a,b) -> (a -> b)-mut f (x',fx') = \x -> if x == x'-                         then fx'-                         else f x---- | Mutate a function at several points.------ > f `mutate` [(x,a),(y,b),(z,c)] = f `mut` (x,a) `mut` (y,b) `mut` (z,c)-mutate :: Eq a => (a -> b) -> [(a,b)] -> (a -> b)-mutate f ms = foldr (flip mut) f ms -- or: foldl mut f ms---- | Return tiers of possible mutations for a single point of a function.--- If the function is undefined at that point, no mutations are provided.--- This function does not return the null mutant.------ > (+1) `mutationsFor` 1 = [ [(1,0)], [(1,1)], [], [(1,3)], [(1,4)], ...-mutationsFor :: Mutable b => (a->b) -> a -> [[(a,b)]]-mutationsFor f x = case errorToNothing (f x) of-                     Nothing -> []-                     Just fx -> ((,) x) `mapT` tail (mutiers fx)---- | Returns tiers of mutants on a selection of arguments of a function.--- Will only return the null mutant from an empty selection of arguments.-tiersMutantsOn :: (Eq a, Mutable b) => (a->b) -> [a] -> [[a->b]]-tiersMutantsOn f xs = mutate f `mapT` products (map (mutationsFor f) xs)---- |--- > mutants not =--- >   [ not--- >   , \p -> case p of False -> False; _ -> not p--- >   , \p -> case p of True  -> True;  _ -> not p--- >   , \p -> case p of False -> False; True -> True--- >   ]-instance (Eq a, Listable a, Mutable b) => Mutable (a -> b) where-  mutiers f = tiersMutantsOn f `concatMapT` setsOf tiers----- *** *** Instances for tuples *** ***---- | > mutants (0,1) = [(0,1),(0,0),(1,1),(0,-1),...]-instance (Mutable a, Mutable b) => Mutable (a,b) where-  mutiers (f,g) = mutiers f >< mutiers g--instance (Mutable a, Mutable b, Mutable c) => Mutable (a,b,c) where-  mutiers (f,g,h) = productWith (\f' (g',h') -> (f',g',h'))-                                (mutiers f) (mutiers (g,h))--instance (Mutable a, Mutable b, Mutable c, Mutable d)-      => Mutable (a,b,c,d) where-  mutiers (f,g,h,i) = productWith (\f' (g',h',i') -> (f',g',h',i'))-                                  (mutiers f) (mutiers (g,h,i))--instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e)-      => Mutable (a,b,c,d,e) where-  mutiers (f,g,h,i,j) = productWith (\f' (g',h',i',j') -> (f',g',h',i',j'))-                                    (mutiers f) (mutiers (g,h,i,j))---- | For Mutable tuple instances greater than sixtuples, see---   'FitSpec.Mutable.Tuples'.  Despite being hidden in this Haddock---   documentation, 7-tuples up to 12-tuples are exported by 'FitSpec'.-instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, Mutable f)-      => Mutable (a,b,c,d,e,f) where-  mutiers (f,g,h,i,j,k) = productWith (\f' (g',h',i',j',k') ->-                                           (f',g',h',i',j',k'))-                                      (mutiers f) (mutiers (g,h,i,j,k))

@@ -1,62 +0,0 @@--- | Mutable instances: septuples up to 12-tuples------ This is part of a Hack that allows those instances to be hidden from Haddock.--- Otherwise Haddock documentation will look very ugly.-module FitSpec.Mutable.Tuples () where--import FitSpec.Mutable-import Test.LeanCheck (productWith)--instance (Mutable a, Mutable b, Mutable c, Mutable d,-          Mutable e, Mutable f, Mutable g)-      => Mutable (a,b,c,d,e,f,g) where-  mutiers (f,g,h,i,j,k,l) = productWith (\f' (g',h',i',j',k',l') ->-                                             (f',g',h',i',j',k',l'))-                                        (mutiers f)-                                        (mutiers (g,h,i,j,k,l))--instance (Mutable a, Mutable b, Mutable c, Mutable d,-          Mutable e, Mutable f, Mutable g, Mutable h)-      => Mutable (a,b,c,d,e,f,g,h) where-  mutiers (f,g,h,i,j,k,l,m) = productWith (\f' (g',h',i',j',k',l',m') ->-                                               (f',g',h',i',j',k',l',m'))-                                          (mutiers f)-                                          (mutiers (g,h,i,j,k,l,m))--instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e,-          Mutable f, Mutable g, Mutable h, Mutable i)-      => Mutable (a,b,c,d,e,f,g,h,i) where-  mutiers (f,g,h,i,j,k,l,m,n) =-    productWith (\f' (g',h',i',j',k',l',m',n') ->-                   (f',g',h',i',j',k',l',m',n'))-                (mutiers f)-                (mutiers (g,h,i,j,k,l,m,n))--instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e,-          Mutable f, Mutable g, Mutable h, Mutable i, Mutable j)-      => Mutable (a,b,c,d,e,f,g,h,i,j) where-  mutiers (f,g,h,i,j,k,l,m,n,o) =-    productWith (\f' (g',h',i',j',k',l',m',n',o') ->-                   (f',g',h',i',j',k',l',m',n',o'))-                (mutiers f)-                (mutiers (g,h,i,j,k,l,m,n,o))--instance (Mutable a, Mutable b, Mutable c, Mutable d,-          Mutable e, Mutable f, Mutable g, Mutable h,-          Mutable i, Mutable j, Mutable k)-      => Mutable (a,b,c,d,e,f,g,h,i,j,k) where-  mutiers (f,g,h,i,j,k,l,m,n,o,p) =-    productWith (\f' (g',h',i',j',k',l',m',n',o',p') ->-                   (f',g',h',i',j',k',l',m',n',o',p'))-                (mutiers f)-                (mutiers (g,h,i,j,k,l,m,n,o,p))--instance (Mutable a, Mutable b, Mutable c, Mutable d,-          Mutable e, Mutable f, Mutable g, Mutable h,-          Mutable i, Mutable j, Mutable k, Mutable l)-      => Mutable (a,b,c,d,e,f,g,h,i,j,k,l) where-  mutiers (f,g,h,i,j,k,l,m,n,o,p,q) =-    productWith (\f' (g',h',i',j',k',l',m',n',o',p',q') ->-                   (f',g',h',i',j',k',l',m',n',o',p',q'))-                (mutiers f)-                (mutiers (g,h,i,j,k,l,m,n,o,p,q))

@@ -1,141 +0,0 @@--- | Poor man's pretty printing library------ This module has somewhat inefficient implementations that could be improved--- in the future.  i.e.: heavy use of '(++)'.-module FitSpec.PrettyPrint-  ( beside-  , above-  , showTuple-  , table-  , columns-  , showQuantity-  , showEach-  , headToUpper-  )-where--import Data.List (intercalate,transpose,isSuffixOf)-import Data.Char (toUpper)--showQuantity :: Int -> String -> String-showQuantity 1 what = "1 " ++ what-showQuantity n what = show n ++ " " ++ pluralize what--showEach :: Show a => String -> [a] -> String-showEach what [x] = what ++ " " ++ show x-showEach what xs  = "each of " ++ pluralize what ++ " "-                 ++ intercalate ", " (map show $ init xs)-                 ++ " and "-                 ++ show (last xs)---- | Pluralizes a word.--- Is not comprehensive (and may never be),--- add missing cases as they are found.------ > pluralize "test case" == "test cases"--- > pluralize "property"  == "properties"-pluralize :: String -> String-pluralize s | s `ew` "se" = s ++ "s"-            | s `ew` "n"  = s ++ "s"-            | s `ew` "y"  = init s ++ "ies"-            | otherwise   = s-  where ew = flip isSuffixOf----- | Appends two Strings side by side, line by line------ > beside ["asdf\nqw\n","zxvc\nas"] ==--- >  "asdfzxvc\n\--- >  \qw  as\n"-beside :: String -> String -> String-beside cs ds = unlines $ zipWith (++) (normalize ' ' css) dss-  where [css,dss] = normalize "" [lines cs,lines ds]---- | Append two Strings on top of each other, adding line breaks *when needed*.-above :: String -> String -> String-above cs ds = if last cs == '\n' || head ds == '\n'-                then cs ++ ds-                else cs ++ '\n':ds---- | Show elements of a list as a tuple.  If there are multiple lines in any of---   the strings, tuple is printed multiline.------ > showTuple ["asdf\nqwer\n","zxvc\nasdf\n"] ==--- >   "( asdf\n\--- >   \  qwer\n\--- >   \, zxvc\n\--- >   \  asdf )\n"------ > showTuple ["asdf","qwer"] == "(asdf,qwer)"-showTuple :: [String] -> String-showTuple []  = ""-showTuple [s] = s-showTuple (s:ss) =-  if any ('\n' `elem`) (s:ss)-    then "( " `beside` s-      ++ init (concatMap (", " `beside`) ss)-      ++ " )\n"-    else "(" ++ intercalate "," (s:ss) ++ ")"---- | Formats a table using a given separator.------ > table "  " [ ["asdf", "qwer",     "zxvc\nzxvc"]--- >            , ["0",    "1",        "2"]--- >            , ["123",  "456\n789", "3"] ] ==--- >   "asdf  qwer  zxvc\n\--- >   \            zxvc\n\--- >   \0     1     2\n\--- >   \123   456   3\n\--- >   \      789\n\"-table :: String -> [[String]] -> String-table s []  = ""-table s sss = unlines-            . map (removeTrailing ' ')-            . map (intercalate s)-            . transpose-            . map (normalize ' ')-            . foldr1 (zipWith (++))-            . map (normalize "" . map lines)-            . normalize ""-            $ sss---- | Given a separator, format strings in columns------ > columns " | " ["asdf", "qw\nzxcv", "as\ndf"] ==--- >   "asdf | qw   | as\n\--- >   \     | zxcv | df\n"-columns :: String -> [String] -> String-columns s = unlines-          . map (removeTrailing ' ')-          . map (intercalate s)-          . transpose-          . map (normalize ' ')-          . normalize ""-          . map lines---- | Fits a list to a certain width by appending a certain value------ > fit ' ' 6 "str" == "str   "------ > fit 0 6 [1,2,3] == [1,2,3,0,0,0]-fit :: a -> Int -> [a] -> [a]-fit x n xs = xs ++ replicate (n - length xs) x---- | normalize makes all list the same length by adding a value------ > normalize ["asdf","qw","er"] == normalize ["asdf","qw  ","er  "]-normalize :: a -> [[a]] -> [[a]]-normalize x xs = map (x `fit` maxLength xs) xs---- | Given a list of lists returns the maximum length-maxLength :: [[a]] -> Int-maxLength = maximum . (0:) . map length--removeTrailing :: Eq a => a -> [a] -> [a]-removeTrailing x = reverse-                 . dropWhile (==x)-                 . reverse--headToUpper :: [Char] -> [Char]-headToUpper [] = []-headToUpper (c:cs) = toUpper c : cs

@@ -1,246 +0,0 @@-module FitSpec.Report-  ( report-  , reportWith-  , reportWithExtra-  , Args(..)-  , args-  , fixargs-  , Property-  , ShowMutantAs(..)-  )-where--import Data.List (intercalate, intersperse)-import Data.Maybe (fromMaybe)--import FitSpec.Engine-import FitSpec.Mutable-import FitSpec.ShowMutable-import FitSpec.Utils-import FitSpec.PrettyPrint---- | How to show mutants.  Use this to fill 'showMutantAs'.-data ShowMutantAs = Tuple      | NestedTuple-                  | Definition | Bindings---- | Extra arguments / configuration for 'reportWith'.---   See 'args' for default values.-data Args = Args-  { nMutants :: Int -- ^ (starting) number of function mutations-  , nTests   :: Int -- ^ (starting) number of test values (for each prop.)-  , timeout  :: Int -- ^ timeout in seconds, 0 for just 'nTests' * 'nMutants'-  , names    :: [String] -- ^ names of functions: @["foo x y","goo x y"]@--  -- advanced options:-  , verbose      :: Bool         -- ^ whether to show detailed results-  , showMutantAs :: ShowMutantAs -- ^ how to show mutants-  , rows         :: Maybe Int    -- ^ number of surviving mutants to show-  , extra        :: [String]     -- ^ ignored argument (user defined meaning)-  }---- | Default arguments for 'reportWith':------ * @nMutants = 500@, start with  500 mutants------ * @nTests = 1000@,  start with 1000 test values------ * @timeout = 5@, keep incresing the number of mutants---                  until 5 seconds elapse------ * @names = []@, default function call template:------   > ["f x y z", "g x y z", "h x y z", ...]-args :: Args-args = Args { nMutants     =  500-            , nTests       = 1000-            , timeout      = 5  -- seconds-            , names        = []-            , verbose      = False-            , showMutantAs = Tuple-            , rows         = Nothing-            , extra        = []-            }---- | Non timed-out default arguments.--- Make conjectures based on a fixed number of mutants and tests, e.g.:------ > reportWith (fixargs 100 200) f pmap------ This is just a shorthand, see:------ > fixargs nm nt  =  args { nMutants = nm, nTests = nt, timeout = 0 }------ > (fixargs nm nt) { nMutants = 500, nTests = 1000, timeout = 5 }  =  args-fixargs :: Int -> Int -> Args-fixargs nm nt = args-  { nMutants = nm-  , nTests   = nt-  , timeout  = 0-  }--showMutant :: ShowMutable a => Args -> a -> a -> String-showMutant as = showMutantByType (showMutantAs as) (names as)-  where-    showMutantByType Tuple       = showMutantAsTuple-    showMutantByType NestedTuple = showMutantNested-    showMutantByType Definition  = showMutantDefinition-    showMutantByType Bindings    = showMutantBindings---- | Report results generated by FitSpec.--- Uses standard configuration (see 'args').--- Needs a function to be mutated and a property map.--- Example (specification of boolean negation):------ > properties not =--- >   [ property $ \p -> not (not p) == p--- >   , property $ \p -> not (not (not p)) == not p--- >   ]--- >--- > main = report not properties-report :: (Mutable a, ShowMutable a)-       => a -> (a -> [Property]) -> IO ()-report = reportWith args----- | Same as 'report' but can be configured via 'Args' ('args' or 'fixargs'),---   e.g.:------ > reportWith args { timeout = 10 } fun properties-reportWith :: (Mutable a, ShowMutable a)-           => Args -> a -> (a -> [Property]) -> IO ()-reportWith = reportWithExtra []----- | Same as 'reportWith', but accepts a list of manually defined (extra)---   mutants to be tested alongside those automatically generated.-reportWithExtra :: (Mutable a, ShowMutable a)-                => [a] -> Args -> a -> (a -> [Property]) -> IO ()-reportWithExtra extraMutants args f properties = do-  let nm = nMutants args-      nt = nTests args-  case propertiesCE nt (properties f) of-    Nothing -> reportWithExtra' extraMutants args f properties-    Just ce -> do-      putStrLn $ "ERROR: The original function-set does not follow property set for "-              ++ show nt ++ " tests"-      putStrLn $ "Counter-example to property " ++ ce-      putStrLn $ "Aborting."---- | Same as 'reportWithExtra', does not abort if the original function does not---   follow the property set.-reportWithExtra' :: (Mutable a, ShowMutable a)-                 => [a] -> Args -> a -> (a -> [Property]) -> IO ()-reportWithExtra' extraMutants args f properties = do-  results <- getResultsExtraTimeout (timeout args)-                                    extraMutants-                                    f properties-                                    (nMutants args) (nTests args)--  let nm = totalMutants $ head results-      nt = maxTests $ head results-      nts = propertiesNTests nt (properties f)-      tex = and $ propertiesTestsExhausted nt (properties f)-      mex = mutantsExhausted $ head results-      apparent | tex && mex = ""-               | otherwise  = "apparent "-  putStrLn . headToUpper $ apparent ++ qualifyCM results ++ " specification based on"-  putStrLn $ showNumberOfTestsAndMutants tex mex nts nm False--  let showR | verbose args = showDetailedResults-            | otherwise    = showResults-  putStrLn $ showR (rows args) (showMutant args f) results---showResults :: Maybe Int -> (a -> String)-            -> [Result a] -> String-showResults mlimit showMutant rs@(r:_) = completeness-                              ++ "\n" ++ minimality-  where-    showMutants ms = init . unlines $ map showMutant ms-    completeness = show (nSurvivors r) ++ " survivors ("-                ++ show (score r) ++ "% killed)"-                ++ case take (fromMaybe 1 mlimit) $ survivors r of-                     [] -> ".\n"-                     [m] -> ", smallest:\n"-                         ++ "  " `beside` showMutant m-                     ms  -> ", " ++ show (length ms) ++ " smallest:\n"-                         ++ "  " `beside` showMutants ms-    minimality = "apparent minimal property subsets:  "-              ++ (unwords . map showPropertySet $ sets r) ++ "\n"-              ++ case showConjectures False rs of-                   "" -> "No conjectures.\n"-                   cs -> "conjectures:  " `beside` cs---showDetailedResults :: Maybe Int -> (a -> String)-                    -> [Result a] -> String-showDetailedResults mlimit showMutant rs = completeness-                                ++ "\n" ++ minimality-  where-    completeness = table "   " . intersperse ["\n"]-                 . ([ "Property\n sets"-                    , "#Survivors\n (%Killed)"-                    , "Smallest or simplest\n surviving mutant"-                    ]:)-                 . map showResult-                 . maybe id take mlimit-                 $ rs-    showResult r = [ unwords . map showPropertySet $ sets r-                   , show  (nSurvivors r) ++ " (" ++ show (score r) ++ "%)"-                   , maybe "" showMutant $ smallestSurvivor r-                   ]-    minimality = case showConjectures True rs of-                   "" -> "No conjectures.\n"-                   cs -> "Conjectures:\n" ++ cs---showNumberOfTestsAndMutants :: Bool -> Bool -> [Int] -> Int -> Bool -> String-showNumberOfTestsAndMutants tex mex nts nm ssum = numTests ++ numMutants-  where-    mexS | mex = " (exhausted)"-         | otherwise = ""-    numMutants = "for each of " ++ showQuantity nm "mutant variation" ++ mexS ++ ".\n"-    numTests | ssum = showQuantity (sum nts) "test case"-                   ++ (if tex then " (exhausted)" else "")-                   ++ "\n"-             | otherwise = unlines-                         . (++ ["(test cases exhausted)" | tex])-                         . sortGroupAndCollapse fst snd testsForProps-                         $ zip nts [1..]-    testsForProps n ps = showQuantity n "test case"-                      ++ " for " ++ showEach "property" ps--showPropertySet :: Show i => [i] -> String-showPropertySet = (\s -> "{" ++ s ++ "}") . intercalate "," . map show----- | Show conjectures derived from results-showConjectures :: Bool -> [Result a] -> String-showConjectures showVeryWeak = table " "-                             . map showConjecture-                             . filter (\r -> showVeryWeak-                                          || cnKilled r    /= 0-                                          && cnSurvivors r /= 0)-                             . conjectures--showConjecture :: Conjecture -> [String]-showConjecture Conjecture {isEq=eq, cleft=l, cright=r, cscore=s} =-  [ showPropertySet l-  , if eq then " = " else "==>"-  , showPropertySet r-  , "   "-  , show s ++ "% killed"-  , sMeaning-  ]-  where sMeaning | s < 1  || 99 < s = "(very weak)"-                 | s < 11 || 89 < s = "(weak)"-                 | s < 33 || 67 < s = "(mild)"-                 | otherwise        = "(strong)" -- the closer to 50 the better--qualifyCM :: Results a -> String-qualifyCM rs | c && m    = "complete and minimal"-             | c         = "complete but non-minimal"-             |      m    = "minimal but incomplete"-             | otherwise = "incomplete and non-minimal"-  where c = complete rs-        m = minimal rs

@@ -1,362 +0,0 @@--- | Show mutant variations-module FitSpec.ShowMutable-  ( ShowMutable (..)-  , mutantSEq-  , showMutantAsTuple-  , showMutantNested-  , showMutantDefinition-  , showMutantBindings-  , MutantS ()-  , mutantSTuple-  )-where--import FitSpec.PrettyPrint-import Test.LeanCheck.Error (errorToNothing, Listable(..))-import Data.Maybe (mapMaybe,isNothing)-import Control.Monad (join)-import Data.List (intercalate,tails)-import Data.Char (isLetter)----- | Show a Mutant as a tuple of lambdas.------ > > putStrLn $ showMutantAsTuple ["p && q","not p"] ((&&),not) ((||),id)--- > ( \p q -> case (p,q) of--- >            (False,False) -> True--- >            _ -> p && q--- >, \p -> case p of--- >          False -> False--- >          True -> True--- >          _ -> not p )------ Can be easily copy pasted into an interactive session for manipulation.--- On GHCi, use @:{@ and @:}@ to allow multi-line expressions and definitions.-showMutantAsTuple :: ShowMutable a => [String] -> a -> a -> String-showMutantAsTuple names f f' = showMutantSAsTuple names-                             $ flatten-                             $ mutantS f f'---- | Show a Mutant as the list of bindings that differ from the original---   function(s).------ > > putStrLn $ showMutantBindings ["p && q","not p"] ((&&),not) ((==),id)--- > False && False = True--- > not False = False--- > not True  = True------ Can possibly be copied into the source of the original function for--- manipulation.-showMutantBindings :: ShowMutable a => [String] -> a -> a -> String-showMutantBindings names f f' = showMutantSBindings False names-                              $ flatten-                              $ mutantS f f'---- | Show a Mutant as a new complete top-level definition, with a prime--- appended to the name of the mutant.------ > > putStrLn $ showMutantDefinition ["p && q","not p"] ((&&),not) ((==),id)--- > False &&- False = True--- > p     &&- q     = p && q--- > not' False = False--- > not' True  = True--- > not' p     = not p-showMutantDefinition :: ShowMutable a => [String] -> a -> a -> String-showMutantDefinition names f f' = showMutantSBindings True names-                               $ flatten-                               $ mutantS f f'---- | Show a Mutant as a tuple of nested lambdas.--- Very similar to 'showMutantAsTuple', but the underlying data structure is--- not flatten: so the output is as close as possible to the underlying--- representation.-showMutantNested :: ShowMutable a => [String] -> a -> a -> String-showMutantNested names f f' = showMutantSAsTuple names-                            $ mutantS f f'---- | Show a Mutant without providing a default name.--- An alias for @showMutantAsTuple []@.-showMutant :: ShowMutable a => a -> a -> String-showMutant = showMutantAsTuple []----- | Default function names (when none given):------ > f g h f' g' h' f'' g'' h''-defaultFunctionNames :: [String]-defaultFunctionNames = ["f","g","h"] ++ map (++"'") defaultFunctionNames---- | Default names in a call (function and variables):------ > f x y z w x' y' z' w' x'' y'' z'' w'' ...-defaultNames :: [String]-defaultNames = head defaultFunctionNames : defVarNames-  where defVarNames = ["x","y","z","w"] ++ map (++"'") defVarNames----- | Types that can have their mutation shown.--- Has only one function 'mutantS' that returns a simple AST ('MutantS')--- representing the mutant.  A standard implementation of 'mutantS' for 'Eq'--- types is given by 'mutantSEq'.-class ShowMutable a where-  mutantS :: a -> a -> MutantS---- | For a given type @Type@ instance of @Eq@ and @Show@,--- define the 'ShowMutable' instance as:------ > instance ShowMutable Type--- >   where mutantS = mutantSEq-mutantSEq :: (Eq a, Show a)-          => a -> a -> MutantS-mutantSEq x x' = if x == x'-                    then Unmutated $ show x-                    else Atom      $ show x'--instance ShowMutable ()   where mutantS = mutantSEq-instance ShowMutable Int  where mutantS = mutantSEq-instance ShowMutable Char where mutantS = mutantSEq-instance ShowMutable Bool where mutantS = mutantSEq-instance (Eq a, Show a) => ShowMutable [a]       where mutantS = mutantSEq-instance (Eq a, Show a) => ShowMutable (Maybe a) where mutantS = mutantSEq--instance (Listable a, Show a, ShowMutable b) => ShowMutable (a->b) where-  -- TODO: let the user provide how many values should be tried when printing-  mutantS f f' = Function-               . take 10-               . filter (not . isUnmutated . snd)-               . mapMaybe bindingFor-               . take 200-               $ list-    where bindingFor x = fmap ((,) [show x])-                       $ errorToNothing (mutantS (f x) (f' x))--instance (ShowMutable a, ShowMutable b) => ShowMutable (a,b) where-  mutantS (f,g) (f',g') = Tuple [ mutantS f f'-                                , mutantS g g' ]--instance (ShowMutable a, ShowMutable b, ShowMutable c)-      => ShowMutable (a,b,c) where-  mutantS (f,g,h) (f',g',h') = Tuple [ mutantS f f'-                                     , mutantS g g'-                                     , mutantS h h' ]----- | (Show) Structure of a mutant.--- This format is intended for processing then pretty-printing.-data MutantS = Unmutated String-             | Atom String-             | Tuple [MutantS]-             | Function [([String],MutantS)]-  deriving Show---- | Check if a 'MutantS' is null-isUnmutated :: MutantS -> Bool-isUnmutated (Unmutated _) = True-isUnmutated (Tuple ms)    = all isUnmutated ms-isUnmutated (Function bs) = all (isUnmutated . snd) bs-isUnmutated _             = False---- | Check if a 'MutantS' is a function.-isFunction :: MutantS -> Bool-isFunction (Function _) = True-isFunction _            = False---- | Flatten a MutantS by merging nested 'Function's.-flatten :: MutantS -> MutantS-flatten (Tuple ms) = Tuple $ map flatten ms-flatten (Function [([],s)])  = flatten s-flatten (Function (([],s):_)) = error "flatten: ambiguous value"-flatten (Function bs) = let bs' = map (mapSnd flatten) bs in-  if any (not . isFunction . snd) bs'-    then Function bs'-    else Function-       $ take 10-       $ concatMap (\(as,Function bs'') -> map (mapFst (as++)) bs'') bs'-flatten m = m----- | Show a nameless mutant.--- Functions should not (but can) be shown using this.-showMutantS :: MutantS -> String-showMutantS (Unmutated s) = s-showMutantS (Atom s)      = s-showMutantS (Tuple ms)    = showTuple $ map showMutantS ms-showMutantS (Function bs) = showLambda ["??"] bs---- | Show top-level (maybe tuple) named 'MutantS' as a tuple.-showMutantSAsTuple :: [String] -> MutantS -> String-showMutantSAsTuple ns (Tuple ms) = showTuple $ zipWith show1 (ns +- defaultFunctionNames) ms-  where show1 n  (Unmutated _) = n-        show1 n  (Function bs) = showLambda (fvnames n) bs-        show1 _  m             = showMutantS m-showMutantSAsTuple ns m = showMutantSAsTuple ns (Tuple [m])---- | Show top-level (maybe tuple) named 'MutantS' as a bindings.--- In general, you want to 'flatten' the 'MutantS' before applying this--- function.-showMutantSBindings :: Bool -> [String] -> MutantS -> String-showMutantSBindings new ns (Tuple ms) = concatMap (uncurry show1)-                                  $ zip (ns ++ defaultFunctionNames) ms-  where show1 _ (Unmutated s) = ""-        show1 _ (Function []) = ""-        show1 n (Function bs) = showBindings new (fvnames n) bs-        show1 n m             = let fn = head $ fvnames n-                                    fn' | new = prime fn-                                        | otherwise = fn-                                in (apply fn' [] ++ " = ")-                          `beside` showMutantS m-showMutantSBindings new ns m = showMutantSBindings new ns (Tuple [m])----- | Given a list with the function and variable names and a list of bindings,--- show a function as a case expression enclosed in a lambda.-showLambda :: [String] -> [([String],MutantS)] -> String-showLambda []    [] = "undefined {- (err?) unmutated -}"-showLambda (n:_) [] = apply n []-showLambda _ [([],m)]   = showMutantS m-showLambda _ (([],_):_) = "undefined {- (err?) ambiguous value -}"-showLambda ns bs = (("\\" ++ unwords bound ++ " -> ") `beside`)-                 $ "case " ++ showTuple bound ++ " of\n"-                ++ "  " `beside` cases-  where-    cases = concatMap (\(as,r) -> (showTuple as ++ " -> ") `beside` showResult r) bs-         ++ "_ -> " ++ apply fn bound-    showResult (Function bs') = showLambda (apply fn bound:unbound) bs'-    showResult m              = showMutantS m-    unbound  = drop (length bound) vns-    bound    = zipWith const vns (fst $ head bs)-    (fn:vns) = ns +- defaultNames---- | Given a list with the function and variable names and a list of bindings,--- show function binding declarations.------ The 'new' boolean argument indicates whether if the function should be shown--- as a new definition.-showBindings :: Bool -> [String] -> [([String],MutantS)] -> String-showBindings new ns bs =-  table " " $ (uncurry showBind `map` bs)-           ++ [words (apply fn' bound) ++ ["=", apply fn bound] | new]-  where-    showBind [a1,a2] r | isInfix fn' = [a1, fn', a2,   "=", showMutantS r]-    showBind as r                    = [fn'] ++ as ++ ["=", showMutantS r]-    fn' | new = prime fn-        | otherwise = fn-    bound    = zipWith const vns (fst $ head bs)-    (fn:vns) = ns +- defaultNames----- | Separate function from variable names in a simple Haskell expr.------ > fvarnames "f x y" == ["f","x","y"]--- > fvarnames "aa bb cc dd" == ["aa","bb","cc","dd"]------ When there are three lexemes, the function checks for a potential infix--- operator in the middle.------ > fvarnames "x + y" == ["(+)","x","y"]--- --- This function always returns a "head"------ > fvarnames "" == ["f"]-fvnames :: String -> [String]-fvnames = fvns' . words-  where fvns' :: [String] -> [String]-        fvns' [a,o,b] | isInfix o = o:[a,b]-        fvns' []      = defaultNames-        fvns' fvs     = fvs---- | Apply a function ('String') to a list of variables ('[String]').------ For the sake of clarity, in the following examples, double-quotes are omitted:--- > apply f       == f--- > apply f x     == f x--- > apply f x y   == f x y--- > apply (+)     == (+)--- > apply (+) x   == (+) x--- > apply (+) x y == (+) x y--- > apply +       == (+)--- > apply + x     == (+) x--- > apply + x y   == (x + y)--- > apply + x y z == (+) x y z-apply :: String -> [String] -> String-apply f [x,y] | isInfix f = unwords [x,f,y]-apply f xs = if isInfix f-               then unwords (toPrefix f:xs)-               else unwords (f:xs)---- | Check if a function / operator is infix------ > isInfix "foo"   == False--- > isInfix "(+)"   == False--- > isInfix "`foo`" == True--- > isInfix "+"     == True-isInfix :: String -> Bool-isInfix (c:cs) = c /= '(' && not (isLetter c)---- | Transform an infix operator into an infix function:------ > toPrefix "`foo`" == "foo"--- > toPrefix "+"     == "(+)"-toPrefix :: String -> String-toPrefix ('`':cs) = init cs-toPrefix cs = '(':cs ++ ")"---- Primeify the name of a function by appending prime @'@ to functions and--- minus @-@ to operators.------ > prime "(+)"   == "(+-)"--- > prime "foo"   == "foo'"--- > prime "`foo`" == "`foo'`"--- > prime "*"     == "*--prime :: String -> String-prime ('`':cs) = '`':init cs ++ "'`" -- `foo` to `foo'`-prime ('(':cs) = '(':init cs ++ "-)" -- (+) to (+-)-prime cs | isInfix cs = cs ++ "-"    -- + to +--         | otherwise  = cs ++ "'"    -- foo to foo'---mapFst :: (a->b) -> (a,c) -> (b,c)-mapFst f (x,y) = (f x,y)--mapSnd :: (a->b) -> (c,a) -> (c,b)-mapSnd f (x,y) = (x,f y)---- | @xs +- ys@ superimposes @xs@ over @ys@.------ [1,2,3] +- [0,0,0,0,0,0,0] == [1,2,3,0,0,0,0]--- [x,y,z] +- [a,b,c,d,e,f,g] == [x,y,z,d,e,f,g]--- "asdf" +- "this is a test" == "asdf is a test"-(+-) :: Eq a => [a] -> [a] -> [a]-xs +- ys = xs ++ drop (length xs) ys----- Instances of ShowMutable for up to 6-tuples are given here:--instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d)-      => ShowMutable (a,b,c,d) where-  mutantS (f,g,h,i) (f',g',h',i') = Tuple [ mutantS f f'-                                          , mutantS g g'-                                          , mutantS h h'-                                          , mutantS i i' ]--instance (ShowMutable a, ShowMutable b, ShowMutable c,-          ShowMutable d, ShowMutable e)-      => ShowMutable (a,b,c,d,e) where-  mutantS (f,g,h,i,j) (f',g',h',i',j') = Tuple [ mutantS f f'-                                               , mutantS g g'-                                               , mutantS h h'-                                               , mutantS i i'-                                               , mutantS j j' ]--instance (ShowMutable a, ShowMutable b, ShowMutable c,-          ShowMutable d, ShowMutable e, ShowMutable f)-      => ShowMutable (a,b,c,d,e,f) where-  mutantS (f,g,h,i,j,k) (f',g',h',i',j',k') = Tuple [ mutantS f f'-                                                    , mutantS g g'-                                                    , mutantS h h'-                                                    , mutantS i i'-                                                    , mutantS j j'-                                                    , mutantS k k' ]--mutantSTuple :: [MutantS] -> MutantS-mutantSTuple = Tuple

@@ -1,98 +0,0 @@--- | ShowMutable instances: septuples up to 12-tuples------ This is part of a Hack that allows those instances to be hidden from Haddock.--- Otherwise Haddock documentation will look very ugly.-module FitSpec.ShowMutable.Tuples () where--import FitSpec.ShowMutable--instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,-          ShowMutable e, ShowMutable f, ShowMutable g)-      => ShowMutable (a,b,c,d,e,f,g) where-  mutantS (f,g,h,i,j,k,l) (f',g',h',i',j',k',l') = mutantSTuple-                                                    [ mutantS f f'-                                                    , mutantS g g'-                                                    , mutantS h h'-                                                    , mutantS i i'-                                                    , mutantS j j'-                                                    , mutantS k k'-                                                    , mutantS l l' ]--instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,-          ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h)-      => ShowMutable (a,b,c,d,e,f,g,h) where-  mutantS (f,g,h,i,j,k,l,m) (f',g',h',i',j',k',l',m') = mutantSTuple-                                                      [ mutantS f f'-                                                      , mutantS g g'-                                                      , mutantS h h'-                                                      , mutantS i i'-                                                      , mutantS j j'-                                                      , mutantS k k'-                                                      , mutantS l l'-                                                      , mutantS m m' ]--instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,-          ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h,-          ShowMutable i)-      => ShowMutable (a,b,c,d,e,f,g,h,i) where-  mutantS (f,g,h,i,j,k,l,m,n) (f',g',h',i',j',k',l',m',n') = mutantSTuple-    [ mutantS f f'-    , mutantS g g'-    , mutantS h h'-    , mutantS i i'-    , mutantS j j'-    , mutantS k k'-    , mutantS l l'-    , mutantS m m'-    , mutantS n n' ]--instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,-          ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h,-          ShowMutable i, ShowMutable j)-      => ShowMutable (a,b,c,d,e,f,h,g,i,j) where-  mutantS (f,g,h,i,j,k,l,m,n,o) (f',g',h',i',j',k',l',m',n',o') = mutantSTuple-    [ mutantS f f'-    , mutantS g g'-    , mutantS h h'-    , mutantS i i'-    , mutantS j j'-    , mutantS k k'-    , mutantS l l'-    , mutantS m m'-    , mutantS n n'-    , mutantS o o' ]--instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,-          ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h,-          ShowMutable i, ShowMutable j, ShowMutable k)-      => ShowMutable (a,b,c,d,e,f,g,h,i,j,k) where-  mutantS (f,g,h,i,j,k,l,m,n,o,p) (f',g',h',i',j',k',l',m',n',o',p') = mutantSTuple-    [ mutantS f f'-    , mutantS g g'-    , mutantS h h'-    , mutantS i i'-    , mutantS j j'-    , mutantS k k'-    , mutantS l l'-    , mutantS m m'-    , mutantS n n'-    , mutantS o o'-    , mutantS p p' ]--instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,-          ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h,-          ShowMutable i, ShowMutable j, ShowMutable k, ShowMutable l)-      => ShowMutable (a,b,c,d,e,f,g,h,i,j,k,l) where-  mutantS (f,g,h,i,j,k,l,m,n,o,p,q) (f',g',h',i',j',k',l',m',n',o',p',q') = mutantSTuple-    [ mutantS f f'-    , mutantS g g'-    , mutantS h h'-    , mutantS i i'-    , mutantS j j'-    , mutantS k k'-    , mutantS l l'-    , mutantS m m'-    , mutantS n n'-    , mutantS o o'-    , mutantS p p'-    , mutantS q q' ]

@@ -1,43 +0,0 @@--- | FitSpec Test Types:--- 'Nat',--- 'Int2', 'Int3', 'Int4',--- 'UInt2', 'UInt3', 'UInt4'.------ This module basically re-exports LeanCheck's Test.Types module--- and defines Mutable and ShowMutable instances for the types--- defined there.-module FitSpec.TestTypes (module Test.LeanCheck.Utils.Types) where--import FitSpec.Mutable-import FitSpec.ShowMutable-import Test.LeanCheck.Utils.Types---- {- Standard implementation:-instance Mutable Nat   where mutiers = mutiersEq-instance Mutable Int1  where mutiers = mutiersEq-instance Mutable Int2  where mutiers = mutiersEq-instance Mutable Int3  where mutiers = mutiersEq-instance Mutable Int4  where mutiers = mutiersEq-instance Mutable Word1 where mutiers = mutiersEq-instance Mutable Word2 where mutiers = mutiersEq-instance Mutable Word3 where mutiers = mutiersEq-instance Mutable Word4 where mutiers = mutiersEq--- -}-{- Alternative implementation:-instance Mutable Nat   where mutants = mutantsIntegral-instance Mutable Int2  where mutants = mutantsIntegral-instance Mutable Int3  where mutants = mutantsIntegral-instance Mutable Int4  where mutants = mutantsIntegral-instance Mutable Word2 where mutants = mutantsIntegral-instance Mutable Word3 where mutants = mutantsIntegral-instance Mutable Word4 where mutants = mutantsIntegral--- -}-instance ShowMutable Nat   where mutantS = mutantSEq-instance ShowMutable Int1  where mutantS = mutantSEq-instance ShowMutable Int2  where mutantS = mutantSEq-instance ShowMutable Int3  where mutantS = mutantSEq-instance ShowMutable Int4  where mutantS = mutantSEq-instance ShowMutable Word1 where mutantS = mutantSEq-instance ShowMutable Word2 where mutantS = mutantSEq-instance ShowMutable Word3 where mutantS = mutantSEq-instance ShowMutable Word4 where mutantS = mutantSEq

@@ -1,133 +0,0 @@--- | General purpose utility functions for FitSpec-{-# LANGUAGE CPP #-}-module FitSpec.Utils-  ( (...)-  , uncurry3-  , count-  , compositions-  , subsets-  , contained-  , contains-  , filterU-  , sortAndGroupOn-  , sortAndGroupFstBySnd-  , sortGroupAndCollapse-  , takeWhileIncreasing-  , takeWhileIncreasingOn-  , lastTimeout-  , sortOn-  , (***)-  )-where--#if __GLASGOW_HASKELL__ <= 704-import Prelude hiding (catch)-#endif-import System.IO.Unsafe (unsafePerformIO)-import Control.Exception ( Exception-                         , SomeException-                         , ArithException-                         , ArrayException-                         , ErrorCall-                         , PatternMatchFail-                         , catch-                         , catches-                         , Handler (Handler)-                         , evaluate-                         )-import Data.Function (on)-import Data.Ord (comparing)-import Data.List (groupBy,sortBy)-import Data.IORef (newIORef, readIORef, writeIORef)-import Control.Concurrent (forkIO, threadDelay, killThread)-import Control.Monad (liftM)---- | Compose composed with compose operator.------ > (f ... g) x y === f (g x y)-(...) :: (c->d) -> (a->b->c) -> a -> b -> d-(...) = (.) . (.)--- f ... g = \x y -> f (g x y)--uncurry3 :: (a->b->c->d) -> (a,b,c) -> d-uncurry3 f (x,y,z) = f x y z--count :: (a -> Bool) -> [a] -> Int-count p = length . filter p---- | 'compositions' @bs@ returns all compositions formed by taking values of @bs@-compositions :: [Bool] -> [Bool]-compositions = map and . subsets---- | 'subsets' @xs@ returns the list of sublists formed by taking values of @xs@-subsets :: [a] -> [[a]]-subsets []     = [[]]-subsets (x:xs) = map (x:) (subsets xs) ++ subsets xs---- TODO: rename contained and contains to subset and superset?---- | Check if all elements of a list is contained in another list-contained :: Eq a => [a] -> [a] -> Bool-xs `contained` ys = all (`elem` ys) xs--contains :: Eq a => [a] -> [a] -> Bool-contains = flip contained---- | 'filterU' filter greater-later elements in a list according to a partial---   ordering relation.------ > filterU (notContained) [[1],[2],[1,2,3],[3,4,5]] == [[1],[2],[3,4,5]]-filterU :: (a -> a -> Bool) -> [a] -> [a]-filterU f []     = []-filterU f (x:xs) = x : filter (f x) (filterU f xs)--sortOn :: Ord b => (a -> b) -> [a] -> [a]-sortOn f = sortBy (compare `on` f)--sortAndGroupOn :: Ord b => (a -> b) -> [a] -> [[a]]-sortAndGroupOn f = groupBy ((==) `on` f)-                 . sortOn f--sortGroupAndCollapse :: Ord b-                     => (a -> b) -> (a -> c) -> (b -> [c] -> d)-                     -> [a] -> [d]-sortGroupAndCollapse f g h = map collapse-                           . sortAndGroupOn f-  where collapse (x:xs) = f x `h` map g (x:xs)--sortAndGroupFstBySnd :: Ord b => [(a,b)] -> [([a],b)]-sortAndGroupFstBySnd = sortGroupAndCollapse snd fst (flip (,))---- | Takes values from a list while the values increase.  If the original list---   is non-empty, the returning list will also be non-empty-takeWhileIncreasing :: (a -> a -> Ordering) -> [a] -> [a]-takeWhileIncreasing _ [] = []-takeWhileIncreasing _ [x] = [x]-takeWhileIncreasing cmp (x:y:xs) = x : case x `cmp` y of-                                         LT -> takeWhileIncreasing cmp (y:xs)-                                         _  -> []---takeWhileIncreasingOn :: Ord b => (a -> b) -> [a] -> [a]-takeWhileIncreasingOn f = takeWhileIncreasing (compare `on` f)----- | @lastTimeout s xs@ will take the last value of @xs@ it is able evaluate---   before @s@ seconds elapse.-lastTimeout :: Int -> [a] -> IO a-lastTimeout _ []     = error "lastTimeout: empty list"-lastTimeout 0 (x:_)  = return x  -- no time to lose-lastTimeout s (x:xs) = do-  r <- newIORef x-  tid <- forkIO $ keepImproving r xs-  threadDelay (s*1000000) -- TODO: change to waitForThread!!!-  killThread tid-  readIORef r-  where keepImproving _ []     = return ()-        keepImproving r (x:xs) = do-          evaluate x-          writeIORef r x-          keepImproving r xs--(***) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)-f *** g = \(x,y) -> (f x, g y)

@@ -20,7 +20,7 @@      $ cabal install fitspec -Pre-requisites are [cmdargs], [pretty] and [leancheck].+Pre-requisites are [cmdargs] and [leancheck]. They should be automatically resolved and installed by [Cabal].  

@@ -15,9 +15,3 @@  * write detailed install instructions on INSTALL.md   (cabal install, cabal from sandbox, source include)---v0.3-------* (?) rename FitSpec to Test.FitSpec

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-import FitSpec+import Test.FitSpec import AVLTree import Data.List (sort,nubBy) @@ -13,7 +13,7 @@ -- all possible mid-points of a list, then recursively -- generating trees for the rest of elements. instance (Ord a, Listable a) => Listable (Tree a) where-  tiers = map (nubBy same . sort) (consFromNoDupList fromList)+  tiers = map (nubBy same . sort) (noDupListCons fromList)  instance (Ord a, Listable a) => Mutable (Tree a) where   mutiers = mutiersEq

@@ -1,4 +1,4 @@-import FitSpec+import Test.FitSpec  propertiesN :: (Bool -> Bool) -> [Property] propertiesN not =

@@ -13,7 +13,7 @@ --   * allows switching between refinements -- 'digraphs ps 0', 'digraphs ps 1', ...; --   * uses polymorphism where it could use monomorphism. import Digraph as D-import FitSpec.Most+import Test.FitSpec import Data.List ((\\)) import qualified Data.List as L (delete) import Control.Monad

@@ -1,6 +1,6 @@ {-# Language DeriveDataTypeable, NoMonomorphismRestriction #-} import System.Console.CmdArgs hiding (args)-import FitSpec+import Test.FitSpec import Prelude hiding (null) import qualified Data.List as L import Data.Maybe (listToMaybe)@@ -8,7 +8,7 @@ import Control.Monad (unless)  instance (Ord a, Listable a) => Listable (Heap a) where-  tiers = consFromAscendingList fromList+  tiers = bagCons fromList  -- a good property to assure that the above does not leave out elements is: --

@@ -1,6 +1,6 @@ -- Example benchmark that mutation tests properties over the function id import System.Console.CmdArgs hiding (args)-import FitSpec+import Test.FitSpec  type Ty a = a -> a 

@@ -1,5 +1,5 @@ import System.Console.CmdArgs hiding (args)-import FitSpec+import Test.FitSpec import Data.List  type Cons a = a -> [a] -> [a]

@@ -1,6 +1,6 @@ {-# Language DeriveDataTypeable, NoMonomorphismRestriction #-} import System.Console.CmdArgs hiding (args)-import FitSpec+import Test.FitSpec import Prelude hiding (null) import qualified Data.List as L import Data.Maybe (listToMaybe)@@ -8,7 +8,7 @@ import Control.Monad (unless)  instance (Ord a, Listable a) => Listable (Heap a) where-  tiers = consFromAscendingList fromList+  tiers = bagCons fromList  instance (Ord a, Listable a) => Mutable (Heap a) where   mutiers = mutiersEq 

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-import FitSpec+import Test.FitSpec import Text.PrettyPrint  #if __GLASGOW_HASKELL__ < 710

@@ -1,9 +1,9 @@ import Set-import FitSpec hiding ((\/))+import Test.FitSpec hiding ((\/))   instance (Ord a, Listable a) => Listable (Set a) where-  tiers = consFromSet set+  tiers = setCons set  instance (Ord a, Listable a) => Mutable (Set a) where   mutiers = mutiersEq

@@ -1,9 +1,9 @@ import Set-import FitSpec hiding ((\/))+import Test.FitSpec hiding ((\/))   instance (Ord a, Listable a) => Listable (Set a) where-  tiers = consFromSet set+  tiers = setCons set  instance (Ord a, Listable a) => Mutable (Set a) where   mutiers = mutiersEq

@@ -1,6 +1,6 @@ -- Example benchmark that mutation tests properties over an infinite list of primes import System.Console.CmdArgs hiding (args)-import FitSpec+import Test.FitSpec import Data.Maybe  -- The code under test

@@ -1,5 +1,5 @@ import Data.List-import FitSpec+import Test.FitSpec   ordered :: Ord a => [a] -> Bool

@@ -1,5 +1,5 @@ import System.Console.CmdArgs hiding (args)-import FitSpec+import Test.FitSpec import Data.List  type Add  a = a -> a -> a

@@ -1,5 +1,5 @@ name:                fitspec-version:             0.2.2+version:             0.3.0 synopsis:            refining property sets for testing Haskell programs description:   FitSpec provides automated assistance in the task of refining test properties@@ -38,138 +38,144 @@ source-repository this   type:            git   location:        https://github.com/rudymatela/fitspec-  tag:             v0.2.2+  tag:             v0.3.0   library-  exposed-modules: FitSpec-                 , FitSpec.Engine-                 , FitSpec.Report-                 , FitSpec.Mutable-                 , FitSpec.Mutable.Tuples-                 , FitSpec.ShowMutable-                 , FitSpec.ShowMutable.Tuples-                 , FitSpec.Derive-                 , FitSpec.Main-                 , FitSpec.Most-                 , FitSpec.TestTypes-  other-modules: FitSpec.Utils-               , FitSpec.PrettyPrint-               , FitSpec.Dot+  exposed-modules: Test.FitSpec+                 , Test.FitSpec.Engine+                 , Test.FitSpec.Report+                 , Test.FitSpec.Mutable+                 , Test.FitSpec.Mutable.Tuples+                 , Test.FitSpec.ShowMutable+                 , Test.FitSpec.ShowMutable.Tuples+                 , Test.FitSpec.Derive+                 , Test.FitSpec.Main+                 , Test.FitSpec.TestTypes+  other-modules: Test.FitSpec.Utils+               , Test.FitSpec.PrettyPrint+               , Test.FitSpec.Dot   build-depends: base >= 4 && < 5, leancheck >= 0.4, cmdargs, template-haskell-  hs-source-dirs:    .+  hs-source-dirs:    src   default-language:  Haskell2010   test-suite mutate   type:                exitcode-stdio-1.0   main-is:             test-mutate.hs-  hs-source-dirs:      ., tests+  hs-source-dirs:      src, tests   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell   default-language:    Haskell2010  test-suite showmutable   type:                exitcode-stdio-1.0   main-is:             test-showmutable.hs-  hs-source-dirs:      ., tests+  hs-source-dirs:      src, tests   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell   default-language:    Haskell2010  test-suite derive   type:                exitcode-stdio-1.0   main-is:             test-derive.hs-  hs-source-dirs:      ., tests+  hs-source-dirs:      src, tests   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell   default-language:    Haskell2010 +test-suite utils+  type:                exitcode-stdio-1.0+  main-is:             test-utils.hs+  hs-source-dirs:      src, tests+  build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell+  default-language:    Haskell2010 + benchmark avltrees   main-is:           avltrees.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark bools   main-is:           bools.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark digraphs   main-is:           digraphs.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark heaps   main-is:           heaps.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark id   main-is:           id.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark list   main-is:           list.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark mergeheaps   main-is:           mergeheaps.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark pretty   main-is:           pretty.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell, pretty-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark sets   main-is:           sets.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark setsofsets   main-is:           setsofsets.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark sieve   main-is:           sieve.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark sorting   main-is:           sorting.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0  benchmark spring   main-is:           spring.hs   build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell-  hs-source-dirs:    ., bench+  hs-source-dirs:    src, bench   default-language:  Haskell2010   type:              exitcode-stdio-1.0

@@ -0,0 +1,106 @@+-- | FitSpec: refining property-sets for functional testing+--+-- FitSpec provides automated assistance in the task of refining test properties+-- for Haskell functions.  FitSpec tests mutant variations of functions under test+-- against a given property set, recording any surviving mutants that pass all+-- tests.  FitSpec then reports:+--+-- * /surviving mutants:/+--   indicating incompleteness of properties,+--   prompting the user to amend a property or to add a new one;+-- * /conjectures:/+--   indicating redundancy in the property set,+--   prompting the user to remove properties so to reduce the cost of testing.+--+-- Example, refining a @sort@ specification:+--+-- > import FitSpec+-- > import Data.List (sort)+-- >+-- > properties sort =+-- >   [ property $ \xs   -> ordered (sort xs)+-- >   , property $ \xs   -> length (sort xs) == length xs+-- >   , property $ \x xs -> elem x (sort xs) == elem x xs+-- >   , property $ \x xs -> notElem x (sort xs) == notElem x xs+-- >   , property $ \x xs -> minimum (x:xs) == head (sort (x:xs))+-- >   ]+-- >   where+-- >   ordered (x:y:xs) = x <= y && ordered (y:xs)+-- >   ordered _        = True+-- >+-- > main = mainWith args { names = ["sort xs"]+-- >                      , nMutants = 4000+-- >                      , nTests   = 4000+-- >                      , timeout  = 0+-- >                      }+-- >                 (sort::[Word2]->[Word2])+--+-- The above program reports the following:+--+-- > Apparent incomplete and non-minimal specification based on+-- > 4000 test cases for each of properties 1, 2, 3, 4 and 5+-- > for each of 4000 mutant variations.+-- >+-- > 3 survivors (99% killed), smallest:+-- >   \xs -> case xs of+-- >            [0,0,1] -> [0,1,1]+-- >            _ -> sort xs+-- >+-- > apparent minimal property subsets:  {1,2,3} {1,2,4}+-- > conjectures:  {3}    =  {4}     96% killed (weak)+-- >               {1,3} ==> {5}     98% killed (weak)+module Test.FitSpec+  (+  -- * Encoding properties+    Property+  , property++  -- * Configuring reports+  , Args (..), ShowMutantAs (..)+  , args+  , fixargs++  -- * Reporting results+  , report+  , reportWith+  , reportWithExtra++  -- ** Parsing command line arguments+  , mainWith+  , defaultMain+  , getArgs+  , getArgsWith++  -- * Mutable types+  , Mutable (..)+  , mutiersEq++  , ShowMutable (..)+  , mutantSEq+  , showMutantAsTuple+  , showMutantDefinition+  , showMutantNested+  , showMutantBindings++  -- * Automatic derivation+  , deriveMutable+  , deriveMutableE++  -- * Re-export modules+  , module Test.FitSpec.TestTypes+  , module Test.LeanCheck+  )+where++import Test.FitSpec.Engine+import Test.FitSpec.Report+import Test.FitSpec.Main++import Test.FitSpec.Mutable+import Test.FitSpec.Mutable.Tuples+import Test.FitSpec.ShowMutable+import Test.FitSpec.ShowMutable.Tuples+import Test.FitSpec.Derive+import Test.FitSpec.TestTypes++import Test.LeanCheck

@@ -0,0 +1,172 @@+-- | Experimental module for deriving Mutable instances+--+-- Needs GHC and Template Haskell+-- (tested on GHC 7.4, 7.6, 7.8, 7.10 and 8.0)+--+-- Despite Mutable instances being actually very simple, this module can be+-- used to derive those.  However, it will not work on all cases: when that+-- happens, you should write your instances manually.+{-# LANGUAGE TemplateHaskell, CPP #-}+module Test.FitSpec.Derive+  ( deriveMutable+  , deriveMutableE+  , module Test.FitSpec.Mutable+  , module Test.FitSpec.ShowMutable+  , module Test.LeanCheck+  )+where++import Test.FitSpec.Mutable+import Test.FitSpec.ShowMutable++import Test.LeanCheck+import Language.Haskell.TH+import Control.Monad (when, unless, liftM, liftM2)++#if __GLASGOW_HASKELL__ < 706+-- reportWarning was only introduced in GHC 7.6 / TH 2.8+reportWarning :: String -> Q ()+reportWarning = report False+#endif++deriveListableIfNeeded :: Name -> DecsQ+deriveListableIfNeeded t = do+  is <- t `isInstanceOf` ''Listable+  if is+    then return []+    else deriveListable t++-- | Derives a Mutable instance for a given type 'Name'.+deriveMutable :: Name -> DecsQ+deriveMutable = deriveMutableE []++-- | Derives a Mutable instance for a given type 'Name'+--   using a given context for all type variables.+deriveMutableE :: [Name] -> Name -> DecsQ+deriveMutableE cs t = do+  is <- t `isInstanceOf` ''Mutable+  if is+    then do+      reportWarning $ "Instance Mutable " ++ show t+                   ++ " already exists, skipping derivation"+      return []+    else do+      cd <- canDeriveMutable t+      unless cd (fail $ "Unable to derive Mutable " ++ show t)+      liftM2 (++) (deriveListableIfNeeded t) (reallyDeriveMutable cs t)++-- | Checks whether it is possible to derive a Mutable instance.+canDeriveMutable :: Name -> Q Bool+canDeriveMutable t = (t `isInstanceOf` ''Eq)+                 &&& (t `isInstanceOf` ''Show)+  where (&&&) = liftM2 (&&)++reallyDeriveMutable :: [Name] -> Name -> DecsQ+reallyDeriveMutable cs t = do+  (nt,vs) <- normalizeType t+#if __GLASGOW_HASKELL__ >= 710+  cxt <- sequence [ [t| $(conT c) $(return v) |]+#else+  cxt <- sequence [ classP c [return v]+#endif+                  | v <- vs, c <- ''Eq:''Listable:''Show:cs ]+#if __GLASGOW_HASKELL__ >= 708+  cxt |=>| [d| instance Mutable $(return nt)+                 where mutiers = mutiersEq+               instance ShowMutable $(return nt)+                 where mutantS = mutantSEq |]+#else+  return [ InstanceD+             cxt+             (AppT (ConT ''Mutable) nt)+             [ValD (VarP 'mutiers) (NormalB (VarE 'mutiersEq)) []]+         , InstanceD+             cxt+             (AppT (ConT ''ShowMutable) nt)+             [ValD (VarP 'mutantS) (NormalB (VarE 'mutantSEq)) []]+         ]+#endif+++-- * Template haskell utilities++-- Normalizes a type by applying it to necessary type variables, making it+-- accept "zero" parameters.  The normalized type is tupled with a list of+-- necessary type variables.+--+-- Suppose:+--+-- > data DT a b c ... = ...+--+-- Then, in pseudo-TH:+--+-- > normalizeType [t|DT|] == Q (DT a b c ..., [a, b, c, ...])+normalizeType :: Name -> Q (Type, [Type])+normalizeType t = do+  ar <- typeArity t+  vs <- newVarTs ar+  return (foldl AppT (ConT t) vs, vs)+  where+    newNames :: [String] -> Q [Name]+    newNames = mapM newName+    newVarTs :: Int -> Q [Type]+    newVarTs n = liftM (map VarT)+               $ newNames (take n . map (:[]) $ cycle ['a'..'z'])++-- Normalizes a type by applying it to units (`()`) while possible.+--+-- > normalizeTypeUnits ''Int    === [t| Int |]+-- > normalizeTypeUnits ''Maybe  === [t| Maybe () |]+-- > normalizeTypeUnits ''Either === [t| Either () () |]+normalizeTypeUnits :: Name -> Q Type+normalizeTypeUnits t = do+  ar <- typeArity t+  return (foldl AppT (ConT t) (replicate ar (TupleT 0)))++-- Given a type name and a class name,+-- returns whether the type is an instance of that class.+isInstanceOf :: Name -> Name -> Q Bool+isInstanceOf tn cl = do+  ty <- normalizeTypeUnits tn+  isInstance cl [ty]++-- | Given a type name, return the number of arguments taken by that type.+-- Examples in partially broken TH:+--+-- > arity ''Int        === Q 0+-- > arity ''Int->Int   === Q 0+-- > arity ''Maybe      === Q 1+-- > arity ''Either     === Q 2+-- > arity ''Int->      === Q 1+--+-- This works for Data's and Newtype's and it is useful when generating+-- typeclass instances.+typeArity :: Name -> Q Int+typeArity t = do+  ti <- reify t+  return . length $ case ti of+#if __GLASGOW_HASKELL__ < 800+    TyConI (DataD    _ _ ks _ _) -> ks+    TyConI (NewtypeD _ _ ks _ _) -> ks+#else+    TyConI (DataD    _ _ ks _ _ _) -> ks+    TyConI (NewtypeD _ _ ks _ _ _) -> ks+#endif+    _                            -> error $ "error (arity): symbol "+                                         ++ show t+                                         ++ " is not a newtype or data"++-- Append to instance contexts in a declaration.+--+-- > sequence [[|Eq b|],[|Eq c|]] |=>| [t|instance Eq a => Cl (Ty a) where f=g|]+-- > == [t| instance (Eq a, Eq b, Eq c) => Cl (Ty a) where f = g |]+(|=>|) :: Cxt -> DecsQ -> DecsQ+c |=>| qds = do ds <- qds+                return $ map (`ac` c) ds+#if __GLASGOW_HASKELL__ < 800+  where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds+        ac d                   _  = d+#else+  where ac (InstanceD o c ts ds) c' = InstanceD o (c++c') ts ds+        ac d                     _  = d+#endif

@@ -0,0 +1,70 @@+-- | Generate dotfiles (graphviz)+module Test.FitSpec.Dot where++import Test.FitSpec+import Test.FitSpec.Engine+import Test.FitSpec.Utils+import Data.List++-- | Given a list of pairs of property groups and their implications,+--   return implications between groups (transitive cases are ommitted).+groupImplications :: Eq i => [([[i]], [i])] -> [([[i]],[[i]])]+groupImplications [] = []+groupImplications (n:ns) = [ (fst n, fst n')+                           | n' <- filterU (not ... implies)+                                 . filter (n `implies`)+                                 $ ns+                           ] ++ groupImplications ns+  where actual (iss,is) = foldr union [] iss `union` is+        n `implies` m = actual n `contains` actual m++isObvious :: Eq i => [[i]] -> [[i]] -> Bool+isObvious as bs = or [ a `contains` b+                     | a <- as+                     , b <- bs ]++attachObviousness :: Eq i => [([[i]], [[i]])] -> [([[i]],[[i]],Bool)]+attachObviousness = map attachObviousness'+  where attachObviousness' (as,bs) = (as,bs,isObvious as bs)+++-- | Given a list of relations, generate a graphviz graph containing those relations.+--   Generate a dotfile from implications between groups.+genDotfileFromGI :: Show i+                 => [([[i]],[[i]],Bool)]+                 -> String+genDotfileFromGI = (\s -> "digraph G {\n" ++ s ++ "}\n")+                 . unlines+                 . map showEntry+  where showG = unwords . map show+        showEntry (iss,jss,p) = "\"" ++ showG iss ++ "\" -> \""+                                     ++ showG jss ++ "\""+                             ++ if p+                                  then " [ color = grey ]"+                                  else ""++-- | Equivalent to 'getResults' but returns a dotfile+getDotfile :: (Mutable a)+           => [a]+           -> Int -> Int -> a -> (a -> [Property])+           -> String+getDotfile ems m n f ps = genDotfileFromGI+                        . attachObviousness+                        . groupImplications+                        . map (\r -> (sets r, implied r))+                        $ getResultsExtra ems f ps m n++-- | Equivalent to report, but writes a dotfile to a file+writeDotfile :: (Mutable a)+             => String+             -> [a]+             -> Int -> Int -> a -> (a -> [Property])+             -> IO ()+writeDotfile fn ems m n f = writeFile fn . getDotfile ems m n f++-- | Equivalent to report, but writes a dotfile to stdout+putDotfile :: (Mutable a)+           => [a]+           -> Int -> Int -> a -> (a -> [Property])+           -> IO ()+putDotfile ems m n f = putStr . getDotfile ems m n f

@@ -0,0 +1,278 @@+-- | FitSpec: refining property-sets for functional testing+--+-- This is the main engine, besides "Test.FitSpec.Mutable".+module Test.FitSpec.Engine+  ( property+  , Property++  , getResults+  , getResultsExtra+  , getResultsExtraTimeout+  , Result (..)+  , Results++  , propertiesNTests+  , propertiesTestsExhausted+  , propertiesToMap+  , propertiesHold+  , propertiesCE++  , minimal+  , complete++  , reduceImplications+  , filterNonCanon+  , Conjecture (..)+  , conjectures+  )+where++import Test.LeanCheck.Error+import Test.FitSpec.Utils+import Data.Maybe (catMaybes, listToMaybe)+import Data.List ((\\),union,transpose)+import Test.FitSpec.Mutable++-- | An encoded representation of a property suitable for use by FitSpec.+--+-- Each list of strings is a printable representation of one possible choice of+-- argument values for the property.  Each boolean indicate whether the+-- property holds for this choice.+type Property = [([String],Bool)]+type Properties = [Property]++-- | Given a 'Testable' type (as defined by 'Test.LeanCheck'), returns a 'Property'.+--+-- This function should be used on every property to create a property list to+-- be passed to 'report', 'reportWith', 'mainDefault' or 'mainWith'.+--+-- > property $ \x y -> x + y < y + (x::Int)+property :: Testable a => a -> Property+property = results++propertyHolds :: Int -> Property -> Bool+propertyHolds n = all snd . take n++propertyCE :: Int -> Property -> Maybe String+propertyCE n = listToMaybe . map (unwords . fst) . filter (not . snd) . take n++propertiesToMap :: [Property] -> Int -> [Bool]+propertiesToMap ps n = map (propertyHolds n) ps++propertiesHold :: Int -> [Property] -> Bool+propertiesHold n = all (propertyHolds n)++propertiesCE :: Int -> [Property] -> Maybe String+propertiesCE n = listToMaybe+               . catMaybes+               . zipWith (\n -> fmap ((show n ++ ":  ") ++)) [1..]+               . map (propertyCE n)++propertiesNTests :: Int -> [Property] -> [Int]+propertiesNTests n = map (length . take n)++propertiesTestsExhausted :: Int -> [Property] -> [Bool]+propertiesTestsExhausted n = map (<= n) . propertiesNTests (n+1)++filterNonCanon :: [Result a] -> [Result a]+filterNonCanon [] = []+filterNonCanon (r:rs) = (r:)+                      . filterNonCanon+                      . filter (not . null . sets)+                      . map (updateSets removeNonCanon)+                      $ rs+  where removeNonCanon = filter (not . (\p' -> (p' `contains`) `any` tail (sets r)))+        updateSets f r = r { sets = f (sets r) }++reduceImplications :: [Result a] -> [Result a]+reduceImplications [] = []+reduceImplications (r:rs) = r : map (r `reduce`) (reduceImplications rs)+  where r `reduce` r' = if or [s `contained` s' | s <- sets r, s' <- sets r']+                          then r' { implied = implied r' \\ implied r }+                          else r'+++-- | A line of result for a single equivalence class of properties+--   with the exact same surviving mutants.+data Result a = Result+  { sets             :: [[Int]] -- ^ property-sets in the equivalence class+  , implied          :: [Int]   -- ^ properties implied by this class+  , survivors        :: [a]     -- ^ list of surviving mutants+  , smallestSurvivor :: Maybe a -- ^ smallest surviving mutant, if any+  , nSurvivors       :: Int -- ^ number of surviving mutants+  , nKilled          :: Int -- ^ number of killed mutants+  , totalMutants     :: Int -- ^ total number of mutants generated and tested+  , score            :: Int -- ^ percentage of killed mutants, 0-100+  , maxTests         :: Int -- ^ Requested number of tests (same for all rs.)+  , mutantsExhausted :: Bool -- ^ mutants were exhausted+  }+type Results a = [Result a]+++-- | Return minimality and completeness results.  See 'report'.+getResults :: (Mutable a)+           => a -> (a -> [Property]) -> Int -> Int+           -> Results a+getResults = getResultsExtra []++getResultsExtra :: (Mutable a)+                => [a]+                -> a -> (a -> [Property]) -> Int -> Int+                -> Results a+getResultsExtra ems f ps nms nts = map (uncurry $ processRawResult mex nts)+                                 $ getRawResults is pmap ms+  where is = [1..(length $ ps f)]+        pmap f = propertiesToMap (ps f) nts+        ms' = take (nms+1) (tail $ mutants f)+        mex = length ms' <= nms+        ms = take nms ms' ++ ems++getResultsExtraTimeout :: (Mutable a)+                       => Int+                       -> [a]+                       -> a -> (a -> [Property]) -> Int -> Int+                       -> IO (Results a)+getResultsExtraTimeout 0 ems f ps m n = return $ getResultsExtra ems f ps m n+getResultsExtraTimeout t ems f ps nm0 nt0 = lastTimeout t resultss+  where+    resultss = map fst+             $ takeWhileIncreasingOn ((totalMutants . head) *** id)+             [ (getResultsExtra ems f ps nm nt, propertiesNTests nt $ ps f)+             | (nm,nt) <- iterate (incHalf *** incHalf) (nm0,nt0) ]+    incHalf x = x + x `div` 2++processRawResult :: Bool -> Int -> [[Int]] -> [(a,Bool)] -> Result a+processRawResult mex nt iss mhs = Result+  { sets      = relevantPropertySets iss+  , implied   = relevantImplications iss+  , survivors = ms+  , smallestSurvivor = listToMaybe ms+  , nSurvivors   = ns+  , nKilled      = nk+  , totalMutants = nm+  , score        = nk*100 `div` nm+  , maxTests     = nt+  , mutantsExhausted = mex+  }+  where ms = [m | (m,h) <- mhs, h]+        nm = length mhs+        ns = length ms+        nk = nm - ns++minimal :: Results a -> Bool+minimal (r:_) = null (implied r)+             && length (sets r) == 1++complete :: Results a -> Bool+complete (r:_) = nSurvivors r == 0++relevantPropertySets :: Eq i => [[i]] -> [[i]]+relevantPropertySets = filterU (not ... contained) . sortOn length++relevantImplications :: Eq i => [[i]] -> [i]+relevantImplications iss = foldr union [] iss+                        \\ foldr union [] (relevantPropertySets iss)++-- | Returns a description of property sets, grouping the ones that had the+--   same surviving mutants.  The resulting list is ordered starting with the+--   least surviving mutants to the most surviving mutants.+--+-- Arguments:+--+-- * @is@: list of property ids (@length is == length (pmap x)@)+--+-- * @pmap@: a property map+--+-- * @ms@: list of mutants to apply to the property map+--+-- Return a list of tuples containing:+--+--   * a list of property sets+--   * a list of mutants paired with booleans indicating whether each survived+getRawResults :: [i] -> (a -> [Bool]) -> [a] -> [([[i]],[(a,Bool)])]+getRawResults is ps ms = (id *** (zip ms)) `map` getRawResults' is ps ms++-- | Returns a description of property sets, grouping the ones that had the+--   same surviving mutants.  The resulting list is ordered starting with the+--   least surviving mutants to the most surviving mutants.+--+-- Arguments:+--+-- * @is@: list of property ids (@length is == length (pmap x)@)+--+-- * @pmap@: a property map+--+-- * @ms@: list of mutants to apply to the property map+--+-- Return a list of tuples containing:+--+--   * a list of property sets+--   * a boolean list indicating whether a given mutant survived+getRawResults' :: [i] -> (a -> [Bool]) -> [a] -> [([[i]],[Bool])]+getRawResults' is pmap = sortOn (count id . snd)+                       . sortAndGroupFstBySnd+                       . zip (subsets is)+                       . transpose+                       . map (compositions . pmap)++-- | 'nSurv' @props fs@ returns the number of values that match+--   compositions of properties on the property map.+--+-- * @props@ should be a function from a value to a list of properties that+--   match that value (in the case of functions, functions that "survive" those+--   properties).+--+-- * @fs@ is a list of values to be mapped over by @props@+--+-- > length (nSurvivors props fs)  ==  2 ^ (length (props fs))+--+-- This function is otherwise unused in this file.  It is just a simpler+-- version of 'pssurv' to serve as documentation.+nSurv :: (a -> [Bool]) -> [a] -> [Int]+nSurv props = map (count id)+            . transpose+            . map (compositions . props)+++data Conjecture = Conjecture+  { isEq        :: Bool+  , isIm        :: Bool+  , cleft       :: [Int]+  , cright      :: [Int]+  , cscore      :: Int+  , cnKilled    :: Int+  , cnSurvivors :: Int+  } deriving Show++conjectures :: [Result a] -> [Conjecture]+conjectures = concatMap conjectures1+            . sortOn (abs . (50-) . score) -- closer to 50 the better!+            . reduceImplications+            . filterNonCanon+            . reverse++conjectures1 :: Result a -> [Conjecture]+conjectures1 r = [ p `eq` p' | p' <- ps ]+              ++ [ p `im` i  | (not.null) i ]+  where+    (p:ps) = sets r+    i      = implied r+    eq     = conj True+    im     = conj False+    conj isE p p' = Conjecture+      { isEq        = isE+      , isIm        = not isE+      , cleft       = p+      , cright      = p'+      , cscore      = score r+      , cnKilled    = nKilled r+      , cnSurvivors = nSurvivors r+      }+-- TODO: improve implication score+-- implication score can be improved by+-- by separating each implication on its own:+--   [4] ==> [2,3]+-- become+--   [4] ==> [2]+--   [4] ==> [3]+-- Then evaluating percentage of occurences of True ==> True and other cases

@@ -0,0 +1,69 @@+-- | Exports "main" functions for FitSpec.+-- They work exactly by 'report' and 'reportWith' but can be customized by+-- command line arguments.+--+-- > main = mainWith args { ... } functions properties+{-# Language DeriveDataTypeable, StandaloneDeriving #-}+module Test.FitSpec.Main+  ( mainWith+  , defaultMain+  , getArgs+  , getArgsWith+  , module Test.FitSpec.Report -- deprecated export, remove later+  )+where++import Test.FitSpec.Report+import System.Console.CmdArgs hiding (args)+import qualified System.Console.CmdArgs as CA (args)+import Control.Monad (liftM)+import Test.FitSpec.Mutable+import Test.FitSpec.ShowMutable++deriving instance Data ShowMutantAs+deriving instance Data Args+deriving instance Typeable ShowMutantAs+deriving instance Typeable Args++annotate :: Args -> Args+annotate as = Args+  { nMutants     = nMutants     as  &= name "m"+      &= help "(starting) number of function mutations"+  , nTests       = nTests       as  &= name "n"+      &= help "(starting) number of test values (each prop.)"+  , timeout      = timeout      as  &= name "t" &= name "s"+      &= help "timeout in seconds, 0 for just T*M"+  , names        = names        as+      &= ignore+  , rows         = rows         as+      &= help "how many rows of results to show"+  , verbose      = verbose      as+      &= help "activate verbose output"+  , showMutantAs = showMutantAs as  &= name "a"+      &= help "how to show mutants (tuple / nestedtuple / definition / bindings)"+      &= typ  "type"+  , extra        = extra        as  &= CA.args+      &= typ "extra arguments"+  } &= summary "FitSpec"+    &= program "program"+    &= help "Refine property-sets for functional testing"++getArgsWith :: Args -> IO Args+getArgsWith = cmdArgs . annotate++getArgs :: IO Args+getArgs = getArgsWith args++-- | Same as 'reportWith', but allow overriding of configuration via command+--   line arguments.+mainWith :: (Mutable a, ShowMutable a)+         => Args+         -> a -> (a -> [Property]) -> IO ()+mainWith as f ps = do+  as' <- getArgsWith as+  reportWith as' f ps++-- | Same as 'report', but allow configuration via command line arguments.+defaultMain :: (Mutable a, ShowMutable a)+            => a -> (a -> [Property]) -> IO ()+defaultMain = mainWith args

@@ -0,0 +1,186 @@+-- | Enumeration of function mutations+module Test.FitSpec.Mutable+  ( Mutable (..)+  , mutiersEq+--, mutantsIntegral+  )+where++import Test.LeanCheck+import Data.List (intercalate, delete)+import Data.Maybe+import Test.LeanCheck.Error (errorToNothing)++-- | This typeclass is similar to 'Listable'.+--+-- A type is 'Mutable' when there exists a function that+-- is able to list mutations of a value.+-- Ideally: list all possible values without repetitions.+--+-- Instances are usually defined by a 'mutiers' function that+-- given a value, returns tiers of mutants of that value:+--   the first  tier contains the equivalent mutant, of size 0,+--   the second tier contains mutants of size 1,+--   the third  tier contains mutants of size 2,+--   and so on.+--+-- The equivalent mutant is the actual function without mutations.+--+-- The size of a mutant is given by the sum of:+--   the number of mutated points (relations) and+--   the sizes of mutated arguments and results.+--+-- To get only inequivalent mutants,+-- just take the 'tail' of either 'mutants' or 'mutiers':+--+-- > tail mutants+--+-- > tail mutiers+--+-- Given that the underlying 'Listable' enumeration has no repetitions+-- parametric instances defined in this file will have no repeated mutants.+class Mutable a where+  mutiers :: a -> [[a]]+  mutants :: a -> [a]+  mutiers = map (:[]) . mutants+  mutants = concat . mutiers+  {-# MINIMAL mutants | mutiers #-}+++-- *** *** Instances for (non-functional) data types *** ***++-- | Implementation of 'mutiers' for non-functional data types.+-- Use this to create instances for user-defined data types, e.g.:+--+-- > instance MyData+-- >   where mutiers = mutiersEq+--+-- and for parametric datatypes:+--+-- > instance (Eq a, Eq b) => MyDt a b+-- >   where mutiers = mutiersEq+--+-- Examples:+--+-- > mutiersEq True = [[True], [False]]+-- > mutiersEq 2   = [[2], [0], [1], [], [3], [4], [5], [6], [7], [8], [9], ...]+-- > mutiersEq [1] = [[[1]], [[]], [[0]], [[0,0]], [[0,0,0],[0,1],[1,0],[-1]], ...]+mutiersEq :: (Listable a, Eq a) => a -> [[a]]+mutiersEq x = [x] : deleteT x tiers++-- | > mutants () = [()]+instance Mutable ()   where mutiers = mutiersEq++-- | > mutants 3 = [3,0,1,2,4,5,6,7,8,9,...+instance Mutable Int  where mutiers = mutiersEq++instance Mutable Char where mutiers = mutiersEq++-- | > mutants True = [True,False]+instance Mutable Bool where mutiers = mutiersEq -- > mutants True=[True,False]++-- | > mutants [0] = [ [0], [], [0,0], [1], ...+instance (Eq a, Listable a) => Mutable [a]       where mutiers = mutiersEq++-- | > mutants (Just 0) = [Just 0, Nothing, ...+instance (Eq a, Listable a) => Mutable (Maybe a) where mutiers = mutiersEq++{- Alternative implementations for Mutable Ints and Lists.+-- These do not improve results significantly.+-- That is why I have kept the simpler mutations above.++-- |- Generate mutants of an Integral value.+-- Alternates between successors and predecessors of the original number.+-- The enumeration starts "towards" zero.+mutantsIntegral :: Integral a => a -> [a]+mutantsIntegral i | i > 0     = [i..] +| tail [i,(i-1)..]+                  | otherwise = [i,(i-1)..] +| tail [i..]+-- NOTE: tail is there to avoid generating out of bound values+--       as (i-1) is usually safe while (i-2) is not.++instance Mutable Int  where mutants = mutantsIntegral++instance (Listable a, Mutable a) => Mutable [a]+  where mutiers []     = [ [] ]+                       : [ ]+                       : tail tiers+        mutiers (x:xs) = [ (x:xs) ]+                       : [ [] ]+                       : tail (lsProductWith (:) (mutiers x) (mutiers xs))+-- -}+++-- *** *** Instances for functional types *** ***++-- | Mutate a function at a single point.+-- The following two declarations are equivalent:+--+-- > id' = id `mut` (0,1)+--+-- > id' 0 = 1+-- > id' x = x+mut :: Eq a => (a -> b) -> (a,b) -> (a -> b)+mut f (x',fx') = \x -> if x == x'+                         then fx'+                         else f x++-- | Mutate a function at several points.+--+-- > f `mutate` [(x,a),(y,b),(z,c)] = f `mut` (x,a) `mut` (y,b) `mut` (z,c)+mutate :: Eq a => (a -> b) -> [(a,b)] -> (a -> b)+mutate f ms = foldr (flip mut) f ms -- or: foldl mut f ms++-- | Return tiers of possible mutations for a single point of a function.+-- If the function is undefined at that point, no mutations are provided.+-- This function does not return the null mutant.+--+-- > (+1) `mutationsFor` 1 = [ [(1,0)], [(1,1)], [], [(1,3)], [(1,4)], ...+mutationsFor :: Mutable b => (a->b) -> a -> [[(a,b)]]+mutationsFor f x = case errorToNothing (f x) of+                     Nothing -> []+                     Just fx -> ((,) x) `mapT` tail (mutiers fx)++-- | Returns tiers of mutants on a selection of arguments of a function.+-- Will only return the null mutant from an empty selection of arguments.+tiersMutantsOn :: (Eq a, Mutable b) => (a->b) -> [a] -> [[a->b]]+tiersMutantsOn f xs = mutate f `mapT` products (map (mutationsFor f) xs)++-- |+-- > mutants not =+-- >   [ not+-- >   , \p -> case p of False -> False; _ -> not p+-- >   , \p -> case p of True  -> True;  _ -> not p+-- >   , \p -> case p of False -> False; True -> True+-- >   ]+instance (Eq a, Listable a, Mutable b) => Mutable (a -> b) where+  mutiers f = tiersMutantsOn f `concatMapT` setsOf tiers+++-- *** *** Instances for tuples *** ***++-- | > mutants (0,1) = [(0,1),(0,0),(1,1),(0,-1),...]+instance (Mutable a, Mutable b) => Mutable (a,b) where+  mutiers (f,g) = mutiers f >< mutiers g++instance (Mutable a, Mutable b, Mutable c) => Mutable (a,b,c) where+  mutiers (f,g,h) = productWith (\f' (g',h') -> (f',g',h'))+                                (mutiers f) (mutiers (g,h))++instance (Mutable a, Mutable b, Mutable c, Mutable d)+      => Mutable (a,b,c,d) where+  mutiers (f,g,h,i) = productWith (\f' (g',h',i') -> (f',g',h',i'))+                                  (mutiers f) (mutiers (g,h,i))++instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e)+      => Mutable (a,b,c,d,e) where+  mutiers (f,g,h,i,j) = productWith (\f' (g',h',i',j') -> (f',g',h',i',j'))+                                    (mutiers f) (mutiers (g,h,i,j))++-- | For Mutable tuple instances greater than sixtuples, see+--   "FitSpec.Mutable.Tuples".  Despite being hidden in this Haddock+--   documentation, 7-tuples up to 12-tuples are exported by "Test.FitSpec".+instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, Mutable f)+      => Mutable (a,b,c,d,e,f) where+  mutiers (f,g,h,i,j,k) = productWith (\f' (g',h',i',j',k') ->+                                           (f',g',h',i',j',k'))+                                      (mutiers f) (mutiers (g,h,i,j,k))

@@ -0,0 +1,62 @@+-- | Mutable instances: septuples up to 12-tuples+--+-- This is part of a Hack that allows those instances to be hidden from Haddock.+-- Otherwise Haddock documentation will look very ugly.+module Test.FitSpec.Mutable.Tuples () where++import Test.FitSpec.Mutable+import Test.LeanCheck (productWith)++instance (Mutable a, Mutable b, Mutable c, Mutable d,+          Mutable e, Mutable f, Mutable g)+      => Mutable (a,b,c,d,e,f,g) where+  mutiers (f,g,h,i,j,k,l) = productWith (\f' (g',h',i',j',k',l') ->+                                             (f',g',h',i',j',k',l'))+                                        (mutiers f)+                                        (mutiers (g,h,i,j,k,l))++instance (Mutable a, Mutable b, Mutable c, Mutable d,+          Mutable e, Mutable f, Mutable g, Mutable h)+      => Mutable (a,b,c,d,e,f,g,h) where+  mutiers (f,g,h,i,j,k,l,m) = productWith (\f' (g',h',i',j',k',l',m') ->+                                               (f',g',h',i',j',k',l',m'))+                                          (mutiers f)+                                          (mutiers (g,h,i,j,k,l,m))++instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e,+          Mutable f, Mutable g, Mutable h, Mutable i)+      => Mutable (a,b,c,d,e,f,g,h,i) where+  mutiers (f,g,h,i,j,k,l,m,n) =+    productWith (\f' (g',h',i',j',k',l',m',n') ->+                   (f',g',h',i',j',k',l',m',n'))+                (mutiers f)+                (mutiers (g,h,i,j,k,l,m,n))++instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e,+          Mutable f, Mutable g, Mutable h, Mutable i, Mutable j)+      => Mutable (a,b,c,d,e,f,g,h,i,j) where+  mutiers (f,g,h,i,j,k,l,m,n,o) =+    productWith (\f' (g',h',i',j',k',l',m',n',o') ->+                   (f',g',h',i',j',k',l',m',n',o'))+                (mutiers f)+                (mutiers (g,h,i,j,k,l,m,n,o))++instance (Mutable a, Mutable b, Mutable c, Mutable d,+          Mutable e, Mutable f, Mutable g, Mutable h,+          Mutable i, Mutable j, Mutable k)+      => Mutable (a,b,c,d,e,f,g,h,i,j,k) where+  mutiers (f,g,h,i,j,k,l,m,n,o,p) =+    productWith (\f' (g',h',i',j',k',l',m',n',o',p') ->+                   (f',g',h',i',j',k',l',m',n',o',p'))+                (mutiers f)+                (mutiers (g,h,i,j,k,l,m,n,o,p))++instance (Mutable a, Mutable b, Mutable c, Mutable d,+          Mutable e, Mutable f, Mutable g, Mutable h,+          Mutable i, Mutable j, Mutable k, Mutable l)+      => Mutable (a,b,c,d,e,f,g,h,i,j,k,l) where+  mutiers (f,g,h,i,j,k,l,m,n,o,p,q) =+    productWith (\f' (g',h',i',j',k',l',m',n',o',p',q') ->+                   (f',g',h',i',j',k',l',m',n',o',p',q'))+                (mutiers f)+                (mutiers (g,h,i,j,k,l,m,n,o,p,q))

@@ -0,0 +1,141 @@+-- | Poor man's pretty printing library+--+-- This module has somewhat inefficient implementations that could be improved+-- in the future.  i.e.: heavy use of '(++)'.+module Test.FitSpec.PrettyPrint+  ( beside+  , above+  , showTuple+  , table+  , columns+  , showQuantity+  , showEach+  , headToUpper+  )+where++import Data.List (intercalate,transpose,isSuffixOf)+import Data.Char (toUpper)++showQuantity :: Int -> String -> String+showQuantity 1 what = "1 " ++ what+showQuantity n what = show n ++ " " ++ pluralize what++showEach :: Show a => String -> [a] -> String+showEach what [x] = what ++ " " ++ show x+showEach what xs  = "each of " ++ pluralize what ++ " "+                 ++ intercalate ", " (map show $ init xs)+                 ++ " and "+                 ++ show (last xs)++-- | Pluralizes a word.+-- Is not comprehensive (and may never be),+-- add missing cases as they are found.+--+-- > pluralize "test case" == "test cases"+-- > pluralize "property"  == "properties"+pluralize :: String -> String+pluralize s | s `ew` "se" = s ++ "s"+            | s `ew` "n"  = s ++ "s"+            | s `ew` "y"  = init s ++ "ies"+            | otherwise   = s+  where ew = flip isSuffixOf+++-- | Appends two Strings side by side, line by line+--+-- > beside ["asdf\nqw\n","zxvc\nas"] ==+-- >  "asdfzxvc\n\+-- >  \qw  as\n"+beside :: String -> String -> String+beside cs ds = unlines $ zipWith (++) (normalize ' ' css) dss+  where [css,dss] = normalize "" [lines cs,lines ds]++-- | Append two Strings on top of each other, adding line breaks *when needed*.+above :: String -> String -> String+above cs ds = if last cs == '\n' || head ds == '\n'+                then cs ++ ds+                else cs ++ '\n':ds++-- | Show elements of a list as a tuple.  If there are multiple lines in any of+--   the strings, tuple is printed multiline.+--+-- > showTuple ["asdf\nqwer\n","zxvc\nasdf\n"] ==+-- >   "( asdf\n\+-- >   \  qwer\n\+-- >   \, zxvc\n\+-- >   \  asdf )\n"+--+-- > showTuple ["asdf","qwer"] == "(asdf,qwer)"+showTuple :: [String] -> String+showTuple []  = ""+showTuple [s] = s+showTuple (s:ss) =+  if any ('\n' `elem`) (s:ss)+    then "( " `beside` s+      ++ init (concatMap (", " `beside`) ss)+      ++ " )\n"+    else "(" ++ intercalate "," (s:ss) ++ ")"++-- | Formats a table using a given separator.+--+-- > table "  " [ ["asdf", "qwer",     "zxvc\nzxvc"]+-- >            , ["0",    "1",        "2"]+-- >            , ["123",  "456\n789", "3"] ] ==+-- >   "asdf  qwer  zxvc\n\+-- >   \            zxvc\n\+-- >   \0     1     2\n\+-- >   \123   456   3\n\+-- >   \      789\n\"+table :: String -> [[String]] -> String+table s []  = ""+table s sss = unlines+            . map (removeTrailing ' ')+            . map (intercalate s)+            . transpose+            . map (normalize ' ')+            . foldr1 (zipWith (++))+            . map (normalize "" . map lines)+            . normalize ""+            $ sss++-- | Given a separator, format strings in columns+--+-- > columns " | " ["asdf", "qw\nzxcv", "as\ndf"] ==+-- >   "asdf | qw   | as\n\+-- >   \     | zxcv | df\n"+columns :: String -> [String] -> String+columns s = unlines+          . map (removeTrailing ' ')+          . map (intercalate s)+          . transpose+          . map (normalize ' ')+          . normalize ""+          . map lines++-- | Fits a list to a certain width by appending a certain value+--+-- > fit ' ' 6 "str" == "str   "+--+-- > fit 0 6 [1,2,3] == [1,2,3,0,0,0]+fit :: a -> Int -> [a] -> [a]+fit x n xs = xs ++ replicate (n - length xs) x++-- | normalize makes all list the same length by adding a value+--+-- > normalize ["asdf","qw","er"] == normalize ["asdf","qw  ","er  "]+normalize :: a -> [[a]] -> [[a]]+normalize x xs = map (x `fit` maxLength xs) xs++-- | Given a list of lists returns the maximum length+maxLength :: [[a]] -> Int+maxLength = maximum . (0:) . map length++removeTrailing :: Eq a => a -> [a] -> [a]+removeTrailing x = reverse+                 . dropWhile (==x)+                 . reverse++headToUpper :: [Char] -> [Char]+headToUpper [] = []+headToUpper (c:cs) = toUpper c : cs

@@ -0,0 +1,246 @@+module Test.FitSpec.Report+  ( report+  , reportWith+  , reportWithExtra+  , Args(..)+  , args+  , fixargs+  , Property+  , ShowMutantAs(..)+  )+where++import Data.List (intercalate, intersperse)+import Data.Maybe (fromMaybe)++import Test.FitSpec.Engine+import Test.FitSpec.Mutable+import Test.FitSpec.ShowMutable+import Test.FitSpec.Utils+import Test.FitSpec.PrettyPrint++-- | How to show mutants.  Use this to fill 'showMutantAs'.+data ShowMutantAs = Tuple      | NestedTuple+                  | Definition | Bindings++-- | Extra arguments / configuration for 'reportWith'.+--   See 'args' for default values.+data Args = Args+  { nMutants :: Int -- ^ (starting) number of function mutations+  , nTests   :: Int -- ^ (starting) number of test values (for each prop.)+  , timeout  :: Int -- ^ timeout in seconds, 0 for just 'nTests' * 'nMutants'+  , names    :: [String] -- ^ names of functions: @["foo x y","goo x y"]@++  -- advanced options:+  , verbose      :: Bool         -- ^ whether to show detailed results+  , showMutantAs :: ShowMutantAs -- ^ how to show mutants+  , rows         :: Maybe Int    -- ^ number of surviving mutants to show+  , extra        :: [String]     -- ^ ignored argument (user defined meaning)+  }++-- | Default arguments for 'reportWith':+--+-- * @nMutants = 500@, start with  500 mutants+--+-- * @nTests = 1000@,  start with 1000 test values+--+-- * @timeout = 5@, keep incresing the number of mutants+--                  until 5 seconds elapse+--+-- * @names = []@, default function call template:+--+--   > ["f x y z", "g x y z", "h x y z", ...]+args :: Args+args = Args { nMutants     =  500+            , nTests       = 1000+            , timeout      = 5  -- seconds+            , names        = []+            , verbose      = False+            , showMutantAs = Tuple+            , rows         = Nothing+            , extra        = []+            }++-- | Non timed-out default arguments.+-- Make conjectures based on a fixed number of mutants and tests, e.g.:+--+-- > reportWith (fixargs 100 200) f pmap+--+-- This is just a shorthand, see:+--+-- > fixargs nm nt  =  args { nMutants = nm, nTests = nt, timeout = 0 }+--+-- > (fixargs nm nt) { nMutants = 500, nTests = 1000, timeout = 5 }  =  args+fixargs :: Int -> Int -> Args+fixargs nm nt = args+  { nMutants = nm+  , nTests   = nt+  , timeout  = 0+  }++showMutant :: ShowMutable a => Args -> a -> a -> String+showMutant as = showMutantByType (showMutantAs as) (names as)+  where+    showMutantByType Tuple       = showMutantAsTuple+    showMutantByType NestedTuple = showMutantNested+    showMutantByType Definition  = showMutantDefinition+    showMutantByType Bindings    = showMutantBindings++-- | Report results generated by FitSpec.+-- Uses standard configuration (see 'args').+-- Needs a function to be mutated and a property map.+-- Example (specification of boolean negation):+--+-- > properties not =+-- >   [ property $ \p -> not (not p) == p+-- >   , property $ \p -> not (not (not p)) == not p+-- >   ]+-- >+-- > main = report not properties+report :: (Mutable a, ShowMutable a)+       => a -> (a -> [Property]) -> IO ()+report = reportWith args+++-- | Same as 'report' but can be configured via 'Args' ('args' or 'fixargs'),+--   e.g.:+--+-- > reportWith args { timeout = 10 } fun properties+reportWith :: (Mutable a, ShowMutable a)+           => Args -> a -> (a -> [Property]) -> IO ()+reportWith = reportWithExtra []+++-- | Same as 'reportWith', but accepts a list of manually defined (extra)+--   mutants to be tested alongside those automatically generated.+reportWithExtra :: (Mutable a, ShowMutable a)+                => [a] -> Args -> a -> (a -> [Property]) -> IO ()+reportWithExtra extraMutants args f properties = do+  let nm = nMutants args+      nt = nTests args+  case propertiesCE nt (properties f) of+    Nothing -> reportWithExtra' extraMutants args f properties+    Just ce -> do+      putStrLn $ "ERROR: The original function-set does not follow property set for "+              ++ show nt ++ " tests"+      putStrLn $ "Counter-example to property " ++ ce+      putStrLn $ "Aborting."++-- | Same as 'reportWithExtra', does not abort if the original function does not+--   follow the property set.+reportWithExtra' :: (Mutable a, ShowMutable a)+                 => [a] -> Args -> a -> (a -> [Property]) -> IO ()+reportWithExtra' extraMutants args f properties = do+  results <- getResultsExtraTimeout (timeout args)+                                    extraMutants+                                    f properties+                                    (nMutants args) (nTests args)++  let nm = totalMutants $ head results+      nt = maxTests $ head results+      nts = propertiesNTests nt (properties f)+      tex = and $ propertiesTestsExhausted nt (properties f)+      mex = mutantsExhausted $ head results+      apparent | tex && mex = ""+               | otherwise  = "apparent "+  putStrLn . headToUpper $ apparent ++ qualifyCM results ++ " specification based on"+  putStrLn $ showNumberOfTestsAndMutants tex mex nts nm False++  let showR | verbose args = showDetailedResults+            | otherwise    = showResults+  putStrLn $ showR (rows args) (showMutant args f) results+++showResults :: Maybe Int -> (a -> String)+            -> [Result a] -> String+showResults mlimit showMutant rs@(r:_) = completeness+                              ++ "\n" ++ minimality+  where+    showMutants ms = init . unlines $ map showMutant ms+    completeness = show (nSurvivors r) ++ " survivors ("+                ++ show (score r) ++ "% killed)"+                ++ case take (fromMaybe 1 mlimit) $ survivors r of+                     [] -> ".\n"+                     [m] -> ", smallest:\n"+                         ++ "  " `beside` showMutant m+                     ms  -> ", " ++ show (length ms) ++ " smallest:\n"+                         ++ "  " `beside` showMutants ms+    minimality = "apparent minimal property subsets:  "+              ++ (unwords . map showPropertySet $ sets r) ++ "\n"+              ++ case showConjectures False rs of+                   "" -> "No conjectures.\n"+                   cs -> "conjectures:  " `beside` cs+++showDetailedResults :: Maybe Int -> (a -> String)+                    -> [Result a] -> String+showDetailedResults mlimit showMutant rs = completeness+                                ++ "\n" ++ minimality+  where+    completeness = table "   " . intersperse ["\n"]+                 . ([ "Property\n sets"+                    , "#Survivors\n (%Killed)"+                    , "Smallest or simplest\n surviving mutant"+                    ]:)+                 . map showResult+                 . maybe id take mlimit+                 $ rs+    showResult r = [ unwords . map showPropertySet $ sets r+                   , show  (nSurvivors r) ++ " (" ++ show (score r) ++ "%)"+                   , maybe "" showMutant $ smallestSurvivor r+                   ]+    minimality = case showConjectures True rs of+                   "" -> "No conjectures.\n"+                   cs -> "Conjectures:\n" ++ cs+++showNumberOfTestsAndMutants :: Bool -> Bool -> [Int] -> Int -> Bool -> String+showNumberOfTestsAndMutants tex mex nts nm ssum = numTests ++ numMutants+  where+    mexS | mex = " (exhausted)"+         | otherwise = ""+    numMutants = "for each of " ++ showQuantity nm "mutant variation" ++ mexS ++ ".\n"+    numTests | ssum = showQuantity (sum nts) "test case"+                   ++ (if tex then " (exhausted)" else "")+                   ++ "\n"+             | otherwise = unlines+                         . (++ ["(test cases exhausted)" | tex])+                         . sortGroupAndCollapse fst snd testsForProps+                         $ zip nts [1..]+    testsForProps n ps = showQuantity n "test case"+                      ++ " for " ++ showEach "property" ps++showPropertySet :: Show i => [i] -> String+showPropertySet = (\s -> "{" ++ s ++ "}") . intercalate "," . map show+++-- | Show conjectures derived from results+showConjectures :: Bool -> [Result a] -> String+showConjectures showVeryWeak = table " "+                             . map showConjecture+                             . filter (\r -> showVeryWeak+                                          || cnKilled r    /= 0+                                          && cnSurvivors r /= 0)+                             . conjectures++showConjecture :: Conjecture -> [String]+showConjecture Conjecture {isEq=eq, cleft=l, cright=r, cscore=s} =+  [ showPropertySet l+  , if eq then " = " else "==>"+  , showPropertySet r+  , "   "+  , show s ++ "% killed"+  , sMeaning+  ]+  where sMeaning | s < 1  || 99 < s = "(very weak)"+                 | s < 11 || 89 < s = "(weak)"+                 | s < 33 || 67 < s = "(mild)"+                 | otherwise        = "(strong)" -- the closer to 50 the better++qualifyCM :: Results a -> String+qualifyCM rs | c && m    = "complete and minimal"+             | c         = "complete but non-minimal"+             |      m    = "minimal but incomplete"+             | otherwise = "incomplete and non-minimal"+  where c = complete rs+        m = minimal rs

@@ -0,0 +1,362 @@+-- | Show mutant variations+module Test.FitSpec.ShowMutable+  ( ShowMutable (..)+  , mutantSEq+  , showMutantAsTuple+  , showMutantNested+  , showMutantDefinition+  , showMutantBindings+  , MutantS ()+  , mutantSTuple+  )+where++import Test.FitSpec.PrettyPrint+import Test.LeanCheck.Error (errorToNothing, Listable(..))+import Data.Maybe (mapMaybe,isNothing)+import Control.Monad (join)+import Data.List (intercalate,tails)+import Data.Char (isLetter)+++-- | Show a Mutant as a tuple of lambdas.+--+-- > > putStrLn $ showMutantAsTuple ["p && q","not p"] ((&&),not) ((||),id)+-- > ( \p q -> case (p,q) of+-- >            (False,False) -> True+-- >            _ -> p && q+-- >, \p -> case p of+-- >          False -> False+-- >          True -> True+-- >          _ -> not p )+--+-- Can be easily copy pasted into an interactive session for manipulation.+-- On GHCi, use @:{@ and @:}@ to allow multi-line expressions and definitions.+showMutantAsTuple :: ShowMutable a => [String] -> a -> a -> String+showMutantAsTuple names f f' = showMutantSAsTuple names+                             $ flatten+                             $ mutantS f f'++-- | Show a Mutant as the list of bindings that differ from the original+--   function(s).+--+-- > > putStrLn $ showMutantBindings ["p && q","not p"] ((&&),not) ((==),id)+-- > False && False = True+-- > not False = False+-- > not True  = True+--+-- Can possibly be copied into the source of the original function for+-- manipulation.+showMutantBindings :: ShowMutable a => [String] -> a -> a -> String+showMutantBindings names f f' = showMutantSBindings False names+                              $ flatten+                              $ mutantS f f'++-- | Show a Mutant as a new complete top-level definition, with a prime+-- appended to the name of the mutant.+--+-- > > putStrLn $ showMutantDefinition ["p && q","not p"] ((&&),not) ((==),id)+-- > False &&- False = True+-- > p     &&- q     = p && q+-- > not' False = False+-- > not' True  = True+-- > not' p     = not p+showMutantDefinition :: ShowMutable a => [String] -> a -> a -> String+showMutantDefinition names f f' = showMutantSBindings True names+                               $ flatten+                               $ mutantS f f'++-- | Show a Mutant as a tuple of nested lambdas.+-- Very similar to 'showMutantAsTuple', but the underlying data structure is+-- not flatten: so the output is as close as possible to the underlying+-- representation.+showMutantNested :: ShowMutable a => [String] -> a -> a -> String+showMutantNested names f f' = showMutantSAsTuple names+                            $ mutantS f f'++-- | Show a Mutant without providing a default name.+-- An alias for @showMutantAsTuple []@.+showMutant :: ShowMutable a => a -> a -> String+showMutant = showMutantAsTuple []+++-- | Default function names (when none given):+--+-- > f g h f' g' h' f'' g'' h''+defaultFunctionNames :: [String]+defaultFunctionNames = ["f","g","h"] ++ map (++"'") defaultFunctionNames++-- | Default names in a call (function and variables):+--+-- > f x y z w x' y' z' w' x'' y'' z'' w'' ...+defaultNames :: [String]+defaultNames = head defaultFunctionNames : defVarNames+  where defVarNames = ["x","y","z","w"] ++ map (++"'") defVarNames+++-- | Types that can have their mutation shown.+-- Has only one function 'mutantS' that returns a simple AST ('MutantS')+-- representing the mutant.  A standard implementation of 'mutantS' for 'Eq'+-- types is given by 'mutantSEq'.+class ShowMutable a where+  mutantS :: a -> a -> MutantS++-- | For a given type @Type@ instance of @Eq@ and @Show@,+-- define the 'ShowMutable' instance as:+--+-- > instance ShowMutable Type+-- >   where mutantS = mutantSEq+mutantSEq :: (Eq a, Show a)+          => a -> a -> MutantS+mutantSEq x x' = if x == x'+                    then Unmutated $ show x+                    else Atom      $ show x'++instance ShowMutable ()   where mutantS = mutantSEq+instance ShowMutable Int  where mutantS = mutantSEq+instance ShowMutable Char where mutantS = mutantSEq+instance ShowMutable Bool where mutantS = mutantSEq+instance (Eq a, Show a) => ShowMutable [a]       where mutantS = mutantSEq+instance (Eq a, Show a) => ShowMutable (Maybe a) where mutantS = mutantSEq++instance (Listable a, Show a, ShowMutable b) => ShowMutable (a->b) where+  -- TODO: let the user provide how many values should be tried when printing+  mutantS f f' = Function+               . take 10+               . filter (not . isUnmutated . snd)+               . mapMaybe bindingFor+               . take 200+               $ list+    where bindingFor x = fmap ((,) [show x])+                       $ errorToNothing (mutantS (f x) (f' x))++instance (ShowMutable a, ShowMutable b) => ShowMutable (a,b) where+  mutantS (f,g) (f',g') = Tuple [ mutantS f f'+                                , mutantS g g' ]++instance (ShowMutable a, ShowMutable b, ShowMutable c)+      => ShowMutable (a,b,c) where+  mutantS (f,g,h) (f',g',h') = Tuple [ mutantS f f'+                                     , mutantS g g'+                                     , mutantS h h' ]+++-- | (Show) Structure of a mutant.+-- This format is intended for processing then pretty-printing.+data MutantS = Unmutated String+             | Atom String+             | Tuple [MutantS]+             | Function [([String],MutantS)]+  deriving Show++-- | Check if a 'MutantS' is null+isUnmutated :: MutantS -> Bool+isUnmutated (Unmutated _) = True+isUnmutated (Tuple ms)    = all isUnmutated ms+isUnmutated (Function bs) = all (isUnmutated . snd) bs+isUnmutated _             = False++-- | Check if a 'MutantS' is a function.+isFunction :: MutantS -> Bool+isFunction (Function _) = True+isFunction _            = False++-- | Flatten a MutantS by merging nested 'Function's.+flatten :: MutantS -> MutantS+flatten (Tuple ms) = Tuple $ map flatten ms+flatten (Function [([],s)])  = flatten s+flatten (Function (([],s):_)) = error "flatten: ambiguous value"+flatten (Function bs) = let bs' = map (mapSnd flatten) bs in+  if any (not . isFunction . snd) bs'+    then Function bs'+    else Function+       $ take 10+       $ concatMap (\(as,Function bs'') -> map (mapFst (as++)) bs'') bs'+flatten m = m+++-- | Show a nameless mutant.+-- Functions should not (but can) be shown using this.+showMutantS :: MutantS -> String+showMutantS (Unmutated s) = s+showMutantS (Atom s)      = s+showMutantS (Tuple ms)    = showTuple $ map showMutantS ms+showMutantS (Function bs) = showLambda ["??"] bs++-- | Show top-level (maybe tuple) named 'MutantS' as a tuple.+showMutantSAsTuple :: [String] -> MutantS -> String+showMutantSAsTuple ns (Tuple ms) = showTuple $ zipWith show1 (ns +- defaultFunctionNames) ms+  where show1 n  (Unmutated _) = n+        show1 n  (Function bs) = showLambda (fvnames n) bs+        show1 _  m             = showMutantS m+showMutantSAsTuple ns m = showMutantSAsTuple ns (Tuple [m])++-- | Show top-level (maybe tuple) named 'MutantS' as a bindings.+-- In general, you want to 'flatten' the 'MutantS' before applying this+-- function.+showMutantSBindings :: Bool -> [String] -> MutantS -> String+showMutantSBindings new ns (Tuple ms) = concatMap (uncurry show1)+                                  $ zip (ns ++ defaultFunctionNames) ms+  where show1 _ (Unmutated s) = ""+        show1 _ (Function []) = ""+        show1 n (Function bs) = showBindings new (fvnames n) bs+        show1 n m             = let fn = head $ fvnames n+                                    fn' | new = prime fn+                                        | otherwise = fn+                                in (apply fn' [] ++ " = ")+                          `beside` showMutantS m+showMutantSBindings new ns m = showMutantSBindings new ns (Tuple [m])+++-- | Given a list with the function and variable names and a list of bindings,+-- show a function as a case expression enclosed in a lambda.+showLambda :: [String] -> [([String],MutantS)] -> String+showLambda []    [] = "undefined {- (err?) unmutated -}"+showLambda (n:_) [] = apply n []+showLambda _ [([],m)]   = showMutantS m+showLambda _ (([],_):_) = "undefined {- (err?) ambiguous value -}"+showLambda ns bs = (("\\" ++ unwords bound ++ " -> ") `beside`)+                 $ "case " ++ showTuple bound ++ " of\n"+                ++ "  " `beside` cases+  where+    cases = concatMap (\(as,r) -> (showTuple as ++ " -> ") `beside` showResult r) bs+         ++ "_ -> " ++ apply fn bound+    showResult (Function bs') = showLambda (apply fn bound:unbound) bs'+    showResult m              = showMutantS m+    unbound  = drop (length bound) vns+    bound    = zipWith const vns (fst $ head bs)+    (fn:vns) = ns +- defaultNames++-- | Given a list with the function and variable names and a list of bindings,+-- show function binding declarations.+--+-- The 'new' boolean argument indicates whether if the function should be shown+-- as a new definition.+showBindings :: Bool -> [String] -> [([String],MutantS)] -> String+showBindings new ns bs =+  table " " $ (uncurry showBind `map` bs)+           ++ [words (apply fn' bound) ++ ["=", apply fn bound] | new]+  where+    showBind [a1,a2] r | isInfix fn' = [a1, fn', a2,   "=", showMutantS r]+    showBind as r                    = [fn'] ++ as ++ ["=", showMutantS r]+    fn' | new = prime fn+        | otherwise = fn+    bound    = zipWith const vns (fst $ head bs)+    (fn:vns) = ns +- defaultNames+++-- | Separate function from variable names in a simple Haskell expr.+--+-- > fvarnames "f x y" == ["f","x","y"]+-- > fvarnames "aa bb cc dd" == ["aa","bb","cc","dd"]+--+-- When there are three lexemes, the function checks for a potential infix+-- operator in the middle.+--+-- > fvarnames "x + y" == ["(+)","x","y"]+-- +-- This function always returns a "head"+--+-- > fvarnames "" == ["f"]+fvnames :: String -> [String]+fvnames = fvns' . words+  where fvns' :: [String] -> [String]+        fvns' [a,o,b] | isInfix o = o:[a,b]+        fvns' []      = defaultNames+        fvns' fvs     = fvs++-- | Apply a function ('String') to a list of variables ('[String]').+--+-- For the sake of clarity, in the following examples, double-quotes are omitted:+-- > apply f       == f+-- > apply f x     == f x+-- > apply f x y   == f x y+-- > apply (+)     == (+)+-- > apply (+) x   == (+) x+-- > apply (+) x y == (+) x y+-- > apply +       == (+)+-- > apply + x     == (+) x+-- > apply + x y   == (x + y)+-- > apply + x y z == (+) x y z+apply :: String -> [String] -> String+apply f [x,y] | isInfix f = unwords [x,f,y]+apply f xs = if isInfix f+               then unwords (toPrefix f:xs)+               else unwords (f:xs)++-- | Check if a function / operator is infix+--+-- > isInfix "foo"   == False+-- > isInfix "(+)"   == False+-- > isInfix "`foo`" == True+-- > isInfix "+"     == True+isInfix :: String -> Bool+isInfix (c:cs) = c /= '(' && not (isLetter c)++-- | Transform an infix operator into an infix function:+--+-- > toPrefix "`foo`" == "foo"+-- > toPrefix "+"     == "(+)"+toPrefix :: String -> String+toPrefix ('`':cs) = init cs+toPrefix cs = '(':cs ++ ")"++-- Primeify the name of a function by appending prime @'@ to functions and+-- minus @-@ to operators.+--+-- > prime "(+)"   == "(+-)"+-- > prime "foo"   == "foo'"+-- > prime "`foo`" == "`foo'`"+-- > prime "*"     == "*-+prime :: String -> String+prime ('`':cs) = '`':init cs ++ "'`" -- `foo` to `foo'`+prime ('(':cs) = '(':init cs ++ "-)" -- (+) to (+-)+prime cs | isInfix cs = cs ++ "-"    -- + to +-+         | otherwise  = cs ++ "'"    -- foo to foo'+++mapFst :: (a->b) -> (a,c) -> (b,c)+mapFst f (x,y) = (f x,y)++mapSnd :: (a->b) -> (c,a) -> (c,b)+mapSnd f (x,y) = (x,f y)++-- | @xs +- ys@ superimposes @xs@ over @ys@.+--+-- [1,2,3] +- [0,0,0,0,0,0,0] == [1,2,3,0,0,0,0]+-- [x,y,z] +- [a,b,c,d,e,f,g] == [x,y,z,d,e,f,g]+-- "asdf" +- "this is a test" == "asdf is a test"+(+-) :: Eq a => [a] -> [a] -> [a]+xs +- ys = xs ++ drop (length xs) ys+++-- Instances of ShowMutable for up to 6-tuples are given here:++instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d)+      => ShowMutable (a,b,c,d) where+  mutantS (f,g,h,i) (f',g',h',i') = Tuple [ mutantS f f'+                                          , mutantS g g'+                                          , mutantS h h'+                                          , mutantS i i' ]++instance (ShowMutable a, ShowMutable b, ShowMutable c,+          ShowMutable d, ShowMutable e)+      => ShowMutable (a,b,c,d,e) where+  mutantS (f,g,h,i,j) (f',g',h',i',j') = Tuple [ mutantS f f'+                                               , mutantS g g'+                                               , mutantS h h'+                                               , mutantS i i'+                                               , mutantS j j' ]++instance (ShowMutable a, ShowMutable b, ShowMutable c,+          ShowMutable d, ShowMutable e, ShowMutable f)+      => ShowMutable (a,b,c,d,e,f) where+  mutantS (f,g,h,i,j,k) (f',g',h',i',j',k') = Tuple [ mutantS f f'+                                                    , mutantS g g'+                                                    , mutantS h h'+                                                    , mutantS i i'+                                                    , mutantS j j'+                                                    , mutantS k k' ]++mutantSTuple :: [MutantS] -> MutantS+mutantSTuple = Tuple

@@ -0,0 +1,98 @@+-- | ShowMutable instances: septuples up to 12-tuples+--+-- This is part of a Hack that allows those instances to be hidden from Haddock.+-- Otherwise Haddock documentation will look very ugly.+module Test.FitSpec.ShowMutable.Tuples () where++import Test.FitSpec.ShowMutable++instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,+          ShowMutable e, ShowMutable f, ShowMutable g)+      => ShowMutable (a,b,c,d,e,f,g) where+  mutantS (f,g,h,i,j,k,l) (f',g',h',i',j',k',l') = mutantSTuple+                                                    [ mutantS f f'+                                                    , mutantS g g'+                                                    , mutantS h h'+                                                    , mutantS i i'+                                                    , mutantS j j'+                                                    , mutantS k k'+                                                    , mutantS l l' ]++instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,+          ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h)+      => ShowMutable (a,b,c,d,e,f,g,h) where+  mutantS (f,g,h,i,j,k,l,m) (f',g',h',i',j',k',l',m') = mutantSTuple+                                                      [ mutantS f f'+                                                      , mutantS g g'+                                                      , mutantS h h'+                                                      , mutantS i i'+                                                      , mutantS j j'+                                                      , mutantS k k'+                                                      , mutantS l l'+                                                      , mutantS m m' ]++instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,+          ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h,+          ShowMutable i)+      => ShowMutable (a,b,c,d,e,f,g,h,i) where+  mutantS (f,g,h,i,j,k,l,m,n) (f',g',h',i',j',k',l',m',n') = mutantSTuple+    [ mutantS f f'+    , mutantS g g'+    , mutantS h h'+    , mutantS i i'+    , mutantS j j'+    , mutantS k k'+    , mutantS l l'+    , mutantS m m'+    , mutantS n n' ]++instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,+          ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h,+          ShowMutable i, ShowMutable j)+      => ShowMutable (a,b,c,d,e,f,h,g,i,j) where+  mutantS (f,g,h,i,j,k,l,m,n,o) (f',g',h',i',j',k',l',m',n',o') = mutantSTuple+    [ mutantS f f'+    , mutantS g g'+    , mutantS h h'+    , mutantS i i'+    , mutantS j j'+    , mutantS k k'+    , mutantS l l'+    , mutantS m m'+    , mutantS n n'+    , mutantS o o' ]++instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,+          ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h,+          ShowMutable i, ShowMutable j, ShowMutable k)+      => ShowMutable (a,b,c,d,e,f,g,h,i,j,k) where+  mutantS (f,g,h,i,j,k,l,m,n,o,p) (f',g',h',i',j',k',l',m',n',o',p') = mutantSTuple+    [ mutantS f f'+    , mutantS g g'+    , mutantS h h'+    , mutantS i i'+    , mutantS j j'+    , mutantS k k'+    , mutantS l l'+    , mutantS m m'+    , mutantS n n'+    , mutantS o o'+    , mutantS p p' ]++instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d,+          ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h,+          ShowMutable i, ShowMutable j, ShowMutable k, ShowMutable l)+      => ShowMutable (a,b,c,d,e,f,g,h,i,j,k,l) where+  mutantS (f,g,h,i,j,k,l,m,n,o,p,q) (f',g',h',i',j',k',l',m',n',o',p',q') = mutantSTuple+    [ mutantS f f'+    , mutantS g g'+    , mutantS h h'+    , mutantS i i'+    , mutantS j j'+    , mutantS k k'+    , mutantS l l'+    , mutantS m m'+    , mutantS n n'+    , mutantS o o'+    , mutantS p p'+    , mutantS q q' ]

@@ -0,0 +1,43 @@+-- | FitSpec's Test Types:+-- 'Nat',+-- 'Int2', 'Int3', 'Int4',+-- 'UInt2', 'UInt3', 'UInt4'.+--+-- This module basically re-exports LeanCheck's Test.Types module+-- and defines 'Mutable' and 'ShowMutable' instances for the types+-- defined there.+module Test.FitSpec.TestTypes (module Test.LeanCheck.Utils.Types) where++import Test.FitSpec.Mutable+import Test.FitSpec.ShowMutable+import Test.LeanCheck.Utils.Types++-- {- Standard implementation:+instance Mutable Nat   where mutiers = mutiersEq+instance Mutable Int1  where mutiers = mutiersEq+instance Mutable Int2  where mutiers = mutiersEq+instance Mutable Int3  where mutiers = mutiersEq+instance Mutable Int4  where mutiers = mutiersEq+instance Mutable Word1 where mutiers = mutiersEq+instance Mutable Word2 where mutiers = mutiersEq+instance Mutable Word3 where mutiers = mutiersEq+instance Mutable Word4 where mutiers = mutiersEq+-- -}+{- Alternative implementation:+instance Mutable Nat   where mutants = mutantsIntegral+instance Mutable Int2  where mutants = mutantsIntegral+instance Mutable Int3  where mutants = mutantsIntegral+instance Mutable Int4  where mutants = mutantsIntegral+instance Mutable Word2 where mutants = mutantsIntegral+instance Mutable Word3 where mutants = mutantsIntegral+instance Mutable Word4 where mutants = mutantsIntegral+-- -}+instance ShowMutable Nat   where mutantS = mutantSEq+instance ShowMutable Int1  where mutantS = mutantSEq+instance ShowMutable Int2  where mutantS = mutantSEq+instance ShowMutable Int3  where mutantS = mutantSEq+instance ShowMutable Int4  where mutantS = mutantSEq+instance ShowMutable Word1 where mutantS = mutantSEq+instance ShowMutable Word2 where mutantS = mutantSEq+instance ShowMutable Word3 where mutantS = mutantSEq+instance ShowMutable Word4 where mutantS = mutantSEq

@@ -0,0 +1,133 @@+-- | General purpose utility functions for FitSpec+{-# LANGUAGE CPP #-}+module Test.FitSpec.Utils+  ( (...)+  , uncurry3+  , count+  , compositions+  , subsets+  , contained+  , contains+  , filterU+  , sortAndGroupOn+  , sortAndGroupFstBySnd+  , sortGroupAndCollapse+  , takeWhileIncreasing+  , takeWhileIncreasingOn+  , lastTimeout+  , sortOn+  , (***)+  )+where++#if __GLASGOW_HASKELL__ <= 704+import Prelude hiding (catch)+#endif+import System.IO.Unsafe (unsafePerformIO)+import Control.Exception ( Exception+                         , SomeException+                         , ArithException+                         , ArrayException+                         , ErrorCall+                         , PatternMatchFail+                         , catch+                         , catches+                         , Handler (Handler)+                         , evaluate+                         )+import Data.Function (on)+import Data.Ord (comparing)+import Data.List (groupBy,sortBy)+import Data.IORef (newIORef, readIORef, writeIORef)+import Control.Concurrent (forkIO, threadDelay, killThread)+import Control.Monad (liftM)++-- | Compose composed with compose operator.+--+-- > (f ... g) x y === f (g x y)+(...) :: (c->d) -> (a->b->c) -> a -> b -> d+(...) = (.) . (.)+-- f ... g = \x y -> f (g x y)++uncurry3 :: (a->b->c->d) -> (a,b,c) -> d+uncurry3 f (x,y,z) = f x y z++count :: (a -> Bool) -> [a] -> Int+count p = length . filter p++-- | 'compositions' @bs@ returns all compositions formed by taking values of @bs@+compositions :: [Bool] -> [Bool]+compositions = map and . subsets++-- | 'subsets' @xs@ returns the list of sublists formed by taking values of @xs@+subsets :: [a] -> [[a]]+subsets []     = [[]]+subsets (x:xs) = map (x:) (subsets xs) ++ subsets xs++-- TODO: rename contained and contains to subset and superset?++-- | Check if all elements of a list is contained in another list+contained :: Eq a => [a] -> [a] -> Bool+xs `contained` ys = all (`elem` ys) xs++contains :: Eq a => [a] -> [a] -> Bool+contains = flip contained++-- | 'filterU' filter greater-later elements in a list according to a partial+--   ordering relation.+--+-- > filterU (notContained) [[1],[2],[1,2,3],[3,4,5]] == [[1],[2],[3,4,5]]+filterU :: (a -> a -> Bool) -> [a] -> [a]+filterU f []     = []+filterU f (x:xs) = x : filter (f x) (filterU f xs)++sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn f = sortBy (compare `on` f)++sortAndGroupOn :: Ord b => (a -> b) -> [a] -> [[a]]+sortAndGroupOn f = groupBy ((==) `on` f)+                 . sortOn f++sortGroupAndCollapse :: Ord b+                     => (a -> b) -> (a -> c) -> (b -> [c] -> d)+                     -> [a] -> [d]+sortGroupAndCollapse f g h = map collapse+                           . sortAndGroupOn f+  where collapse (x:xs) = f x `h` map g (x:xs)++sortAndGroupFstBySnd :: Ord b => [(a,b)] -> [([a],b)]+sortAndGroupFstBySnd = sortGroupAndCollapse snd fst (flip (,))++-- | Takes values from a list while the values increase.  If the original list+--   is non-empty, the returning list will also be non-empty+takeWhileIncreasing :: (a -> a -> Ordering) -> [a] -> [a]+takeWhileIncreasing _ [] = []+takeWhileIncreasing _ [x] = [x]+takeWhileIncreasing cmp (x:y:xs) = x : case x `cmp` y of+                                         LT -> takeWhileIncreasing cmp (y:xs)+                                         _  -> []+++takeWhileIncreasingOn :: Ord b => (a -> b) -> [a] -> [a]+takeWhileIncreasingOn f = takeWhileIncreasing (compare `on` f)+++-- | @lastTimeout s xs@ will take the last value of @xs@ it is able evaluate+--   before @s@ seconds elapse.+lastTimeout :: Int -> [a] -> IO a+lastTimeout _ []     = error "lastTimeout: empty list"+lastTimeout 0 (x:_)  = return x  -- no time to lose+lastTimeout s (x:xs) = do+  r <- newIORef x+  tid <- forkIO $ keepImproving r xs+  threadDelay (s*1000000) -- TODO: change to waitForThread!!!+  killThread tid+  readIORef r+  where keepImproving _ []     = return ()+        keepImproving r (x:xs) = do+          evaluate x+          writeIORef r x+          keepImproving r xs++(***) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)+f *** g = \(x,y) -> (f x, g y)

@@ -2,7 +2,7 @@ import System.Exit (exitFailure) import Data.List (elemIndices,sort) -import FitSpec+import Test.FitSpec  data D0       = D0                    deriving (Show,Eq,Ord) data D1 a     = D1 a                  deriving (Show,Eq,Ord)@@ -29,7 +29,7 @@ data Set a = Set [a] deriving (Show,Eq,Ord)  instance (Ord a, Listable a) => Listable (Set a) where-  tiers = consFromSet Set+  tiers = setCons Set  deriveMutableE [''Ord] ''Set 

@@ -2,8 +2,8 @@ import Data.List (elemIndices, sort) import Data.Tuple (swap) -import FitSpec-import FitSpec.Utils (contained)+import Test.FitSpec+import Test.FitSpec.Utils (contained) import Test.LeanCheck.Error (errorToNothing, errorToFalse) import Test.LeanCheck.Function.ListsOfPairs (functionPairs, defaultFunPairsToFunction) 

@@ -4,9 +4,9 @@ import Data.List (elemIndices, sort) import Data.Tuple (swap) -import FitSpec-import FitSpec.ShowMutable-import FitSpec.PrettyPrint+import Test.FitSpec+import Test.FitSpec.ShowMutable+import Test.FitSpec.PrettyPrint import Test.LeanCheck.Error (errorToNothing) import Test.LeanCheck.Utils.TypeBinding 

@@ -0,0 +1,27 @@+import System.Exit (exitFailure)+import Data.List (elemIndices,sortBy)++import Data.Function++import Test.LeanCheck+import Test.FitSpec.Utils++main :: IO ()+main =+  case elemIndices False (tests 500) of+    [] -> putStrLn "Tests passed!"+    is -> do putStrLn ("Failed tests:" ++ show is)+             exitFailure++tests :: Int -> [Bool]+tests n =+  [ True++  , sortOn snd [(1,3),(2,2),(3,1)] == [(3,1),(2,2),(1,3)]+  , holds n $ (propSortOn fst :: [(Int,Int)] -> Bool)+  , holds n $ (propSortOn snd :: [(Int,Int)] -> Bool)+  , holds n $ (propSortOn abs :: [Int] -> Bool)+  ]++propSortOn :: (Eq a, Ord b) => (a -> b) -> [a] -> Bool+propSortOn f xs = sortOn f xs == sortBy (compare `on` f) xs