fitspec 0.3.1 → 0.4.0

raw patch · 11 files changed

+311/−33 lines, 11 filesdep +haskell-srcdep +haskell-src-extsdep ~leancheck

Dependencies added: haskell-src, haskell-src-exts

Dependency ranges changed: leancheck

Files

• README.md +2/−2
• TODO.md +23/−0
• bench/haskell-src-exts.hs +38/−0
• bench/haskell-src.hs +58/−0
• fitspec.cabal +17/−3
• src/Test/FitSpec.hs +2/−0
• src/Test/FitSpec/Derive.hs +131/−21
• src/Test/FitSpec/Engine.hs +1/−1
• src/Test/FitSpec/Mutable.hs +17/−2
• src/Test/FitSpec/ShowMutable.hs +10/−0
• tests/test-mutate.hs +12/−4

@@ -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

@@ -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.

@@ -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 "<unknown>.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

@@ -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

@@ -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

@@ -86,6 +86,8 @@   -- * Automatic derivation   , deriveMutable   , deriveMutableE+  , deriveMutableCascading+  , deriveMutableCascadingE    -- * Re-export modules   , module Test.FitSpec.TestTypes

@@ -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 []

@@ -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'.

@@ -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.

@@ -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

@@ -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