leancheck 0.5.0 → 0.6.0

raw patch · 9 files changed

+220/−45 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• TODO.md +7/−1
• leancheck.cabal +3/−3
• src/Test/LeanCheck.hs +1/−0
• src/Test/LeanCheck/Basic.hs +23/−7
• src/Test/LeanCheck/Core.hs +4/−0
• src/Test/LeanCheck/Derive.hs +127/−33
• src/Test/LeanCheck/Invariants.hs +8/−0
• tests/test-derive.hs +33/−1
• tests/test.hs +14/−0

@@ -12,7 +12,13 @@   It will also be clearer what each parameter means.   Note that ALLHS and LIBHS are not (but could be) the final names. +* parameterize number of tests in test programs and add slow-test target +* add diff test for IO functions (diff w/ model output and exit status)++* (?) on leancheck.cabal, add upper bound for template-haskell package++ documentation ------------- @@ -23,7 +29,7 @@ * on data-invariant.md, write missing section;  -v0.6.0+v0.6.1 ------  * implement stub `Test.LeanCheck.Function.*` modules;

@@ -11,7 +11,7 @@ -- this cabal file too complicated.  -- Rudy  name:                leancheck-version:             0.5.0+version:             0.6.0 synopsis:            Cholesterol-free property-based testing description:   LeanCheck is a simple enumerative property-based testing library.@@ -50,7 +50,7 @@ source-repository this   type:            git   location:        https://github.com/rudymatela/leancheck-  tag:             v0.5.0+  tag:             v0.6.0  library   exposed-modules: Test.LeanCheck@@ -70,7 +70,7 @@                  , Test.LeanCheck.Function.Periodic                  , Test.LeanCheck.Function.Show                  , Test.LeanCheck.Function.ShowFunction-  other-modules:       Test.LeanCheck.Invariants+  other-modules:   Test.LeanCheck.Invariants   hs-source-dirs:      src   build-depends:       base >= 4 && < 5, template-haskell   default-language:    Haskell2010

@@ -89,6 +89,7 @@    -- ** Automatically deriving Listable instances   , deriveListable+  , deriveListableCascading    -- ** Specialized constructors of tiers   , setCons

@@ -1,14 +1,18 @@--- | LeanCheck is a simple enumerative property-based testing library.+-- | This module is part of LeanCheck,+--   a simple enumerative property-based testing library. ----- This module exports "Test.LeanCheck.Core" along with instances and--- functions for further tuple and constructor arities.+-- This module exports "Test.LeanCheck.Core" along with: ----- For the complete list of functions, see "Test.LeanCheck".+--   * support for 'Listable' 6-tuples up to 12-tuples;+--   * 'tiers' constructors (@consN@) with arities from 6 up to 12;+--   * a 'Listable' 'Ratio' instance (consequently 'Listable' 'Rational');+--   * a 'Listable' 'Word' instance. -- -- "Test.LeanCheck" already exports everything from this module.--- You should only import this if you /only/ want basic functionality from--- "Test.LeanCheck.Core" with support for tuples and constructors with arities--- from 6 up to 12.+-- You are probably better off importing it.+--+-- You should /only/ import "Test.LeanCheck.Basic"+-- if you /only/ want the above basic functionality. module Test.LeanCheck.Basic   ( module Test.LeanCheck.Core @@ -22,7 +26,11 @@   ) where +-- TODO: Listable Int8/16/32/64, Word8/16/32/64, Natural+ import Test.LeanCheck.Core+import Data.Word (Word)+import Data.Ratio  instance (Listable a, Listable b, Listable c,           Listable d, Listable e, Listable f) =>@@ -125,3 +133,11 @@ uncurry12 :: (a->b->c->d->e->f->g->h->i->j->k->l->m)           -> (a,b,c,d,e,f,g,h,i,j,k,l) -> m uncurry12 f (x,y,z,w,v,u,r,s,t,o,p,q) = f x y z w v u r s t o p q++instance (Integral a, Listable a) => Listable (Ratio a) where+  tiers = mapT (uncurry (%))+        $ tiers `suchThat` (\(n,d) -> d > 0 && n `gcd` d == 1)+                `ofWeight` 0 -- make size 0 not be "usually" empty++instance Listable Word where+  list = [0..]

