diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -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; diff --git a/leancheck.cabal b/leancheck.cabal --- a/leancheck.cabal +++ b/leancheck.cabal @@ -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 diff --git a/src/Test/LeanCheck.hs b/src/Test/LeanCheck.hs --- a/src/Test/LeanCheck.hs +++ b/src/Test/LeanCheck.hs @@ -89,6 +89,7 @@ -- ** Automatically deriving Listable instances , deriveListable + , deriveListableCascading -- ** Specialized constructors of tiers , setCons diff --git a/src/Test/LeanCheck/Basic.hs b/src/Test/LeanCheck/Basic.hs --- a/src/Test/LeanCheck/Basic.hs +++ b/src/Test/LeanCheck/Basic.hs @@ -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..] diff --git a/src/Test/LeanCheck/Core.hs b/src/Test/LeanCheck/Core.hs --- a/src/Test/LeanCheck/Core.hs +++ b/src/Test/LeanCheck/Core.hs @@ -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]] diff --git a/src/Test/LeanCheck/Derive.hs b/src/Test/LeanCheck/Derive.hs --- a/src/Test/LeanCheck/Derive.hs +++ b/src/Test/LeanCheck/Derive.hs @@ -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 [] diff --git a/src/Test/LeanCheck/Invariants.hs b/src/Test/LeanCheck/Invariants.hs --- a/src/Test/LeanCheck/Invariants.hs +++ b/src/Test/LeanCheck/Invariants.hs @@ -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 diff --git a/tests/test-derive.hs b/tests/test-derive.hs --- a/tests/test-derive.hs +++ b/tests/test-derive.hs @@ -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 = diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -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