diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -135,8 +135,8 @@ For further documentation, consult the [doc](doc) folder and [FitSpec API] documentation on Hackage. -(TODO: link to a possible future FitSpec paper goes here) - +FitSpec has been subject to a paper, see the +[FitSpec paper on Haskell Symposium 2016](https://matela.com.br/paper/fitspec.pdf) [Listable]: https://hackage.haskell.org/package/leancheck/docs/Test-LeanCheck.html#t:Listable [Mutable]: https://hackage.haskell.org/package/fitspec/docs/Test-FitSpec.html#t:Mutable diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -10,6 +10,7 @@ * add diff test for IO functions (diff w/ model output and exit status) + documentation ------------- @@ -18,3 +19,25 @@ * write detailed install instructions on INSTALL.md (cabal install, cabal from sandbox, source include) + + +v0.4.1 +------ + +* Fix `thread killed` when first run takes longer than timeout: + + $ ./bench/haskell-src -t5 -m500 -n1000 + haskell-src: thread killed + + As it takes more than 5 seconds to run this example (at least on my machine), + the thread will be killed before concluding. I *think* this is the source of + the bug, but could be something else. + + EDIT (after re-reading the code and doing some tests): maybe the Thread + Killed exception somehow "infects" `x` as it may share some structure with + elements of `xs`. + + To solve this, maybe re-implement by probing (every 100ms) whether the IORef + was ever written to --- for that I will need a second boolean IORef. This has + the advantage of, by adding a *third* boolean IORef we can also exit earlier + when test cases and mutants are exhausted. diff --git a/bench/haskell-src-exts.hs b/bench/haskell-src-exts.hs new file mode 100644 --- /dev/null +++ b/bench/haskell-src-exts.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} +import Test.FitSpec +import Language.Haskell.Exts +import Language.Haskell.Exts.Pretty + +instance Eq a => Eq (ParseResult a) where + ParseOk x == ParseOk y = x == y + ParseFailed l1 s1 == ParseFailed l2 s2 = l1 == l2 && s1 == s2 + _ == _ = False + +deriveMutableCascading ''ParseResult +deriveMutableCascading ''Module +deriveMutableCascading ''SrcSpanInfo + +properties :: (String -> ParseResult (Module SrcSpanInfo) + ,Module SrcSpanInfo -> String) + -> [Property] +properties (parseFileContents,prettyPrint) = + [ property $ case parseFileContents "" of + ParseOk (Module _ _ _ _ _) -> True + _ -> False + , property $ case parseFileContents "a" of + ParseFailed (SrcLoc ".hs" 2 1) _ -> True + _ -> False + , property $ \m -> case parseFileContents (prettyPrint m) of + ParseOk m' -> case parseFileContents (prettyPrint m') of + ParseOk m'' -> m' == m'' + _ -> False + _ -> True +-- Not true: +--, property $ \s -> case parseFileContents s of +-- ParseOk m' -> prettyPrint m' == s +-- _ -> True + ] + +main = mainWith args { names = ["parseFileContents f", "prettyPrint m"] } + (parseFileContents,prettyPrint) + properties diff --git a/bench/haskell-src.hs b/bench/haskell-src.hs new file mode 100644 --- /dev/null +++ b/bench/haskell-src.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TemplateHaskell, StandaloneDeriving #-} +import Test.FitSpec +import Language.Haskell.Parser +import Language.Haskell.Pretty as P +import Language.Haskell.Syntax +import Data.Ratio +import Data.List (intercalate) +import Data.Function (on) +import Data.Char + +deriving instance Eq HsModule -- needed for Mutable + +deriveMutableCascading ''HsModule + +-- change ``take 5'' below to ``take n'' where n `elem` [1,2,3,4] +-- to see surviving mutants for different refinements +-- +-- All 5 properties should be reported as ``apparently complete'' +-- so no surviving mutants. +properties :: (HsModule -> String) -> [Property] +properties prettyPrint = take 5 + [ property $ + \nm loc -> (prettyPrint $ HsModule loc (Module nm) Nothing [] []) + == "module " ++ nm ++ " where" + + , property $ + \nm loc -> (prettyPrint $ HsModule loc (Module nm) (Just []) [] []) + == "module " ++ nm ++ " () where" + + , property $ + \nm loc -> (prettyPrint $ HsModule loc (Module nm) Nothing [] [HsFunBind []]) + == "module " ++ nm ++ " where" + + , property $ + \nm loc imports decls -> + (prettyPrint $ HsModule loc (Module nm) Nothing imports decls) + === unlines (("module " ++ nm ++ " where") + :(map P.prettyPrint imports + ++ map P.prettyPrint decls)) + + , property $ + \nm loc imports exports decls -> + (prettyPrint $ HsModule loc (Module nm) (Just exports) imports decls) + === unlines (["module " ++ nm ++ " (" + ++ intercalate ", " (map P.prettyPrint exports) + ++ ") where"] + ++ map P.prettyPrint imports + ++ map P.prettyPrint decls) + ] + where + (===) :: String -> String -> Bool + (===) = (==) `on` (filter (not . null) . lines) + +main = mainWith args { names = ["prettyPrint"] + , timeout = 0 + } + prettyPrint + properties diff --git a/fitspec.cabal b/fitspec.cabal --- a/fitspec.cabal +++ b/fitspec.cabal @@ -1,5 +1,5 @@ name: fitspec -version: 0.3.1 +version: 0.4.0 synopsis: refining property sets for testing Haskell programs description: FitSpec provides automated assistance in the task of refining test properties @@ -38,7 +38,7 @@ source-repository this type: git location: https://github.com/rudymatela/fitspec - tag: v0.3.1 + tag: v0.4.0 library @@ -55,7 +55,7 @@ other-modules: Test.FitSpec.Utils , Test.FitSpec.PrettyPrint , Test.FitSpec.Dot - build-depends: base >= 4 && < 5, leancheck >= 0.4, cmdargs, template-haskell + build-depends: base >= 4 && < 5, leancheck >= 0.6, cmdargs, template-haskell hs-source-dirs: src default-language: Haskell2010 @@ -106,6 +106,20 @@ benchmark digraphs main-is: digraphs.hs build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell + hs-source-dirs: src, bench + default-language: Haskell2010 + type: exitcode-stdio-1.0 + +benchmark haskell-src + main-is: haskell-src.hs + build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell, haskell-src + hs-source-dirs: src, bench + default-language: Haskell2010 + type: exitcode-stdio-1.0 + +benchmark haskell-src-exts + main-is: haskell-src-exts.hs + build-depends: base >= 4 && < 5, leancheck, cmdargs, template-haskell, haskell-src-exts hs-source-dirs: src, bench default-language: Haskell2010 type: exitcode-stdio-1.0 diff --git a/src/Test/FitSpec.hs b/src/Test/FitSpec.hs --- a/src/Test/FitSpec.hs +++ b/src/Test/FitSpec.hs @@ -86,6 +86,8 @@ -- * Automatic derivation , deriveMutable , deriveMutableE + , deriveMutableCascading + , deriveMutableCascadingE -- * Re-export modules , module Test.FitSpec.TestTypes diff --git a/src/Test/FitSpec/Derive.hs b/src/Test/FitSpec/Derive.hs --- a/src/Test/FitSpec/Derive.hs +++ b/src/Test/FitSpec/Derive.hs @@ -13,6 +13,8 @@ module Test.FitSpec.Derive ( deriveMutable , deriveMutableE + , deriveMutableCascading + , deriveMutableCascadingE , module Test.FitSpec.Mutable , module Test.FitSpec.ShowMutable , module Test.LeanCheck @@ -23,8 +25,10 @@ import Test.FitSpec.ShowMutable import Test.LeanCheck +import Test.LeanCheck.Derive (deriveListableIfNeeded) import Language.Haskell.TH -import Control.Monad (when, unless, liftM, liftM2) +import Control.Monad (when, unless, liftM, liftM2, filterM) +import Data.List (delete) #if __GLASGOW_HASKELL__ < 706 -- reportWarning was only introduced in GHC 7.6 / TH 2.8 @@ -32,13 +36,6 @@ reportWarning = report False #endif -deriveListableIfNeeded :: Name -> DecsQ -deriveListableIfNeeded t = do - is <- t `isInstanceOf` ''Listable - if is - then return [] - else deriveListable t - -- | Derives 'Mutable', 'ShowMutable' and (optionally) 'Listable' instances -- for a given type 'Name'. -- @@ -69,10 +66,19 @@ deriveMutable :: Name -> DecsQ deriveMutable = deriveMutableE [] +deriveMutableCascading :: Name -> DecsQ +deriveMutableCascading = deriveMutableCascadingE [] + -- | 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 +deriveMutableE = deriveMutableEX False + +deriveMutableCascadingE :: [Name] -> Name -> DecsQ +deriveMutableCascadingE = deriveMutableEX True + +deriveMutableEX :: Bool -> [Name] -> Name -> DecsQ +deriveMutableEX cascade cs t = do is <- t `isInstanceOf` ''Mutable if is then do @@ -80,18 +86,18 @@ ++ " 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) + isEq <- t `isInstanceOf` ''Eq + isShow <- t `isInstanceOf` ''Show + unless isEq (fail $ "Unable to derive Mutable " ++ show t + ++ " (missing Eq instance)") + unless isShow (fail $ "Unable to derive Mutable " ++ show t + ++ " (missing Show instance)") + if cascade + then liftM2 (++) (deriveListableCascading t) (reallyDeriveMutableCascading cs t) + else liftM2 (++) (deriveListableIfNeeded t) (reallyDeriveMutable cs t) -- TODO: document deriveMutableE with an example -- TODO: create deriveListableE on LeanCheck? --- | 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 @@ -118,9 +124,50 @@ ] #endif +reallyDeriveMutableCascading :: [Name] -> Name -> DecsQ +reallyDeriveMutableCascading cs t = do + return . concat + =<< mapM (reallyDeriveMutable cs) + =<< filterM (liftM not . isTypeSynonym) + =<< return . (t:) . delete t + =<< t `typeConCascadingArgsThat` (`isntInstanceOf` ''Mutable) + -- * Template haskell utilities +typeConArgs :: Name -> Q [Name] +typeConArgs t = do + is <- isTypeSynonym t + if is + then liftM typeConTs $ typeSynonymType t + else liftM (nubMerges . map typeConTs . concat . map snd) $ typeConstructors t + where + typeConTs :: Type -> [Name] + typeConTs (AppT t1 t2) = typeConTs t1 `nubMerge` typeConTs t2 + typeConTs (SigT t _) = typeConTs t + typeConTs (VarT _) = [] + typeConTs (ConT n) = [n] +#if __GLASGOW_HASKELL__ >= 800 + -- typeConTs (PromotedT n) = [n] ? + typeConTs (InfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2 + typeConTs (UInfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2 + typeConTs (ParensT t) = typeConTs t +#endif + typeConTs _ = [] + +typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name] +typeConArgsThat t p = do + targs <- typeConArgs t + tbs <- mapM (\t' -> do is <- p t'; return (t',is)) targs + return [t' | (t',p) <- tbs, p] + +typeConCascadingArgsThat :: Name -> (Name -> Q Bool) -> Q [Name] +t `typeConCascadingArgsThat` p = do + ts <- t `typeConArgsThat` p + let p' t' = do is <- p t'; return $ t' `notElem` (t:ts) && is + tss <- mapM (`typeConCascadingArgsThat` p') ts + return $ nubMerges (ts:tss) + -- 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. @@ -161,6 +208,9 @@ ty <- normalizeTypeUnits tn isInstance cl [ty] +isntInstanceOf :: Name -> Name -> Q Bool +isntInstanceOf tn cl = liftM not (isInstanceOf tn cl) + -- | Given a type name, return the number of arguments taken by that type. -- Examples in partially broken TH: -- @@ -183,10 +233,58 @@ TyConI (DataD _ _ ks _ _ _) -> ks TyConI (NewtypeD _ _ ks _ _ _) -> ks #endif - _ -> error $ "error (arity): symbol " - ++ show t - ++ " is not a newtype or data" + TyConI (TySynD _ ks _) -> ks + _ -> error $ "error (typeArity): symbol " ++ show t + ++ " is not a newtype, data or type synonym" +-- Given a type name, returns a list of its type constructor names paired with +-- the type arguments they take. +-- +-- > typeConstructors ''() === Q [('(),[])] +-- +-- > typeConstructors ''(,) === Q [('(,),[VarT a, VarT b])] +-- +-- > typeConstructors ''[] === Q [('[],[]),('(:),[VarT a,AppT ListT (VarT a)])] +-- +-- > data Pair a = P a a +-- > typeConstructors ''Pair === Q [('P,[VarT a, VarT a])] +-- +-- > data Point = Pt Int Int +-- > typeConstructors ''Point === Q [('Pt,[ConT Int, ConT Int])] +typeConstructors :: Name -> Q [(Name,[Type])] +typeConstructors t = do + ti <- reify t + return . map simplify $ case ti of +#if __GLASGOW_HASKELL__ < 800 + TyConI (DataD _ _ _ cs _) -> cs + TyConI (NewtypeD _ _ _ c _) -> [c] +#else + TyConI (DataD _ _ _ _ cs _) -> cs + TyConI (NewtypeD _ _ _ _ c _) -> [c] +#endif + _ -> error $ "error (typeConstructors): symbol " ++ show t + ++ " is neither newtype nor data" + where + simplify (NormalC n ts) = (n,map snd ts) + simplify (RecC n ts) = (n,map trd ts) + simplify (InfixC t1 n t2) = (n,[snd t1,snd t2]) + trd (x,y,z) = z + +isTypeSynonym :: Name -> Q Bool +isTypeSynonym t = do + ti <- reify t + return $ case ti of + TyConI (TySynD _ _ _) -> True + _ -> False + +typeSynonymType :: Name -> Q Type +typeSynonymType t = do + ti <- reify t + return $ case ti of + TyConI (TySynD _ _ t') -> t' + _ -> error $ "error (typeSynonymType): symbol " ++ show t + ++ " is not a type synonym" + -- Append to instance contexts in a declaration. -- -- > sequence [[|Eq b|],[|Eq c|]] |=>| [t|instance Eq a => Cl (Ty a) where f=g|] @@ -201,3 +299,15 @@ where ac (InstanceD o c ts ds) c' = InstanceD o (c++c') ts ds ac d _ = d #endif + +-- > nubMerge xs ys == nub (merge xs ys) +-- > nubMerge xs ys == nub (sort (xs ++ ys)) +nubMerge :: Ord a => [a] -> [a] -> [a] +nubMerge [] ys = ys +nubMerge xs [] = xs +nubMerge (x:xs) (y:ys) | x < y = x : xs `nubMerge` (y:ys) + | x > y = y : (x:xs) `nubMerge` ys + | otherwise = x : xs `nubMerge` ys + +nubMerges :: Ord a => [[a]] -> [a] +nubMerges = foldr nubMerge [] diff --git a/src/Test/FitSpec/Engine.hs b/src/Test/FitSpec/Engine.hs --- a/src/Test/FitSpec/Engine.hs +++ b/src/Test/FitSpec/Engine.hs @@ -41,7 +41,7 @@ type Property = [([String],Bool)] type Properties = [Property] --- | Given a 'Testable' type (as defined by 'Test.LeanCheck'), returns a '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'. diff --git a/src/Test/FitSpec/Mutable.hs b/src/Test/FitSpec/Mutable.hs --- a/src/Test/FitSpec/Mutable.hs +++ b/src/Test/FitSpec/Mutable.hs @@ -10,6 +10,8 @@ import Data.List (intercalate, delete) import Data.Maybe import Test.LeanCheck.Error (errorToNothing) +import Data.Ratio (Ratio) +import Data.Word (Word) -- | This typeclass is similar to 'Listable'. -- @@ -71,19 +73,32 @@ -- | > mutants () = [()] instance Mutable () where mutiers = mutiersEq --- | > mutants 3 = [3,0,1,2,4,5,6,7,8,9,... +-- | > mutants 3 = [3,0,1,2,4,5,6,7,8,...] instance Mutable Int where mutiers = mutiersEq +instance Mutable Integer where mutiers = mutiersEq + instance Mutable Char where mutiers = mutiersEq -- | > mutants True = [True,False] -instance Mutable Bool where mutiers = mutiersEq -- > mutants True=[True,False] +instance Mutable Bool where mutiers = mutiersEq -- | > 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 + +instance (Eq a, Listable a, Eq b, Listable b) => Mutable (Either a b) + where mutiers = mutiersEq + +instance (Eq a, Listable a, Integral a) => Mutable (Ratio a) + where mutiers = mutiersEq + +instance Mutable Float where mutiers = mutiersEq +instance Mutable Double where mutiers = mutiersEq +instance Mutable Ordering where mutiers = mutiersEq +instance Mutable Word where mutiers = mutiersEq {- Alternative implementations for Mutable Ints and Lists. -- These do not improve results significantly. diff --git a/src/Test/FitSpec/ShowMutable.hs b/src/Test/FitSpec/ShowMutable.hs --- a/src/Test/FitSpec/ShowMutable.hs +++ b/src/Test/FitSpec/ShowMutable.hs @@ -17,6 +17,7 @@ import Control.Monad (join) import Data.List (intercalate,tails) import Data.Char (isLetter) +import Data.Ratio (Ratio) -- | Show a Mutant as a tuple of lambdas. @@ -114,10 +115,19 @@ instance ShowMutable () where mutantS = mutantSEq instance ShowMutable Int where mutantS = mutantSEq +instance ShowMutable Integer 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 (Eq a, Show a, Eq b, Show b) => ShowMutable (Either a b) + where mutantS = mutantSEq +instance (Eq a, Show a, Integral a) => ShowMutable (Ratio a) + where mutantS = mutantSEq +instance ShowMutable Float where mutantS = mutantSEq +instance ShowMutable Double where mutantS = mutantSEq +instance ShowMutable Ordering where mutantS = mutantSEq +instance ShowMutable Word 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 diff --git a/tests/test-mutate.hs b/tests/test-mutate.hs --- a/tests/test-mutate.hs +++ b/tests/test-mutate.hs @@ -7,7 +7,10 @@ import Test.LeanCheck.Error (errorToNothing, errorToFalse) import Test.LeanCheck.Function.ListsOfPairs (functionPairs, defaultFunPairsToFunction) +import Data.Monoid ((<>)) +polyAppend :: [a] -> [b] -> [Either a b] +polyAppend xs ys = map Left xs ++ map Right ys main :: IO () main = @@ -16,10 +19,6 @@ is -> do putStrLn ("Failed tests:" ++ show is) exitFailure --- NOTE: --- the lsMutantsEqOld property only *actually* hold for functions returning --- lists when using mutiersEq as the implementation of mutiers for [a] - tests = map errorToFalse [ True @@ -67,6 +66,12 @@ , allUnique $ concat $ showNewMutants2 ((,) :: Int -> Bool -> (Int,Bool)) 7 , allUnique $ concat $ showNewMutants2 ((,) :: Bool -> Int -> (Bool,Int)) 7 + , allUnique $ concat $ showNewMutants2 (polyAppend :: [String] -> [Int] -> [Either String Int]) 7 + , allUnique $ concat $ showNewMutants2 ((+) :: Float -> Float -> Float) 7 + , allUnique $ concat $ showNewMutants2 ((+) :: Double -> Double -> Double) 7 + , allUnique $ concat $ showNewMutants2 ((<>) :: Ordering -> Ordering -> Ordering) 7 + , allUnique $ concat $ showNewMutants2 ((+) :: Word -> Word -> Word) 7 + {- , checkBindingsOfLength 7 2 ((,) :: Bool -> Bool -> (Bool,Bool)) , checkBindingsOfLength 7 2 ((,) :: Int -> Int -> (Int,Int)) @@ -119,6 +124,9 @@ bindingsOfLength :: Int -> [([String],String)] -> Bool bindingsOfLength n = all ((== n) . length . fst) +-- NOTE: +-- mutiersEqOld only *actually* hold for functions returning +-- lists when using mutiersEq as the implementation of mutiers for [a] mutiersEqOld :: ( Show a, Show b , Eq a, Eq b , Listable a, Listable b