@@ -196,6 +196,10 @@ instance Listable Double where   tiers = tiersFractional +instance Listable Ordering where+  tiers = cons0 LT+       \/ cons0 EQ+       \/ cons0 GT  -- | 'map' over tiers mapT :: (a -> b) -> [[a]] -> [[b]]

@@ -10,12 +10,15 @@ -- culprit. module Test.LeanCheck.Derive   ( deriveListable+  , deriveListableIfNeeded+  , deriveListableCascading   ) where  import Language.Haskell.TH import Test.LeanCheck.Basic-import Control.Monad (unless, liftM, liftM2)+import Control.Monad (unless, liftM, liftM2, filterM)+import Data.List (delete)  #if __GLASGOW_HASKELL__ < 706 -- reportWarning was only introduced in GHC 7.6 / TH 2.8@@ -40,24 +43,30 @@ -- -- Needs the @TemplateHaskell@ extension. deriveListable :: Name -> DecsQ-deriveListable t = do+deriveListable = deriveListableX True False++-- | Same as 'deriveListable' but does not warn when instance already exists+--   ('deriveListable' is preferable).+deriveListableIfNeeded :: Name -> DecsQ+deriveListableIfNeeded = deriveListableX False False++-- | Derives a 'Listable' instance for a given type 'Name'+--   cascading derivation of type arguments as well.+deriveListableCascading :: Name -> DecsQ+deriveListableCascading = deriveListableX True True++deriveListableX :: Bool -> Bool -> Name -> DecsQ+deriveListableX warnExisting cascade t = do   is <- t `isInstanceOf` ''Listable   if is-    then do reportWarning $ "Instance Listable "-                         ++ show t-                         ++ " already exists, skipping derivation"-            return []-    else do cd <- canDeriveListable t-            unless cd (fail $ "Unable to derive Listable "-                           ++ show t)-            reallyDeriveListable t---- | Checks whether it is possible to derive a Listable instance.------ For example, it is not possible if there is no Listable instance for a--- type in one of the constructors.-canDeriveListable :: Name -> Q Bool-canDeriveListable t = return True -- TODO: Check instances for type-cons args+    then do+      unless (not warnExisting)+        (reportWarning $ "Instance Listable " ++ show t+                      ++ " already exists, skipping derivation")+      return []+    else if cascade+           then reallyDeriveListableCascading t+           else reallyDeriveListable t  -- TODO: Somehow check if the enumeration has repetitions, then warn the user. reallyDeriveListable :: Name -> DecsQ@@ -70,23 +79,65 @@ #endif #if __GLASGOW_HASKELL__ >= 708   cxt |=>| [d| instance Listable $(return nt)-                 where tiers = $(conse =<< typeCons t) |]+                 where tiers = $(conse =<< typeConstructors t) |] #else-  tiersE <- conse =<< typeCons t+  tiersE <- conse =<< typeConstructors t   return [ InstanceD              cxt              (AppT (ConT ''Listable) nt)              [ValD (VarP 'tiers) (NormalB tiersE) []]          ] #endif-  where cone n arity = do-          (Just consN) <- lookupValueName $ "cons" ++ show arity+  where cone n as = do+          (Just consN) <- lookupValueName $ "cons" ++ show (length as)           [| $(varE consN) $(conE n) |]         conse = foldr1 (\e1 e2 -> [| $e1 \/ $e2 |]) . map (uncurry cone) +-- Not only really derive Listable instances,+-- but cascade through argument types.+reallyDeriveListableCascading :: Name -> DecsQ+reallyDeriveListableCascading t =+      return . concat+  =<< mapM reallyDeriveListable+  =<< filterM (liftM not . isTypeSynonym)+  =<< return . (t:) . delete t+  =<< t `typeConCascadingArgsThat` (`isntInstanceOf` ''Listable)  -- * 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.@@ -127,6 +178,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: --@@ -149,14 +203,26 @@     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 tupled with--- the number of arguments they take.-typeCons :: Name -> Q [(Name,Int)]-typeCons t = do+-- 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@@ -166,13 +232,29 @@     TyConI (DataD    _ _ _ _ cs _) -> cs     TyConI (NewtypeD _ _ _ _ c  _) -> [c] #endif-    _ -> error $ "error (typeConstructors): symbol "-              ++ show t+    _ -> error $ "error (typeConstructors): symbol " ++ show t               ++ " is neither newtype nor data"-  where simplify (NormalC n ts)  = (n,length ts)-        simplify (RecC    n ts)  = (n,length ts)-        simplify (InfixC  _ n _) = (n,2)+  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|]@@ -187,3 +269,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 []

@@ -15,8 +15,10 @@    , ordered   , orderedBy+  , orderedOn   , strictlyOrdered   , strictlyOrderedBy+  , strictlyOrderedOn   ) where @@ -43,6 +45,9 @@                            GT -> False                            _  -> orderedBy cmp (y:xs) +orderedOn :: Ord b => (a -> b) -> [a] -> Bool+orderedOn f = orderedBy (comparing f)+ -- | check if a list is strictly ordered by a given ordering function strictlyOrderedBy :: (a -> a -> Ordering) -> [a] -> Bool strictlyOrderedBy _ [] = True@@ -50,6 +55,9 @@ strictlyOrderedBy cmp (x:y:xs) = case x `cmp` y of                                    LT -> strictlyOrderedBy cmp (y:xs)                                    _  -> False++strictlyOrderedOn :: Ord b => (a -> b) -> [a] -> Bool+strictlyOrderedOn f = strictlyOrderedBy (comparing f)  ifNotEq :: Ordering -> Ordering -> Ordering -- Could be implemented as:  ifNotEq = mappend

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, CPP #-} import Test.LeanCheck.Derive import Test.LeanCheck import System.Exit (exitFailure)@@ -21,12 +21,44 @@ deriveListable ''C2 deriveListable ''I +-- Nested datatype cascade+data Nested = Nested N0 (N1 Int) (N2 Int Int)+data N0     = R0 Int+data N1 a   = R1 a+data N2 a b = R2 a b+deriveListableCascading ''Nested++-- Recursive nested datatype cascade+data RN      = RN RN0 (RN1 Int) (RN2 Int RN)+data RN0     = Nest0 Int | Recurse0 RN+data RN1 a   = Nest1 a   | Recurse1 RN+data RN2 a b = Nest2 a b | Recurse2 RN+deriveListableCascading ''RN++-- Type synonyms+data Pair a = Pair a a+type Alias a = Pair a+-- deriveListable ''Alias -- this will fail+deriveListableCascading ''Alias+deriveListableIfNeeded ''Alias -- only works because instance already exists++-- Nested type synonyms+data Triple a = Triple a a a+type Tralias a = Triple a+data Pairiple a = Pairriple (Tralias a) (Tralias a)+deriveListableCascading ''Pairiple+ -- Those should have no effect (instance already exists): {- uncommenting those should generate warnings deriveListable ''Bool deriveListable ''Maybe deriveListable ''Either -}++-- Those should not generate warnings+deriveListableIfNeeded ''Bool+deriveListableIfNeeded ''Maybe+deriveListableIfNeeded ''Either  main :: IO () main =

@@ -5,6 +5,9 @@ import Test.LeanCheck.Invariants import Test.LeanCheck.Utils +import Data.Ratio+import Data.Word (Word)+ main :: IO () main =   case elemIndices False tests of@@ -46,6 +49,17 @@   , counterExample 50 (\x -> x + 1 /= (x::Double)) == Just ["Infinity"]   , allUnique (take 100 list :: [Float])   , allUnique (take 500 list :: [Double])++  , allUnique (take 500 list :: [Rational])+  , allUnique (take 100 list :: [Ratio Nat])+  , orderedOn (\r -> numerator r + denominator r) (take 500 (list :: [Ratio Nat]))+  , orderedOn (\r -> abs (numerator r) + abs(denominator r)) (take 500 (list :: [Rational]))++  , list == [LT, EQ, GT]+  , orderedOn length (take 500 (list :: [[Ordering]]))+  , orderedOn length (take 500 (list :: [[Bool]]))++  , strictlyOrderedOn (\xs -> (sum $ map (+1) xs, xs)) (take 500 (list :: [[Word]]))    , tPairEqParams 100   , tTripleEqParams 100