diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c)2011, Jonas Dureg†rd +Copyright (c)2011, Jonas Duregård All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Jonas Dureg†rd nor the names of other + * Neither the name of Jonas Duregård nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs diff --git a/Test/Feat.hs b/Test/Feat.hs --- a/Test/Feat.hs +++ b/Test/Feat.hs @@ -1,34 +1,39 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + -- | This module contains a (hopefully) manageable subset of the functionality -- of Feat. The rest resides only in the Test.Feat.* modules. module Test.Feat( - Enumerate(), + + -- * Testing driver + test, + testOptions, + Options(..), + defOptions, + + -- * The type class - Enumerable(..), - shared, - nullary, - unary, - FreePair(..), - funcurry, - consts, + Enumerate(), + Enumerable(..), datatype, c0, c1, c2, c3, c4, c5, c6, c7, + -- ** Automatic derivation deriveEnumerable, + + -- * Accessing data optimal, index, select, values, - bounded, uniform, - -- ** Testing drivers - featCheck, - ioFeat, - ioAll, - ioBounded, - Report, - inputRep + + ) where import Test.Feat.Access -import Test.Feat.Class +-- import Test.Feat.Class import Test.Feat.Enumerate +import Test.Feat.Driver +import Control.Enumerable + + -- import Test.Feat.Modifiers diff --git a/Test/Feat/Access.hs b/Test/Feat/Access.hs --- a/Test/Feat/Access.hs +++ b/Test/Feat/Access.hs @@ -1,147 +1,73 @@ --- | Functions for accessing the values of enumerations including --- compatibility with the property based testing frameworks QuickCheck and --- SmallCheck. +-- | Functions for accessing the values of enumerations including +-- compatibility with the property based testing framework QuickCheck module Test.Feat.Access( - -- ** Accessing functions + -- * Accessing functions + optimal, index, select, values, - striped, - bounded, - - -- ** A simple property tester - featCheck, - ioFeat, - ioAll, - ioBounded, - - Report, - inputRep, - prePostRep, - - -- ** Compatibility - -- *** QuickCheck + -- * QuickCheck Compatibility uniform, - -- *** SmallCheck - toSeries, - -- ** Non-class versions of the access functions + -- * Combinators + skipping, + bounded, + sizeRange, + + -- * Non-class versions of the access functions indexWith, selectWith, valuesWith, - stripedWith, - boundedWith, - uniformWith, - toSeriesWith + uniformWith )where --- testing-feat -import Test.Feat.Enumerate -import Test.Feat.Class +import Test.Feat.Enumerate +import Control.Enumerable +--import Data.Modifiers + -- base import Data.List import Data.Ratio((%)) + + -- quickcheck -import Test.QuickCheck --- smallcheck --- import Test.SmallCheck.Series -- Not needed +import Test.QuickCheck(choose,Gen) +-- | Memoised enumeration. Note that all cardinalities are kept in memory until your program terminates. +optimal :: Enumerable a => Enumerate a +optimal = global --- | Mainly as a proof of concept we define a function to index into --- an enumeration. (If this is repeated multiple times it might be --- very inefficient, depending on whether the dictionary for the --- Enumerable is shared or not.) -index :: Enumerable a => Integer -> a +-- | Index into an enumeration. Mainly used for party tricks (give it a really large number), since usually you want to distinguish values by size. +index :: Enumerable a => Integer -> a index = indexWith optimal --- | A more fine grained version of index that takes a size and an --- index into the values of that size. @select p i@ is only defined for @i@ +-- | A more fine grained version of index that takes a size and an +-- index into the values of that size. @select p i@ is only defined +-- for @i@ within bounds (meaning @i < fst (values !! p)@). select :: Enumerable a => Int -> Index -> a select = selectWith optimal +{- +-- Not too happy with this phantom argument +countThese :: Enumerable a => a -> Int -> Integer +countThese x k = help x (drop k $ parts optimal) where + help :: a -> [Finite a] -> Integer + help _ [] = 0 + help _ (f:_) = fCard f +-} + -- | All values of the enumeration by increasing cost (which is the number --- of constructors for most types). Also contains the cardinality of each list. +-- of constructors for most types). Also contains the length of each list. values :: Enumerable a => [(Integer,[a])] values = valuesWith optimal --- | A generalisation of @values@ that enumerates every nth value of the --- enumeration from a given starting point. --- As a special case @values = striped 0 1@. --- --- Useful for running enumerations in parallel since e.g. @striped 0 2@ is --- disjoint from @striped 0 1 2@ and the union of the two cover all values. -striped :: Enumerable a => Index -> Integer -> [(Integer,[a])] -striped = stripedWith optimal --- | A version of values with a limited number of values in each inner list. --- If the list corresponds to a Part which is larger than the bound it evenly --- distributes the values across the enumeration of the Part. -bounded :: Enumerable a => Integer -> [(Integer,[a])] -bounded = boundedWith optimal - - --- | Check a property for all values up to a given size. --- @ featCheck p prop = 'ioAll' p ('inputRep' prop) @ -featCheck :: (Enumerable a, Show a) => Int -> (a -> Bool) -> IO () -featCheck p prop = ioAll p (inputRep prop) - --- | Functions that test a property and reports the result. -type Report a = a -> IO () - --- | A rather simple but general property testing driver. --- The property is an (funcurried) IO function that both tests and reports the --- error. The driver goes on forever or until the list is exhausted, --- reporting its progress and the number of --- tests before each new part. -ioFeat :: [(Integer,[a])] -> Report a -> IO () -ioFeat vs f = go vs 0 0 where - go ((c,xs):xss) s tot = do - putStrLn $ "--- Testing "++show c++" values at size " ++ show s - mapM f xs - go xss (s+1) (tot + c) - go [] s tot = putStrLn $ "--- Done. Tested "++ show tot++" values" - --- | Defined as @ioAll p = 'ioFeat' (take p 'values') @ -ioAll :: Enumerable a => Int -> Report a -> IO () -ioAll p = ioFeat (take p values) - --- | Defined as @ioBounded n p = 'ioFeat' (take p $ 'bounded' n)@ -ioBounded :: Enumerable a => Integer -> Int -> Report a -> IO () -ioBounded n p = ioFeat (take p $ bounded n) - --- | Reports counterexamples to the given predicate by printing them -inputRep :: Show a => (a -> Bool) -> Report a -inputRep pred a = if pred a - then return () - else do - putStrLn "Counterexample found:" - print a - putStrLn "" - --- | Takes a function and a predicate on its input/output pairs. --- Reports counterexamples by printing the failing input/output pair. -prePostRep :: (Show a, Show b) => (a -> b) -> (a -> b -> Bool) -> Report a -prePostRep f pred a = let fa = f a in if pred a fa - then return () - else do - putStrLn "Counterexample found. Input:" - print a - putStrLn "Output:" - print fa - putStrLn "" - - --- | Compatibility with QuickCheck. Distribution is uniform generator over +-- | Compatibility with QuickCheck. Distribution is uniform generator over -- values bounded by the given size. Typical use: @sized uniform@. uniform :: Enumerable a => Int -> Gen a uniform = uniformWith optimal --- | Compatibility with SmallCheck. -toSeries :: Enumerable a => Int -> [a] -toSeries = toSeriesWith optimal - - -- | Non class version of 'index'. indexWith :: Enumerate a -> Integer -> a indexWith e i0 = go (parts e) i0 where @@ -158,48 +84,54 @@ valuesWith :: Enumerate a -> [(Integer,[a])] valuesWith = map fromFinite . parts --- | Non class version of 'striped'. -stripedWith :: Enumerate a -> Index -> Integer -> [(Integer,[a])] -stripedWith e o0 step = stripedWith' (parts e) o0 where - stripedWith' [] o = [] - stripedWith' (Finite crd ix : ps) o = - (max 0 d,thisP) : stripedWith' ps o' - where - o' = if space <= 0 then o-crd else step-m-1 - thisP = map ix (genericTake d $ iterate (+step) o) - space = crd - o - (d,m) = divMod space step - --- | Non class version of 'bounded'. -boundedWith :: Enumerate a -> Integer -> [(Integer,[a])] -boundedWith e n = map (samplePart n) $ parts e - --- Specification: pick at most @m@ evenly distributed values from part @p@ of @e@ --- Return the list length together with the list of the selected values. -samplePart :: Index -> Finite a -> (Integer,[a]) -samplePart m (Finite crd ix) = - let step = crd % m - in if crd <= m - then (crd, map ix [0..crd - 1]) - else (m, map ix [ round (k * step) - | k <- map toRational [0..m-1]]) --- The first value is at index 0 and the last value is at index ~= crd - step --- This is "fair" if we consider using samplePart on the next part as well. --- An alternative would be to make the last index used |crd-1|. - - -- | Non class version of 'uniform'. uniformWith :: Enumerate a -> Int -> Gen a uniformWith = uni . parts where - uni :: [Finite a] -> Int -> Gen a + uni :: [Finite a] -> Int -> Gen a uni [] _ = error "uniform: empty enumeration" uni ps maxp = let (incl, rest) = splitAt maxp ps - fin = mconcat incl + fin = mconcat incl in case fCard fin of 0 -> uni rest 1 _ -> do i <- choose (0,fCard fin-1) - return (fIndex fin i) - --- | Non class version of 'toSeries'. -toSeriesWith :: Enumerate a -> Int -> [a] -toSeriesWith e d = concat (take (d+1) $ map snd $ valuesWith e) + return (fIndex fin i) + + +-- | Enumerates every nth value of the enumeration from a given starting index. +-- As a special case @striped 0 1@ gives all values (starts at index 0 and takes steps of 1). +-- +-- Useful for running enumerations in parallel since e.g. @striped 0 2@ is +-- disjoint from @striped 1 2@ and the union of the two cover all values. +skipping :: Enumerate a -> Index -> Integer -> Enumerate a +skipping _ o0 step | step <= 0 || o0 < 0 = error "skippingWith: invalid argument" +skipping e o0 step = fromParts $ go o0 (parts e) where + go o [] = [] + go o _ | o < 0 = error "negative" + go o (p:ps) = p' : go o' ps where -- error (show (space,take,o')) : + space = fCard p - o + (take,o') | space <= 0 = (0,o-fCard p) + | space < step = (1,step-space) + | otherwise = (space `quotRem` step) + p' = Finite{fCard = take + , fIndex = \i -> fIndex p (i*step + o)} + +-- | A version of values with a limited number of values in each inner list. +-- If the list corresponds to a Part which is larger than the bound it evenly +-- distributes the values across the enumeration of the Part. +bounded :: Enumerate a -> Integer -> Enumerate a +bounded e n = fromParts $ map (samplePart n) $ parts e where + -- The first value is at index 0 and the last value is at index ~= crd - step + -- This is "fair" if we consider using samplePart on the next part as well. + -- An alternative would be to make the last index used |crd-1|. + samplePart :: Index -> Finite a -> Finite a + samplePart m f@(Finite crd ix) = + let step = crd % m + in if crd <= m + then f + else Finite{fCard = m, fIndex = \i -> fIndex f (floor (toRational i * step))} + +-- | Remove all sizes exept those in the given inclusive (low,high) range +sizeRange :: Enumerate a -> (Int, Int) -> Enumerate a +sizeRange e (lo, hi) = fromParts $ take (1+hi-lo) $ drop lo $ parts e + + diff --git a/Test/Feat/Class.hs b/Test/Feat/Class.hs --- a/Test/Feat/Class.hs +++ b/Test/Feat/Class.hs @@ -1,358 +1,32 @@ -{-#LANGUAGE DeriveDataTypeable, TemplateHaskell #-} - --- | Everything you need to construct an enumeration for an algebraic type. --- Just define each constructor using pure for nullary constructors and --- unary and funcurry for positive arity constructors, then combine the --- constructors with consts. Example: --- --- @ --- instance Enumerable a => Enumerable [a] where --- enumerate = consts [unary (funcurry (:)), pure []] --- @ --- --- There's also a handy Template Haskell function for automatic derivation. - - -module Test.Feat.Class ( - Enumerable(..), - - -- ** Building instances - Constructor, - nullary, - unary, - funcurry, - consts, - - -- ** Accessing the enumerator of an instance - shared, - optimal, - - -- *** Free pairs - FreePair(..), - - - -- ** Deriving instances with template Haskell - deriveEnumerable, - deriveEnumerable', - ConstructorDeriv, - dAll, - dExcluding, - dExcept - -- autoCon, - -- autoCons - ) where - --- testing-feat -import Test.Feat.Enumerate -import Test.Feat.Internals.Tag(Tag(Class)) -import Test.Feat.Internals.Derive -import Test.Feat.Internals.Newtypes --- base -import Data.Typeable -import Data.Monoid --- template-haskell -import Language.Haskell.TH -import Language.Haskell.TH.Syntax --- base - only for instances -import Data.Word -import Data.Int -import Data.Bits -import Data.Ratio - --- | A class of functionally enumerable types -class Typeable a => Enumerable a where - -- | This is the interface for defining an instance. When combining - -- enumerations use 'shared' instead and when accessing the data of - -- enumerations use 'optimal'. - enumerate :: Enumerate a - - --- | Version of 'enumerate' that ensures that the enumeration is shared --- between all accesses. Should always be used when --- combining enumerations. -shared :: Enumerable a => Enumerate a -shared = eShare Class enumerate - --- | An optimal version of enumerate. Used by all --- library functions that access enumerated values (but not --- by combining functions). Library functions should ensure that --- @optimal@ is not reevaluated. -optimal :: Enumerable a => Enumerate a -optimal = optimise shared - --- | A free pair constructor. The cost of constructing a free pair --- is equal to the sum of the costs of its components. -newtype FreePair a b = Free {free :: (a,b)} - deriving (Show, Typeable) - --- | Uncurry a function (typically a constructor) to a function on free pairs. -funcurry :: (a -> b -> c) -> FreePair a b -> c -funcurry f = uncurry f . free - -instance (Enumerable a, Enumerable b) => - Enumerable (FreePair a b) where - enumerate = curry Free <$> shared <*> shared - -type Constructor = Enumerate - --- | For nullary constructors such as @True@ and @[]@. -nullary :: a -> Constructor a -nullary = pure - --- | For any non-nullary constructor. Apply 'funcurry' until the type of --- the result is unary (i.e. n-1 times where n is the number of fields --- of the constructor). -unary :: Enumerable a => (a -> b) -> Constructor b -unary f = f <$> shared - --- | Produces the enumeration of a type given the enumerators for each of its --- constructors. The result of 'unary' should typically not be used --- directly in an instance even if it only has one constructor. So you --- should apply consts even in that case. -consts :: [Constructor a] -> Enumerate a -consts xs = pay $ mconcat xs - - --------------------------------------------------------------------- --- Automatic derivation - --- | Derive an instance of Enumberable with Template Haskell. To derive --- an instance for @Enumerable A@, just put this as a top level declaration --- in your module (with the TemplateHaskell extension enabled): --- --- @ --- deriveEnumerable ''A --- @ - -deriveEnumerable :: Name -> Q [Dec] -deriveEnumerable = deriveEnumerable' . dAll - - -type ConstructorDeriv = (Name, [(Name, ExpQ)]) -dAll :: Name -> ConstructorDeriv -dAll n = (n,[]) -dExcluding :: Name -> ConstructorDeriv -> ConstructorDeriv -dExcluding n (t,nrs) = (t,(n,[|mempty|]):nrs) -dExcept :: Name -> ExpQ -> ConstructorDeriv -> ConstructorDeriv -dExcept n e (t,nrs) = (t,(n,e):nrs) - --- | Derive an instance of Enumberable with Template Haskell, with --- rules for some specific constructors -deriveEnumerable' :: ConstructorDeriv -> Q [Dec] -deriveEnumerable' (n,cse) = - fmap return $ instanceFor ''Enumerable [enumDef] n - where - enumDef :: [(Name,[Type])] -> Q Dec - enumDef cons = do - sanityCheck - fmap mk_freqs_binding [|consts $ex |] - where - ex = listE $ map cone cons - cone xs@(n,_) = maybe (cone' xs) id $ lookup n cse - cone' (n,[]) = [|nullary $(conE n)|] - cone' (n,_:vs) = - [|unary $(foldr appE (conE n) (map (const [|funcurry|] ) vs) )|] - mk_freqs_binding :: Exp -> Dec - mk_freqs_binding e = ValD (VarP 'enumerate ) (NormalB e) [] - sanityCheck = case filter (`notElem` map fst cons) (map fst cse) of - [] -> return () - xs -> error $ "Invalid constructors for "++show n++": "++show xs - - - ---------------------------------------------------------------------- --- Instances - -{- --- There may have been some problems with this TH script on older GHC versions. --- Its result is pasted at the end of this file -(let - it = mapM (instanceFor ''Enumerable [enumDef]) - [ ''[] - , ''Bool - , ''() - , ''(,) - , ''(,,) - , ''(,,,) - , ''(,,,,) - , ''(,,,,,) - , ''(,,,,,,) -- This is as far as typeable goes... - , ''Either - , ''Maybe - , ''Ordering - ] - -- Circumventing the stage restrictions by means of code repetition. - enumDef :: [(Name,[Type])] -> Q Dec - enumDef cons = fmap mk_freqs_binding [|consts $ex |] where - ex = listE $ map cone cons - cone (n,[]) = [|pure $(conE n)|] - cone (n,_:vs) = - [|unary $(foldr appE (conE n) (map (const [|funcurry|] ) vs) )|] - mk_freqs_binding :: Exp -> Dec - mk_freqs_binding e = ValD (VarP 'enumerate) (NormalB e) [] - in it) --} - -simpleEnum car sel = - let e = Enumerate - (toRev$ map (\p -> Finite (car p) (sel p)) [0..]) - (return e) - in e - - --- This instance is quite important. It needs to be exponential for --- the other instances to work. -instance Infinite a => Enumerable (Nat a) where - enumerate = simpleEnum crd sel - where - crd p - | p <= 0 = 0 - | p == 1 = 1 - | otherwise = 2^(p-2) - sel :: Num a => Int -> Index -> Nat a - sel 1 0 = Nat 0 - sel p i = Nat $ 2^(p-2) + fromInteger i - - --- This instance is used by the Int* instances and needs to be exponential as --- well. -instance Enumerable Integer where - enumerate = unary f where - f (Free (b,Nat i)) = if b then -i-1 else i - -instance (Infinite a, Enumerable a) => Enumerable (NonZero a) where - enumerate = unary (\a -> NonZero $ if a >= 0 then a+1 else a) - --- An exported version would have to use $tag instead of Class -word :: (Bits a, Integral a) => Enumerate a -word = e where - e = cutOff (bitSize' e+1) $ unary (fromInteger . nat) - -int :: (Bits a, Integral a) => Enumerate a -int = e where - e = cutOff (bitSize' e+1) $ unary fromInteger - -cutOff :: Int -> Enumerate a -> Enumerate a -cutOff n e = Enumerate prts (fmap (cutOff n) (optimiser e)) where - prts = toRev$ take n $ parts e - -bitSize' :: Bits a => f a -> Int -bitSize' f = hlp undefined f where - hlp :: Bits a => a -> f a -> Int - hlp a _ = bitSize a - -instance Enumerable Word where - enumerate = word -instance Enumerable Word8 where - enumerate = word -instance Enumerable Word16 where - enumerate = word -instance Enumerable Word32 where - enumerate = word -instance Enumerable Word64 where - enumerate = word - -instance Enumerable Int where - enumerate = int -instance Enumerable Int8 where - enumerate = int -instance Enumerable Int16 where - enumerate = int -instance Enumerable Int32 where - enumerate = int -instance Enumerable Int64 where - enumerate = int - --- | Not injective -instance Enumerable Double where - enumerate = unary (funcurry encodeFloat) - --- | Not injective -instance Enumerable Float where - enumerate = unary (funcurry encodeFloat) - --- This should be fixed with a bijective function. --- | Not injective -instance (Infinite a, Enumerable a) => Enumerable (Ratio a) where - enumerate = unary $ funcurry $ \a b -> a % nonZero b - --- | Contains only ASCII characters -instance Enumerable Char where - enumerate = cutOff 8 $ unary (toEnum . fromIntegral :: Word -> Char) - - - - ----- The rest of this file is automatically generated with -ddump-splices, then adjusted by hand -instance Enumerable a_12 => - Enumerable ([] a_12) where - enumerate - = consts - [pure [], - unary (funcurry (:))] -instance Enumerable Bool where - enumerate = consts [pure False, pure True] -instance Enumerable () where - enumerate = consts [pure ()] -instance (Enumerable a_12, Enumerable b_13) => - Enumerable ((,) a_12 b_13) where - enumerate = consts [unary (funcurry (,))] -instance (Enumerable a_12, Enumerable b_13, Enumerable c_14) => - Enumerable ((,,) a_12 b_13 c_14) where - enumerate - = consts [unary (funcurry (funcurry (,,)))] -instance (Enumerable a_12, - Enumerable b_13, - Enumerable c_14, - Enumerable d_15) => - Enumerable ((,,,) a_12 b_13 c_14 d_15) where - enumerate - = consts - [unary (funcurry (funcurry (funcurry (,,,))))] -instance (Enumerable a_12, - Enumerable b_13, - Enumerable c_14, - Enumerable d_15, - Enumerable e_16) => - Enumerable ((,,,,) a_12 b_13 c_14 d_15 e_16) where - enumerate - = consts - [unary - (funcurry - (funcurry (funcurry (funcurry (,,,,)))))] -instance (Enumerable a_12, - Enumerable b_13, - Enumerable c_14, - Enumerable d_15, - Enumerable e_16, - Enumerable f_17) => - Enumerable ((,,,,,) a_12 b_13 c_14 d_15 e_16 f_17) where - enumerate - = consts - [unary - (funcurry - (funcurry - (funcurry (funcurry (funcurry (,,,,,))))))] -instance (Enumerable a_12, - Enumerable b_13, - Enumerable c_14, - Enumerable d_15, - Enumerable e_16, - Enumerable f_17, - Enumerable g_18) => - Enumerable ((,,,,,,) a_12 b_13 c_14 d_15 e_16 f_17 g_18) where - enumerate - = consts - [unary - (funcurry - (funcurry - (funcurry - (funcurry (funcurry (funcurry (,,,,,,)))))))] -instance (Enumerable a_acKx, Enumerable b_acKy) => - Enumerable (Either a_acKx b_acKy) where - enumerate = consts [unary Left, unary Right] -instance Enumerable a_a1aW => Enumerable (Maybe a_a1aW) where - enumerate = consts [pure Nothing, unary Just] -instance Enumerable Ordering where - enumerate = consts [pure LT, pure EQ, pure GT] - + +module Test.Feat.Class {-# DEPRECATED "Use Control.Enumerable instead" #-} + ( Enumerable(..) + , nullary + , unary + , funcurry + , shared + , consts + , deriveEnumerable + ) where + +import Control.Enumerable + +-- compatability +{-# DEPRECATED nullary "use c0 instead" #-} +-- nullary :: x -> Memoizable f x +nullary x = c0 x + +{-# DEPRECATED unary "use c1 instead" #-} +-- unary :: (Enumerable a, MemoSized f) => (a -> x) -> f x +unary x = c1 x + +{-# DEPRECATED shared "use access instead" #-} +shared :: (Sized f, Enumerable a, Typeable f) => Shareable f a +shared = access + + +funcurry = uncurry + +{-# DEPRECATED consts "use datatype instead" #-} +--consts :: (Typeable a, MemoSized f) => [f a] -> Closed (f a) +consts xs = datatype xs diff --git a/Test/Feat/Class/Override.hs b/Test/Feat/Class/Override.hs deleted file mode 100644 --- a/Test/Feat/Class/Override.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | Anexperimental feature to override the 'Enumerable' instance for any type. - -module Test.Feat.Class.Override ( - Override, - noOverride, - addOverride, - override - ) where - -import Test.Feat.Enumerate -import Test.Feat.Class -import Test.Feat.Internals.Tag(Tag(Class)) -import Test.Feat.Modifiers -import Control.Monad.TagShare -import Control.Monad.State - -type Override = DynMap Tag - -noOverride :: Override -noOverride = dynEmpty - -addOverride :: Enumerable a => Enumerate a -> Override -> Override -addOverride = dynInsert Class - --- | This function is best described with an example: --- --- @ --- let e1 = override $ addOverride (unary 'printable') noOverride :: Enumerate T --- @ --- --- @e1@ enumerates values of type @T@ where all characters (accessed using --- the @Enumerable@ instance for @Char@) are printable. Sometimes this can save --- you from placing lots of 'printable' modifiers in your instances or --- newtypes in your data type definitions. --- --- This works for any type (not just characters). This function should typically --- not be used when combining enumerations (doing so might increase memory --- usage because the resulting enumeration is optimised). --- Also this only has effect on enumerations which have not already been --- optimised, so using override again on the result of override has no effect. -override :: Enumerable a => Override -> Enumerate a -override = evalState (optimiser shared) - - diff --git a/Test/Feat/Driver.hs b/Test/Feat/Driver.hs new file mode 100644 --- /dev/null +++ b/Test/Feat/Driver.hs @@ -0,0 +1,133 @@ +-- | A simple testing driver for testing properties using FEAT. +-- Contains three drivers with different levels of flexibility of configuration. +-- +-- Ironically, this code is mostly untested at the moment. +module Test.Feat.Driver( + -- * Simple test driver + test + , Result + , counterexamples + -- * Test driver with show/readable options + , testOptions + , Options(..) + , defOptions + -- * Extremely flexible test driver + , testFlex + , FlexibleOptions(..) + , FlexOptions(..) + , defFlex + , toFlex + , toFlexWith + ) where + +import Control.Enumerable +import Test.Feat.Access +import Test.Feat.Finite +import Test.Feat.Enumerate + +import System.Timeout +import Data.IORef + +-- | Basic options for executing a test. Unlike 'FlexibleOptions' this type has Show/Read instances. +data Options = Options + { oTimeoutSec :: Maybe Int + , oSizeFromTo :: Maybe (Int,Int) -- ^ (first size, last size) + , oMaxCounter :: Maybe Int -- ^ Maximum number of counterexamples + , oSilent :: Bool + , oSkipping :: Maybe (Index, Integer) -- ^ (start-index, steps to skip) + , oBounded :: Maybe Integer -- ^ Maximum number of tests per size + } deriving (Show,Read) + +-- | Much more flexible options for configuring every part of the test execution. +-- @a@ is the parameter type of the property. +type FlexibleOptions a = IO (FlexOptions a) + +-- | FlexOptions +data FlexOptions a = FlexOptions + { fIO :: IO Bool -> IO (Result a) -- ^ The whole execution of the test is sent through this function. + , fReport :: a -> IO Bool -- ^ Applied to each found counterexample, return False to stop testing + , fOutput :: String -> IO () -- ^ Print text + , fProcess :: Enumerate a -> Enumerate a -- ^ Applied to the enumeration before running + , fEnum :: Enumerate a -- ^ The base enumeration to use, before applying @fProcess@. + } + +data Result a = Exhausted [a] -- ^ Reached max size + | Quota [a] -- ^ Reached max number of counterexamples + | TimedOut [a] + deriving Show + +counterexamples :: Result a -> [a] +counterexamples (Exhausted xs) = xs +counterexamples (Quota xs) = xs +counterexamples (TimedOut xs) = xs + +-- | 60 seconds timeout, maximum size of 100, bound of 100000 tests per size +defOptions :: Options +defOptions = Options + { oTimeoutSec = Just 60 + , oSizeFromTo = Just (0,100) + , oSilent = False + , oSkipping = Nothing + , oBounded = Just 100000 + , oMaxCounter = Just 1 + } + +defFlex :: Enumerable a => FlexibleOptions a +defFlex = defFlexWith optimal + +-- | For testing without using the 'Enumerable' class. +defFlexWith :: Enumerate a -> FlexibleOptions a +defFlexWith e = toFlexWith e defOptions + +toFlex :: Enumerable a => Options -> FlexibleOptions a +toFlex = toFlexWith optimal + +toFlexWith :: Enumerate a -> Options -> FlexibleOptions a +toFlexWith e o = do + res <- newIORef [] + count <- newIORef 0 + let doReport x = do + modifyIORef res (x:) + modifyIORef count (+1) + maybe (return True) (checkCount) (oMaxCounter o) + checkCount mx = do + n <- readIORef count + return (n < mx) + doIO io = do + mb <- maybe (fmap Just io) (\t -> timeout (t*1000000) io) (oTimeoutSec o) + res <- readIORef res + return $ maybe (TimedOut res) (\b -> if b then Exhausted res else Quota res) mb + skip = maybe id (\(i,n) e -> skipping e i n) (oSkipping o) + bound = maybe id (\n e -> bounded e n) (oBounded o) + sizes = maybe id (\bs e -> sizeRange e bs) (oSizeFromTo o) + return $ FlexOptions + { fIO = doIO + , fOutput = if oSilent o then const (return ()) else putStr + , fReport = doReport + , fProcess = bound . skip . sizes + , fEnum = e + } + +-- | Test with default options ('defOptions'). +test :: Enumerable a => (a -> Bool) -> IO (Result a) +test = testFlex defFlex + +-- | Test with basic options. +testOptions :: Enumerable a => Options -> (a -> Bool) -> IO (Result a) +testOptions = testFlex . toFlex + +-- | The most flexible test driver, can be configured to behave in almost any way. +testFlex :: FlexibleOptions a -> (a -> Bool) -> IO (Result a) +testFlex ioOp p = do + op <- ioOp + let e = fProcess op (fEnum op) + lazyResult = [(n,filter (not . p) xs) | (n,xs) <- valuesWith e] + runSize k (n,cs) = do + fOutput op $ "*** Searching in " ++ show n ++ " values of size " ++ show k ++ "\n" + doWhile (map (\x -> fOutput op "Counterexample found!\n" >> fReport op x) cs) + fIO op ((doWhile $ zipWith runSize [0..] lazyResult)) + +doWhile :: [IO Bool] -> IO Bool +doWhile [] = return True +doWhile (iob:iobs) = iob >>= \b -> if b then doWhile iobs else return False + diff --git a/Test/Feat/Enumerate.hs b/Test/Feat/Enumerate.hs --- a/Test/Feat/Enumerate.hs +++ b/Test/Feat/Enumerate.hs @@ -1,26 +1,26 @@ {-#LANGUAGE DeriveDataTypeable, TemplateHaskell #-} -- | Basic combinators for building enumerations --- most users will want to use the type class --- based combinators in "Test.Feat.Class" instead. +-- most users will want to use the type class +-- based combinators in "Test.Feat.Class" instead. module Test.Feat.Enumerate ( - + Index, Enumerate(..), parts, fromParts, - + -- ** Reversed lists RevList(..), toRev, - + -- ** Finite ordered sets Finite(..), fromFinite, - - + + -- ** Combinators for building enumerations module Data.Monoid, union, @@ -28,77 +28,70 @@ cartesian, singleton, pay, - - -- *** Polymorphic sharing - module Data.Typeable, - Tag(Source), - tag, - eShare, - noOptim, - optimise, - irregular - ) where -- testing-feat -import Control.Monad.TagShare(Sharing, runSharing, share) -import Test.Feat.Internals.Tag(Tag(Source)) +-- import Control.Monad.TagShare(Sharing, runSharing, share) +-- import Test.Feat.Internals.Tag(Tag(Source)) -- base +import Control.Sized import Control.Applicative -import Control.Monad -import Data.Function import Data.Monoid import Data.Typeable -import Language.Haskell.TH import Data.List(transpose) -import Control.Monad.State -- TODO: remove direct dependency on mtl - +import Test.Feat.Finite type Part = Int -type Index = Integer -- | A functional enumeration of type @t@ is a partition of -- @t@ into finite numbered sets called Parts. Each parts contains values -- of a certain cost (typically the size of the value). -data Enumerate a = Enumerate +data Enumerate a = Enumerate { revParts :: RevList (Finite a) - , optimiser :: Sharing Tag (Enumerate a) - } deriving Typeable + } deriving Typeable parts :: Enumerate a -> [Finite a] parts = fromRev . revParts fromParts :: [Finite a] -> Enumerate a -fromParts ps = Enumerate (toRev ps) (return $ fromParts ps) +fromParts ps = Enumerate (toRev ps) -- | Only use fmap with bijective functions (e.g. data constructors) -instance Functor Enumerate where - fmap f e = Enumerate (fmap (fmap f) $ revParts e) (fmap (noOptim . fmap f) $ optimiser e) +instance Functor Enumerate where + fmap f e = Enumerate (fmap (fmap f) $ revParts e) -- | Pure is 'singleton' and '<*>' corresponds to cartesian product (as with lists) instance Applicative Enumerate where pure = singleton f <*> a = fmap (uncurry ($)) (cartesian f a) +instance Alternative Enumerate where + empty = Enumerate mempty + (<|>) = union + +instance Sized Enumerate where + pay e = Enumerate (revCons mempty $ revParts e) + aconcat = mconcat + pair = cartesian + fin k = fromParts [finFin k] + -- | The @'mappend'@ is (disjoint) @'union'@ instance Monoid (Enumerate a) where - mempty = Enumerate mempty (return mempty) + mempty = empty mappend = union mconcat = econcat - + -- | Optimal 'mconcat' on enumerations. econcat :: [Enumerate a] -> Enumerate a econcat [] = mempty econcat [a] = a econcat [a,b] = union a b -econcat xs = Enumerate +econcat xs = Enumerate (toRev . map mconcat . transpose $ map parts xs) - (fmap (noOptim . econcat) $ mapM optimiser xs) -- Product of two enumerations -cartesian (Enumerate xs1 o1) (Enumerate xs2 o2) = - Enumerate (xs1 `prod` xs2) (fmap noOptim $ liftM2 cartesian o1 o2) +cartesian (Enumerate xs1) (Enumerate xs2) = Enumerate (xs1 `prod` xs2) prod :: RevList (Finite a) -> RevList (Finite b) -> RevList (Finite (a,b)) prod (RevList [] _) _ = mempty @@ -118,40 +111,35 @@ go xs@(_:xs') = conv xs ry : go xs' conv :: [Finite a] -> [Finite b] -> Finite (a,b) - conv xs ys = Finite - (sum $ zipWith (*) (map fCard xs) (map fCard ys )) + conv xs ys = Finite + (sum $ zipWith (*) (map fCard xs) (map fCard ys )) (prodSel xs ys) prodSel :: [Finite a] -> [Finite b] -> (Index -> (a,b)) - prodSel (f1:f1s) (f2:f2s) = \i -> - let mul = fCard f1 * fCard f2 - in if i < mul - then let (q, r) = (i `quotRem` fCard f2) + prodSel (f1:f1s) (f2:f2s) = \i -> + let mul = fCard f1 * fCard f2 + in if i < mul + then let (q, r) = (i `quotRem` fCard f2) in (fIndex f1 q, fIndex f2 r) else prodSel f1s f2s (i-mul) prodSel _ _ = \i -> error "index out of bounds" union :: Enumerate a -> Enumerate a -> Enumerate a -union (Enumerate xs1 o1) (Enumerate xs2 o2) = - Enumerate (xs1 `mappend` xs2) (fmap noOptim $ liftM2 union o1 o2) +union (Enumerate xs1) (Enumerate xs2) = Enumerate (xs1 `mappend` xs2) --- | The definition of @pure@ for the applicative instance. +-- | The definition of @pure@ for the applicative instance. singleton :: a -> Enumerate a -singleton a = Enumerate (revPure $ finPure a) (return (singleton a)) +singleton a = Enumerate (revPure $ pure a) --- | Increases the cost of all values in an enumeration by one. -pay :: Enumerate a -> Enumerate a -pay e = Enumerate (revCons mempty $ revParts e) (fmap (noOptim . pay) $ optimiser e) - ------------------------------------------------------------------ -- Reverse lists --- | A data structure that contains a list and the reversals of all initial --- segments of the list. Intuitively +-- | A data structure that contains a list and the reversals of all initial +-- segments of the list. Intuitively -- -- @reversals xs !! n = reverse (take (n+1) (fromRev xs))@ -- @@ -169,110 +157,19 @@ mappend xs ys = toRev$ zipMon (fromRev xs) (fromRev ys) where zipMon :: Monoid a => [a] -> [a] -> [a] zipMon (x:xs) (y:ys) = x <> y : zipMon xs ys - zipMon xs ys = xs ++ ys + zipMon xs ys = xs ++ ys --- | Constructs a "Reverse list" variant of a given list. In a sensible --- Haskell implementation evaluating any inital segment of +-- | Constructs a "Reverse list" variant of a given list. In a sensible +-- Haskell implementation evaluating any inital segment of -- @'reversals' (toRev xs)@ uses linear memory in the size of the segment. toRev:: [a] -> RevList a toRev xs = RevList xs $ go [] xs where go _ [] = [] go rev (x:xs) = let rev' = x:rev in rev' : go rev' xs - --- | Adds an element to the head of a @RevList@. Constant memory iff the --- the reversals of the resulting list are not evaluated (which is frequently + +-- | Adds an element to the head of a @RevList@. Constant memory iff the +-- the reversals of the resulting list are not evaluated (which is frequently -- the case in @Feat@). revCons a = toRev. (a:) . fromRev revPure a = RevList [a] [[a]] - - - - - -------------------------------------------------------- --- Polymorphic sharing - -eShare :: Typeable a => Tag -> Enumerate a -> Enumerate a -eShare t e = e{optimiser = share t (optimiser e)} - --- Automatically generates a unique tag based on the source position. -tag :: Q Exp -- :: Tag -tag = location >>= makeTag where - makeTag Loc{ loc_package = p, - loc_module = m, - loc_start = (r,c) } - = [|Source p m r c|] - -optimise :: Enumerate a -> Enumerate a -optimise e = let e' = runSharing (optimiser e) in - e'{optimiser = return e'} - -noOptim :: Enumerate a -> Enumerate a -noOptim e = e{optimiser = return e} - --- | Used to avoid non-termination of 'optimise' in the presence of --- irregular data types. @irregular@ should be applied to the enumeration for the --- constructor that introduces the irregularity. Excessive use may impact --- performance -irregular :: Enumerate a -> Enumerate a -irregular e = e{optimiser = gets $ evalState $ optimiser e} - - --------------------------------------------------------- --- Operations on finite sets -data Finite a = Finite {fCard :: Index, fIndex :: Index -> a} - -finEmpty = Finite 0 (\i -> error "index: Empty") - -finUnion :: Finite a -> Finite a -> Finite a -finUnion f1 f2 - | fCard f1 == 0 = f2 - | fCard f2 == 0 = f1 - | otherwise = Finite car sel where - car = fCard f1 + fCard f2 - sel i = if i < fCard f1 - then fIndex f1 i - else fIndex f2 (i-fCard f1) - -instance Functor Finite where - fmap f fin = fin{fIndex = f . fIndex fin} - -instance Applicative Finite where - pure = finPure - a <*> b = fmap (uncurry ($)) (finCart a b) - - -instance Monoid (Finite a) where - mempty = finEmpty - mappend = finUnion - mconcat xs = Finite - (sum $ map fCard xs) - (sumSel $ filter ((>0) . fCard) xs) - -sumSel :: [Finite a] -> (Index -> a) -sumSel (f:rest) = \i -> if i < fCard f - then fIndex f i - else sumSel rest (i-fCard f) -sumSel _ = error "Index out of bounds" - -finCart :: Finite a -> Finite b -> Finite (a,b) -finCart f1 f2 = Finite car sel where - car = fCard f1 * fCard f2 - sel i = let (q, r) = (i `quotRem` fCard f2) - in (fIndex f1 q, fIndex f2 r) - -finPure :: a -> Finite a -finPure a = Finite 1 one where - one 0 = a - one _ = error "index: index out of bounds" - - -fromFinite :: Finite a -> (Index,[a]) -fromFinite (Finite c ix) = (c,map ix [0..c-1]) - - -instance Show a => Show (Finite a) where - show = show . fromFinite - - diff --git a/Test/Feat/Finite.hs b/Test/Feat/Finite.hs new file mode 100644 --- /dev/null +++ b/Test/Feat/Finite.hs @@ -0,0 +1,68 @@ +-- | A datatype of finite sequences +module Test.Feat.Finite (Finite (..), Index, fromFinite, finFin) where + +import Control.Applicative +import Data.Monoid + +type Index = Integer +data Finite a = Finite {fCard :: Index, fIndex :: Index -> a} + +finEmpty = Finite 0 (\i -> error "index: Empty") + +finUnion :: Finite a -> Finite a -> Finite a +finUnion f1 f2 + | fCard f1 == 0 = f2 + | fCard f2 == 0 = f1 + | otherwise = Finite car sel where + car = fCard f1 + fCard f2 + sel i = if i < fCard f1 + then fIndex f1 i + else fIndex f2 (i-fCard f1) + +instance Functor Finite where + fmap f fin = fin{fIndex = f . fIndex fin} + +instance Applicative Finite where + pure = finPure + a <*> b = fmap (uncurry ($)) (finCart a b) + +instance Alternative Finite where + empty = finEmpty + (<|>) = finUnion + +instance Monoid (Finite a) where + mempty = finEmpty + mappend = finUnion + mconcat xs = Finite + (sum $ map fCard xs) + (sumSel $ filter ((>0) . fCard) xs) + +sumSel :: [Finite a] -> (Index -> a) +sumSel (f:rest) = \i -> if i < fCard f + then fIndex f i + else sumSel rest (i-fCard f) +sumSel _ = error "Index out of bounds" + +finCart :: Finite a -> Finite b -> Finite (a,b) +finCart f1 f2 = Finite car sel where + car = fCard f1 * fCard f2 + sel i = let (q, r) = (i `quotRem` fCard f2) + in (fIndex f1 q, fIndex f2 r) + +finPure :: a -> Finite a +finPure a = Finite 1 one where + one 0 = a + one _ = error "Index out of bounds" + + +fromFinite :: Finite a -> (Index,[a]) +fromFinite (Finite c ix) = (c,map ix [0..c-1]) + + +instance Show a => Show (Finite a) where + show = show . fromFinite + +finFin :: Integer -> Finite Integer +finFin k | k <= 0 = finEmpty +finFin k = Finite k (\i -> i) + diff --git a/Test/Feat/Internals/Derive.hs b/Test/Feat/Internals/Derive.hs deleted file mode 100644 --- a/Test/Feat/Internals/Derive.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-#Language CPP#-} -{-#Language TemplateHaskell#-} -module Test.Feat.Internals.Derive where -import Language.Haskell.TH - --- General combinator for class derivation -instanceFor :: Name -> [[(Name,[Type])] -> Q Dec] -> Name -> Q Dec -instanceFor clname confs dtname = do - (cxt,dtvs,cons) <- extractData dtname - cd <- mapM conData cons - let - mkCxt = fmap (cxt++) $ mapM (classP clname . return . varT) dtvs - mkTyp = mkInstanceType clname dtname dtvs - mkDecs conf = conf cd - - instanceD mkCxt mkTyp (map mkDecs confs) - - -mkInstanceType :: Name -> Name -> [Name] -> Q Type -mkInstanceType cn dn vns = appT (conT cn) (foldl (appT) (conT dn) (map varT vns)) - -extractData :: Name -> Q (Cxt, [Name], [Con]) -extractData n = reify n >>= \i -> return $ case i of -#if MIN_VERSION_template_haskell(2,11,0) - TyConI (DataD cxt _ tvbs _ cons _) -> (cxt, map tvbName tvbs, cons) - TyConI (NewtypeD cxt _ tvbs _ con _) -> (cxt, map tvbName tvbs, [con]) -#else - TyConI (DataD cxt _ tvbs cons _) -> (cxt, map tvbName tvbs, cons) - TyConI (NewtypeD cxt _ tvbs con _) -> (cxt, map tvbName tvbs, [con]) -#endif - _ -> error $ "Unexpected info: " ++ show (ppr i) - -tvbName :: TyVarBndr -> Name -tvbName (PlainTV n) = n -tvbName (KindedTV n _) = n - - -conData :: Con -> Q (Name,[Type]) -conData c = case c of - NormalC n sts -> return (n,map snd sts) - RecC n vsts -> return (n,map (\(_,s,t) -> t) vsts) - InfixC st1 n st2 -> return (n,[snd st1,snd st2]) - ForallC _ _ c' -> conData c' - - -x :: IO Type -x = runQ $ (toType ''(,)) - - -toType n = case lookup n tups of - Nothing -> conT n - Just q -> q - -tups = (''(), [t|()|]):map (\(n,i) -> (n, tupleT i)) (zip [''(,), ''(,,)] [2..]) diff --git a/Test/Feat/Internals/Newtypes.hs b/Test/Feat/Internals/Newtypes.hs deleted file mode 100644 --- a/Test/Feat/Internals/Newtypes.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-#LANGUAGE DeriveDataTypeable #-} -module Test.Feat.Internals.Newtypes ( - Infinite(..), - Nat(..), - NonZero(..) - )where - -import Data.Typeable - --- | A class of infinite precision integral types. 'Integer' is the principal --- class member. -class (Typeable a, Integral a) => Infinite a - -instance Infinite Integer - --- | A type of (infinite precision) natural numbers such that @ nat a >= 0 @. -newtype Nat a = Nat {nat :: a} - deriving (Typeable, Show, Eq, Ord) - --- | A type of (infinite precision) non-zero integers such that @ nonZero a /= 0 @. -newtype NonZero a = NonZero {nonZero :: a} - deriving (Typeable, Show, Eq, Ord) diff --git a/Test/Feat/Internals/Tag.hs b/Test/Feat/Internals/Tag.hs deleted file mode 100644 --- a/Test/Feat/Internals/Tag.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Test.Feat.Internals.Tag where - -data Tag = Class - | Source String String Int Int - deriving (Show,Eq,Ord) diff --git a/Test/Feat/Modifiers.hs b/Test/Feat/Modifiers.hs --- a/Test/Feat/Modifiers.hs +++ b/Test/Feat/Modifiers.hs @@ -1,97 +1,26 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- | Modifiers for types, i.e. newtype wrappers where the values satisfy some --- constraint (non-empty, positive etc.). Suggestions on useful types are --- appreciated. --- --- To apply the modifiers types you can use the record label. For instance: --- --- @ --- data C a = C [a] [a] deriving 'Typeable' --- instance 'Enumerable' a => 'Enumerable' (C a) where --- 'enumerate' = 'unary' $ 'funcurry' $ --- \\xs ys -> C ('nonEmpty' xs) ('nonEmpty' ys) --- @ --- --- Alternatively you can put everything in pattern postition: --- --- @ --- instance 'Enumerable' a => 'Enumerable' (C a) where --- 'enumerate' = 'unary' $ 'funcurry' $ --- \\('Free' ('NonEmpty' xs,'NonEmpty' ys)) -> C xs ys) --- @ --- --- The first approach has the advantage of being usable with a --- point free style: @ \\xs -> C ('nonEmpty' xs) . 'nonEmpty' @. -module Test.Feat.Modifiers( - -- ** List modifiers - NonEmpty(..), - mkNonEmpty, - - -- ** Numeric modifiers - Infinite(..), - Nat(..), - NonZero(..), - - -- ** Character and string modifiers - Unicode(..), - unicodes, - Printable(..), - printables - - ) where - --- testing-feat -import Test.Feat.Enumerate -import Test.Feat.Class -import Test.Feat.Internals.Newtypes --- quickcheck -- Should be made compatible at some point. --- import Test.QuickCheck.Modifiers - - --- | A type of non empty lists. -newtype NonEmpty a = NonEmpty {nonEmpty :: [a]} - deriving (Typeable, Show) -mkNonEmpty :: (a,[a]) -> NonEmpty a -mkNonEmpty (x,xs) = NonEmpty $ x:xs -instance Enumerable a => Enumerable (NonEmpty a) where - enumerate = unary $ mkNonEmpty - - -enumerateBounded :: (Enum a) => Int -> Int -> Enumerate a -enumerateBounded from to = let e = Enumerate prts (return e) in e - where - prts = toRev$ map (\p -> Finite (crd p) (sel p)) [0..] - crd p - | p <= 0 = 0 - | p == 1 = 1 - | 2^(p-1) > num = max 0 (num - 2^(p-2)) - | otherwise = 2^(p-2) - sel 1 0 = toEnum from - sel p i = toEnum $ 2^(p-2) + fromInteger i + from - num = toInteger $ to - from - --- | Any unicode character. -newtype Unicode = Unicode {unicode :: Char} - deriving (Typeable, Show, Eq, Ord) - -instance Enumerable Unicode where - enumerate = fmap Unicode $ enumerateBounded - (fromEnum (minBound :: Char)) - (fromEnum (maxBound :: Char)) - --- | Smart constructor for unicode strings. -unicodes :: [Unicode] -> String -unicodes = map unicode - --- | Printable ASCII characters -newtype Printable = Printable {printable :: Char} - deriving (Typeable, Show) - -instance Enumerable Printable where - enumerate = fmap Printable $ enumerateBounded 32 126 - --- | Smart constructor for printable ASCII strings -printables :: [Printable] -> String -printables = map printable - +-- | Modifiers for types, i.e. newtype wrappers where the values satisfy some +-- constraint (non-empty, positive etc.). Suggestions on useful types are +-- appreciated. +-- +-- To apply the modifiers types you can use the record label. For instance: +-- +-- @ +-- data C a = C [a] [a] deriving 'Typeable' +-- instance 'Enumerable' a => 'Enumerable' (C a) where +-- 'enumerate' = 'c2' $ +-- \\xs ys -> C ('nonEmpty' xs) ('nonEmpty' ys) +-- @ +-- +-- Alternatively you can put everything in pattern postition: +-- +-- @ +-- instance 'Enumerable' a => 'Enumerable' (C a) where +-- 'enumerate' = 'unary' $ 'funcurry' $ +-- \\('Free' ('NonEmpty' xs,'NonEmpty' ys)) -> C xs ys) +-- @ +-- +-- The first approach has the advantage of being usable with a +-- point free style: @ \\xs -> C ('nonEmpty' xs) . 'nonEmpty' @. +module Test.Feat.Modifiers (module Data.Modifiers) where + +import Data.Modifiers diff --git a/examples/haskell-src-exts/hse.hs b/examples/haskell-src-exts/hse.hs --- a/examples/haskell-src-exts/hse.hs +++ b/examples/haskell-src-exts/hse.hs @@ -1,20 +1,23 @@ {-# Language TemplateHaskell #-} import Test.Feat -import Test.Feat.Class +-- import Test.Feat.Class import Test.Feat.Modifiers +import Test.Feat.Driver +import Control.Enumerable + import Language.Haskell.Exts import Language.Haskell.Exts.Syntax import Control.Exception as Ex -- Welcome to the automatic HSE tester! --- Things to try while youre here: +-- Things to try while youre here: -- switch between Exp/Module/Decl etc. as testing types (e.g. TestRoundtrip) -- to discover bugs in the various entry-points of the grammar. --- TODOs: add some newtypes and modifiers to deal with syntax type invariants --- (such as only enumerating non-empty do-expressions with a statement as last +-- TODOs: add some newtypes and modifiers to deal with syntax type invariants +-- (such as only enumerating non-empty do-expressions with a statement as last -- expression). -- -- Catalogue and report all the bugs found. @@ -25,10 +28,10 @@ run n = main_parse n --- Everything which is produced by the pretty printer and is parseable is +-- Everything which is produced by the pretty printer and is parseable is -- semantically euivalent to the original. type TestRoundtrip = Exp -main_round n = ioFeat (take n values) (rep_round :: TestRoundtrip -> IO()) +main_round n = undefined rep_round :: (Eq a,Parseable a, Show a, Pretty a) => a -> IO () rep_round e = case myParse $ prettyPrint e of @@ -40,89 +43,116 @@ putStrLn $ "e'(Pretty): "++(prettyPrint e') putStrLn "" ParseFailed _ err -> return () - +instance Enumerable SrcSpanInfo where + enumerate = datatype [c0 $ SrcSpanInfo (SrcSpan "M.hs" 0 0 0 0) []] + -- Everything produced by the pretty printer is parseable. -type TestParse = Module -main_parse n = ioFeat (take n values) (rep_parse :: TestParse -> IO()) +type TestParse = Module SrcSpanInfo +main_parse n = do + res <- test prop_parse + mapM (putStr . rep_parse) (counterexamples res) -rep_parse :: (Parseable a, Show a, Pretty a) => a -> IO () + +rep_parse :: (Parseable a, Show a, Pretty a) => a -> String rep_parse e = case myParse $ prettyPrint e of - ParseOk e' -> const (return ()) (e' `asTypeOf` e) - ParseFailed _ err -> do - putStrLn (show e) - putStrLn (prettyPrint e) - putStrLn err - putStrLn "" + ParseOk e' -> const "" (e' `asTypeOf` e) + ParseFailed _ err -> unlines + [(show e) + ,(prettyPrint e) + ,err] +prop_parse :: TestParse -> Bool +prop_parse e = case myParse $ prettyPrint e of + ParseOk e' -> const True (e' `asTypeOf` e) + ParseFailed _ err -> False + +{- -- The pretty printer doesnt fail, for testing the enumerators. type TestPrint = Module -main_print n = ioFeat (take n values) (rep_print :: TestPrint -> IO()) -main_print' n = ioFeat (take n $ bounded 100000) (rep_print :: TestPrint -> IO()) - - prop_print :: Pretty a => a -> Bool prop_print e = length (prettyPrint e) >= 0 rep_print :: (Show a, Pretty a) => a -> IO () -rep_print e = Ex.catch +rep_print e = Ex.catch (prop_print e `seq` return ()) (\err -> do putStrLn (show e) if show (err::SomeException) == "user interrupt" then undefined else return () putStrLn $ show (err::SomeException) putStrLn "") +-} myParse :: Parseable a => String -> ParseResult a myParse = parseWithMode defaultParseMode{ extensions = ge' } -ge' = [ TypeFamilies - ] +ge' = map EnableExtension + [ TypeFamilies + , TemplateHaskell + , MagicHash + , ParallelArrays + , LambdaCase + , ExplicitNamespaces + ] sureParse :: Parseable a => String -> a sureParse s = case myParse s of ParseOk a -> a ParseFailed _ err -> error err - + parse_print :: (Parseable a, Pretty a) => String -> (a,String) parse_print s = let a = sureParse s in (a,prettyPrint a) + + + -- Uncomment the dExcluding line to enable known bugs (let + buggy1 = dExcluding 'UnboxedSingleCon . dAll - buggy2 = - dExcluding 'PQuasiQuote . - dAll - + buggy2 = + dExcluding 'PQuasiQuote . + dAll buggy3 = + dExcept 'LCase [| c2 (\a -> LCase a . nonEmpty) |] . + dExcept 'Do [| c3 $ \a ss e -> Do a (ss ++ [Qualifier a e]) |] . + dExcluding 'XPcdata . dExcluding 'XExpTag . dExcluding 'XChildTag . - dExcept 'XPcdata [| unary $ XPcdata . nonEmpty |] . dAll + dExcept 'XPcdata [| c2 $ \a -> XPcdata a . nonEmpty |] . + dExcept 'MultiIf [| c2 $ \a -> MultiIf a . nonEmpty |] . + dAll + + fixdecs = + dExcept 'InfixDecl [| c4 $ \a b c -> InfixDecl a b c . nonEmpty |] . + dAll + + fixlit = + dExcept 'PrimWord [| c2 (\a x -> PrimWord a (toInteger (x :: Word)) (show x)) |] . + dAll + in fmap concat $ mapM deriveEnumerable' [ dAll ''Module, -- dAll ''SrcLoc, - dExcept 'LanguagePragma [|unary $ funcurry $ \x -> LanguagePragma x . nonEmpty|] + dExcluding 'AnnModulePragma $ dExcluding 'LanguagePragma + -- dExcept 'LanguagePragma [|c2 $ \x -> LanguagePragma x . nonEmpty|] $ dAll ''ModulePragma, - dExcept 'WarnText [|unary $ WarnText . nonEmpty|] - $ dExcept 'DeprText [|unary $ DeprText . nonEmpty|] - $ dAll ''WarningText, - dAll ''ExportSpec, dAll ''ImportDecl, - dAll ''Decl, + fixdecs ''Decl, dAll ''Tool, dAll ''QName, dAll ''ImportSpec, @@ -165,42 +195,77 @@ dAll ''QOp, dAll ''Stmt, dAll ''Alt, - dAll ''Literal, + fixlit ''Literal, dAll ''IPName, dAll ''ConDecl, dAll ''RPatOp, - dAll ''GuardedAlts, + -- dAll ''GuardedAlts, dAll ''BangType, - dAll ''GuardedAlt + -- dAll ''GuardedAlt, + dAll ''TypeEqn, + dAll ''Sign, + dAll ''Role, + dAll ''Promoted, + dAll ''PatternSynDirection, + dAll ''Overlap, + dAll ''Namespace, + dAll ''BooleanFormula, + dAll ''ImportSpecList, + dAll ''DeclHead, + dAll ''ResultSig, + dAll ''InjectivityInfo, + dAll ''Context, + dAll ''Deriving, + dAll ''InstRule, + dAll ''Unpackedness, + dAll ''FieldDecl, + dAll ''InstHead ]) -instance Enumerable ModuleName where - enumerate = consts - [ nullary $ ModuleName "M" - , nullary $ ModuleName "C.M" - ] +instance Enumerable a => Enumerable (ModuleHead a) where + enumerate = datatype [c1 $ \a -> ModuleHead a (ModuleName a "M") Nothing Nothing] --- Will probably need to be broken into constructor/variable/symbol names -instance Enumerable Name where - enumerate = consts - [ nullary $ Ident "C" - , nullary $ Ident "v" - , nullary $ Symbol "*" - ] +instance Enumerable a => Enumerable (ExportSpec a) where + enumerate = datatype [ c2 $ \a -> EVar a . nonSpecial + , c3 $ \a x -> EAbs a x . nonSpecial + -- , c1 $ EThingAll . nonSpecial + -- , c2 $ EThingWith . nonSpecial + , c2 $ EModuleContents + ] -instance Enumerable CName where - enumerate = consts - [ nullary $ VarName (Ident "v") - , nullary $ ConName (Ident "C") - ] +-- newtype Upper = Upper {upper :: QName} +-- instance Enumerable Upper where +-- enumerate = datatype [c2 Qual -instance Enumerable SrcLoc where - enumerate = consts - [ nullary (SrcLoc "File.hs" 0 0)] +newtype NonSpecialName a = NonSpecialName {nonSpecial :: QName a} +instance Enumerable a => Enumerable (NonSpecialName a) where + enumerate = datatype [fmap NonSpecialName $ c3 Qual + ,fmap NonSpecialName $ c2 UnQual + ] +instance Enumerable a => Enumerable (ModuleName a) where + enumerate = datatype + [ c1 $ \a -> ModuleName a "M" + , c1 $ \a -> ModuleName a "C.M" + ] +-- Will probably need to be broken into constructor/variable/symbol names +instance Enumerable a => Enumerable (Name a) where + enumerate = datatype + [ c1 $ \a -> Ident a "C" + , c1 $ \a -> Ident a "v" +-- , c0 $ Symbol "*" + ] +instance Enumerable a => Enumerable (CName a) where + enumerate = datatype + [ c1 $ \a -> VarName a (Ident a "v") + , c1 $ \a -> ConName a (Ident a "C") + ] +instance Enumerable SrcLoc where + enumerate = datatype + [ c0 (SrcLoc "File.hs" 0 0)] diff --git a/examples/lambda-terms/lambdas.hs b/examples/lambda-terms/lambdas.hs --- a/examples/lambda-terms/lambdas.hs +++ b/examples/lambda-terms/lambdas.hs @@ -2,31 +2,31 @@ {-# LANGUAGE DeriveDataTypeable #-} import Test.Feat.Enumerate -import Test.Feat.Class +import Control.Enumerable import Test.Feat.Access import Test.Feat data Term scope = Lam (Term (FinS scope)) | App (Term scope) (Term scope) - | Var scope + | Var scope deriving (Show, Typeable) instance Enumerable a => Enumerable (Term a) where - enumerate = unary Var -- Variables are size 0, add pay to make size 1 - <> irregular (pay (unary Lam)) -- "Irregular constructor" - <> pay (unary (funcurry App)) + enumerate = datatype [ c1 Var -- Variables are size 0, add pay to make size 1 + , pay (c1 Lam) -- "Irregular constructor" + , pay (c2 App)] -- Finite numeric types data FinZ deriving Typeable instance Show FinZ where show _ = undefined instance Enumerable FinZ where - enumerate = mempty + enumerate = datatype [] data FinS n = Z | S n deriving (Typeable, Show) instance Enumerable n => Enumerable (FinS n) where - enumerate = pure Z <> fmap S shared + enumerate = datatype [c0 Z, c1 S] -- All closed lambda expressions -closed = optimal :: Enumerate (Term FinZ) +closed = global :: Enumerate (Term FinZ) vs = valuesWith closed -- Count the number of terms of a given size @@ -34,4 +34,3 @@ -- Select any term of a given size selectTerm = selectWith closed - diff --git a/examples/template-haskell/th.hs b/examples/template-haskell/th.hs --- a/examples/template-haskell/th.hs +++ b/examples/template-haskell/th.hs @@ -1,25 +1,26 @@ -{-#LANGUAGE MagicHash, TemplateHaskell, DeriveDataTypeable, StandaloneDeriving, GeneralizedNewtypeDeriving #-} +-- This is tested with haskell-src-exts-1.19.1 +{-#LANGUAGE MagicHash, TemplateHaskell, DeriveDataTypeable, StandaloneDeriving, GeneralizedNewtypeDeriving #-} -- BangPatterns, ScopedTypeVariables, ViewPatterns, KindSignatures import Language.Haskell.TH.Syntax - ( Exp(..), Pat(..), Stmt(..), Type(..), Dec(..), - Range(..), Lit(..), Kind(..), - Body(..), Guard(..), Con(..), Match(..), - Name(..), mkName, NameFlavour(..), NameSpace(..), - Clause(..), Pragma(..), FamFlavour(..), - Pred(..), TyVarBndr(..), - Foreign, Callconv(..), FunDep(..), - Safety(..), Strict(..), InlineSpec(..)) + ( Exp(..), Pat(..), Stmt(..), Type(..), Dec(..), + Range(..), Lit(..), Kind(..), + Body(..), Guard(..), Con(..), Match(..), + Name(..), mkName, NameFlavour(..), NameSpace(..), + Clause(..), Pragma(..), FamFlavour(..), + Pred(..), TyVarBndr(..), + Foreign, Callconv(..), FunDep(..), + Safety(..), Strict(..), OccName(..), ModName(..)) -- testing-feat import Test.Feat -import Test.Feat.Access import Test.Feat.Modifiers +import Control.Enumerable -- template-haskell -import Language.Haskell.TH.Syntax.Internals(OccName(OccName), ModName(ModName), PkgName) +-- import Language.Haskell.TH.Syntax.Internals(OccName(OccName), ModName(ModName), PkgName) import Language.Haskell.TH.Ppr(pprint,Ppr) -- haskell-src-meta -import Language.Haskell.Meta(toExp) +-- import Language.Haskell.Meta(toExp) -- haskell-src-exts import qualified Language.Haskell.Exts as E -- quickcheck @@ -29,15 +30,51 @@ import Data.Ord import Data.List -- smallcheck -import Test.SmallCheck.Series hiding (Nat) -import Test.SmallCheck +-- import Test.SmallCheck.Series hiding (Nat) +-- import Test.SmallCheck + + +main = testOptions defOptions{oMaxCounter=Just 10} prop_parses + +type Ex = (E.Exp E.SrcSpanInfo) + + +-- Haskell parser +myParse :: String -> E.ParseResult Ex +myParse = E.parseWithMode E.defaultParseMode{E.extensions = + (map E.EnableExtension [E.ExplicitForAll, E.ConstraintKinds]) +{- [ E.BangPatterns + , E.ScopedTypeVariables + , E.ViewPatterns + , E.KindSignatures + , E.ExplicitForAll + , E.TypeFamilies + ]-} + } + +-- | Newtype to make error reporting look nicer +newtype PPR a = PPR a + +instance (Show a, Ppr a) => Show (PPR a) where + show (PPR a) = show a ++ "\n" ++ pprint a ++ "\n" ++errormsg a where + errormsg x = case myParse (pprint x) of + E.ParseFailed _ s -> s + E.ParseOk _ -> "OK" +instance Enumerable a => Enumerable (PPR a) where + enumerate = share (c1 PPR) + +-- | Every pretty-printer result should be par +prop_parses (PPR e) = case myParse $ pprint (e :: Exp) of + E.ParseOk _ -> True + E.ParseFailed _ s -> False + {- -- Currently both of these spit out a lot of errors unless we disable a few of the -- buggier constructors (which we have done below). test_parsesAll = ioAll 15 report_parses --- | Test (at most) 10000 values of each size up to size 100. +-- | Test (at most) 10000 values of each size up to size 100. test_parsesBounded = ioBounded 10000 100 report_parses test_parsesBounded' = ioFeat (boundedWith enumerate 1000) report_parses @@ -76,35 +113,10 @@ --- Haskell parser -myParse :: String -> E.ParseResult E.Exp -myParse = E.parseWithMode E.defaultParseMode{E.extensions = - [ E.BangPatterns - , E.ScopedTypeVariables - , E.ViewPatterns - , E.KindSignatures - , E.ExplicitForAll - , E.TypeFamilies - ]} --} - --- We define both SmallCheck and Feat enumerators for comparison. -c1 :: (Serial a, Enumerable a) => (a -> b) -> (Enumerate b, Series b) -c1 f = (unary f,cons1 f) -c0 f = (nullary f, cons0 f) - -instance (Serial a, Serial b) => Serial (FreePair a b) where - series = map Free . (series >< series) - coseries = undefined - -toSel :: [(Enumerate b, Series b)] -> Enumerate b -toSel xs = consts $ map fst xs - -toSerial :: [(Enumerate b, Series b)] -> Series b -toSerial xs = foldl1 (\/) $ map snd xs +-} @@ -121,340 +133,237 @@ newtype BindN = BindN Name deriving Typeable -instance (Enumerable a, Serial a) => Serial (NonEmpty a) where - series = toSerial [c1 $ NonEmpty . funcurry (:)] - coseries = undefined - -instance (Serial a, Infinite a) => Serial (Nat a) where - series = map (\(N a) -> Nat a) . series - coseries = undefined - - newtype CPair a b = CPair {cPair :: (a,b)} deriving Typeable -instance (Enumerable a, Serial a,Enumerable b, Serial b) => Serial (CPair a b) where - series = toSerial [c1 $ CPair . funcurry (,)] - coseries = undefined -instance (Serial a,Enumerable a,Enumerable b, Serial b) => Enumerable (CPair a b) where - enumerate = toSel [c1 $ CPair . funcurry (,)] +instance (Enumerable a,Enumerable b) => Enumerable (CPair a b) where + enumerate = datatype [c1 CPair] -cExp = - [c1 $ VarE . lcased - ,c1 $ ConE . ucased - ,c1 LitE - ,c1 $ funcurry AppE - ,c1 $ \(ExpStmt a,o) -> InfixE (Just a) (either ConE VarE o) Nothing - ,c1 $ \(ExpStmt a,o) -> InfixE Nothing (either ConE VarE o) (Just a) - ,c1 $ \(a,o,b) -> InfixE (Just a) (either ConE VarE o) (Just b) --- ,c1 $ funcurry $ funcurry $ \a o b -> UInfixE a (VarE o) b --- ,c1 $ funcurry $ funcurry $ \a o b -> UInfixE a (ConE o) b --- ,c1 ParensE - ,c1 $ funcurry $ LamE . nonEmpty - ,c1 $ \(x1,x2,xs) -> TupE (x1:x2:xs) --- ,c1 UnboxedTupE - ,c1 $ funcurry $ funcurry CondE - ,c1 $ \(d,ds,e) -> LetE (map unWhere $ d:ds) e -- DISABLED BUGGY EMPTY LETS - ,c1 $ \(e,NonEmpty m) -> CaseE e m - ,c1 $ \(e,ss) -> DoE (ss ++ [NoBindS e]) - ,c1 $ (\((p,e),(CPair (xs,e'))) -> CompE ([BindS p e] ++ xs ++ [NoBindS e'])) --- ,c1 ArithSeqE -- BUGGY! - ,c1 ListE --- ,c1 $ funcurry SigE -- BUGGY! - ,c1 $ \(e,x) -> RecConE e $ map unCase (nonEmpty x) - ,c1 $ \(e,fe) -> RecUpdE e $ map unCase (nonEmpty fe) - ] instance Enumerable Exp where - enumerate = toSel cExp -instance Serial Exp where - series = toSerial cExp - coseries = undefined + enumerate = datatype + [c1 $ VarE . lcased + ,c1 $ ConE . ucased + ,c1 LitE + ,c2 AppE + ,c1 $ \(ExpStmt a,o) -> InfixE (Just a) (either ConE VarE o) Nothing + ,c1 $ \(ExpStmt a,o) -> InfixE Nothing (either ConE VarE o) (Just a) + ,c1 $ \(a,o,b) -> InfixE (Just a) (either ConE VarE o) (Just b) + -- ,c3 $ \a o b -> UInfixE a (VarE o) b + -- ,c3 $ \a o b -> UInfixE a (ConE o) b + -- ,c1 ParensE + ,c2 $ LamE . nonEmpty + ,c1 $ \(x1,x2,xs) -> TupE (x1:x2:xs) + -- ,c1 UnboxedTupE + ,c3 CondE + ,c1 $ \(d,ds,e) -> LetE (map unWhere $ d:ds) e -- DISABLED BUGGY EMPTY LETS + ,c1 $ \(e,NonEmpty m) -> CaseE e m + ,c1 $ \(ExpStmt e,ss) -> DoE (ss ++ [NoBindS e]) + ,c1 $ (\((p,e),(CPair (xs,e'))) -> CompE ([BindS p e] ++ xs ++ [NoBindS e'])) + -- ,c1 ArithSeqE -- BUGGY! + ,c1 ListE + -- ,c2 SigE -- BUGGY! + ,c1 $ \(e,x) -> RecConE e $ map unCase (nonEmpty x) + ,c1 $ \(e,fe) -> RecUpdE e $ map unCase (nonEmpty fe) + ] unCase (LcaseN n,e) = (n,e) -cExpStmt = - [ c1 $ ExpStmt . VarE - , c1 $ ExpStmt . ConE - , c1 $ ExpStmt . LitE - , c1 $ \(e1,e2) -> ExpStmt (AppE e1 e2) - , c1 $ ExpStmt . LitE - -- , c1 parS - -- Removed paralell comprehensions - ] instance Enumerable ExpStmt where - enumerate = toSel cExpStmt -instance Serial ExpStmt where - series = toSerial cExpStmt - coseries = undefined - -cPat = - [ c1 LitP - , c1 $ \(BindN n) -> VarP n - , c1 TupP - , c1 $ \(UpcaseName n,ps) -> ConP n ps - , c1 $ \(p1,UpcaseName n,p2) -> InfixP p1 n p2 - , c1 TildeP --- , c1 $ \(LcaseN n) -> BangP $ VarP n - , c1 $ \(BindN n,p) -> AsP n p - , c0 WildP - , c1 $ \(UpcaseName e,x) -> RecP e (map (\(BindN n, p) -> (n,p)) (nonEmpty x)) - , c1 ListP --- , c1 $ funcurry SigP -- BUGGY! --- , c1 $ funcurry ViewP -- BUGGY! - ] -instance Enumerable Pat where - enumerate = toSel cPat -instance Serial Pat where - series = toSerial cPat - coseries = undefined + enumerate = datatype + [ c1 $ ExpStmt . VarE + , c1 $ ExpStmt . ConE + -- , c1 $ ExpStmt . LitE + , c1 $ \(e1,e2) -> ExpStmt (AppE e1 e2) + -- , c1 $ ExpStmt . LitE + -- , c1 parS + -- Removed paralell comprehensions + ] +instance Enumerable Pat where + enumerate = datatype + [ c1 LitP + , c1 $ \(BindN n) -> VarP n + , c1 TupP + , c1 $ \(UpcaseName n,ps) -> ConP n ps + , c1 $ \(p1,UpcaseName n,p2) -> InfixP p1 n p2 + , c1 TildeP + -- , c1 $ \(LcaseN n) -> BangP $ VarP n + , c1 $ \(BindN n,p) -> AsP n p + , c0 WildP + , c1 $ \(UpcaseName e,x) -> RecP e (map (\(BindN n, p) -> (n,p)) (nonEmpty x)) + , c1 ListP + -- , c2 SigP -- BUGGY! + -- , c2 ViewP -- BUGGY! + ] + -- deriveEnumerable ''Match -- Should remove decs -cMatch = - [c1 $ funcurry $ funcurry $ \x y ds -> Match x y (map unWhere ds) - ] instance Enumerable Match where - enumerate = toSel cMatch -instance Serial Match where - series = toSerial cMatch - coseries = undefined - -cStmt = - [ c1 $ funcurry BindS - , c1 $ \(d) -> LetS $ map unWhere $ nonEmpty d - , c1 $ NoBindS - -- , c1 parS - -- Removed paralell comprehensions - ] + enumerate = datatype + [c3 $ \x y ds -> Match x y (map unWhere ds) + ] + instance Enumerable Stmt where - enumerate = toSel cStmt -instance Serial Stmt where - series = toSerial cStmt - coseries = undefined + enumerate = datatype + [ c2 BindS + , c1 $ \(d) -> LetS $ map unWhere $ nonEmpty d + , c1 $ NoBindS + -- , c1 parS + -- Removed paralell comprehensions + ] -cName = [ c1 (funcurry Name) ] + instance Enumerable Name where - enumerate = toSel cName -instance Serial Name where - series = toSerial cName - coseries = undefined + enumerate = datatype [ c2 Name ] -cType = - [c1 $ funcurry $ funcurry $ (\(x) -> ForallT (nonEmpty x)) - ,c1 $ \(BindN a) -> VarT a - ,c1 $ \(UpcaseName a) -> ConT a - ,c1 $ \n -> TupleT (abs n) - ,c0 ArrowT - ,c0 ListT - ,c1 $ funcurry AppT - -- ,c1 $ funcurry SigT -- BUGGY! - ] + + instance Enumerable Type where - enumerate = toSel cType -instance Serial Type where - series = toSerial cType - coseries = undefined + enumerate = datatype cType where + cType = + [c3 $ (\(x) -> ForallT (map (PlainTV . lcased) $ nonEmpty x)) + ,c1 $ \(BindN a) -> VarT a + ,c1 $ \(UpcaseName a) -> ConT a + ,c1 $ \n -> TupleT (abs n) + ,c0 ArrowT + ,c0 ListT + ,c2 AppT + -- ,c2 SigT -- BUGGY! + ] + -- deriveEnumerable ''Dec -cWhereDec = - [ c1 $ \(n,c) -> WhereDec $ FunD n (nonEmpty c) - , c1 $ \(n,p,wds) -> WhereDec $ ValD n p (map unWhere wds) - , c1 $ \(BindN a,b) -> WhereDec $ SigD a b - -- , c1 $ WhereDec . PragmaD -- Removed pragmas - -- , c1 parS -- Removed paralell comprehensions - ] instance Enumerable WhereDec where - enumerate = toSel cWhereDec -instance Serial WhereDec where - series = toSerial cWhereDec - coseries = undefined + enumerate = datatype + [ c1 $ \(n,c) -> WhereDec $ FunD n (nonEmpty c) + , c1 $ \(n,p,wds) -> WhereDec $ ValD n p (map unWhere wds) + , c1 $ \(BindN a,b) -> WhereDec $ SigD a b + -- , c1 $ WhereDec . PragmaD -- Removed pragmas + -- , c1 parS -- Removed paralell comprehensions + ] - -cLit = - [ c1 StringL - , c1 CharL -- TODO: Fair char generation - , c1 $ IntegerL . nat - -- , c1 RationalL -- BUGGY! - -- Removed primitive litterals - ] -instance Enumerable Lit where - enumerate = toSel cLit -instance Serial Lit where - series = toSerial cLit - coseries = undefined -cClause = - [c1 $ funcurry (funcurry $ \ps bs ds -> Clause ps bs (map unWhere ds))] +instance Enumerable Lit where + enumerate = datatype + [ c1 StringL + , c1 CharL -- TODO: Fair char generation + , c1 $ IntegerL . nat + -- , c1 RationalL -- BUGGY! + -- Removed primitive litterals + ] + instance Enumerable Clause where - enumerate = toSel cClause -instance Serial Clause where - series = toSerial cClause - coseries = undefined + enumerate = datatype + [c3 $ \ps bs ds -> Clause ps bs (map unWhere ds)] -- deriveEnumerable ''Pred -cPred = - [ c1 $ funcurry ClassP - , c1 $ funcurry EqualP - ] -instance Enumerable Pred where - enumerate = toSel cPred -instance Serial Pred where - series = toSerial cPred - coseries = undefined +--cPred = +-- [ c2 ClassP +-- , c2 EqualP +-- ] +--instance Enumerable Pred where +-- enumerate = datatype cPred + -- deriveEnumerable ''TyVarBndr -cTyVarBndr = - [ c1 $ PlainTV - , c1 $ funcurry KindedTV - ] instance Enumerable TyVarBndr where - enumerate = toSel cTyVarBndr -instance Serial TyVarBndr where - series = toSerial cTyVarBndr - coseries = undefined + enumerate = datatype + [ c1 PlainTV + , c2 KindedTV + ] -cKind = - [c0 StarK - ,c1 (funcurry ArrowK) - ] -instance Enumerable Kind where - enumerate = toSel cKind -instance Serial Kind where - series = toSerial cKind - coseries = undefined +--cKind = +-- [c0 StarK +-- ,c2 ArrowK +-- ] +--instance Enumerable Kind where +-- enumerate = datatype cKind -cBody = - [ c1 NormalB - , c1 $ \(x) -> GuardedB (nonEmpty x) - -- Removed primitive litterals - ] instance Enumerable Body where - enumerate = toSel cBody -instance Serial Body where - series = toSerial cBody - coseries = undefined - -cGuard = - [c1 $ NormalG - ,c1 $ \(s) -> PatG (nonEmpty s) - ] -instance Enumerable Guard where - enumerate = toSel cGuard -instance Serial Guard where - series = toSerial cGuard - coseries = undefined + enumerate = datatype + [ c1 NormalB + , c1 $ \(x) -> GuardedB (nonEmpty x) + -- Removed primitive litterals + ] +instance Enumerable Guard where + enumerate = datatype + [c1 $ NormalG + ,c1 $ \(s) -> PatG (nonEmpty s) + ] -cCallconv = [c0 CCall, c0 StdCall] instance Enumerable Callconv where - enumerate = toSel cCallconv -instance Serial Callconv where - series = toSerial cCallconv - coseries = undefined + enumerate = datatype [c0 CCall, c0 StdCall] -cSafety = [c0 Unsafe, c0 Safe, c0 Interruptible] + + instance Enumerable Safety where - enumerate = toSel cSafety -instance Serial Safety where - series = toSerial cSafety - coseries = undefined - + enumerate = datatype + [c0 Unsafe, c0 Safe, c0 Interruptible] -cStrict = [c0 IsStrict, c0 NotStrict, c0 Unpacked] -instance Enumerable Strict where - enumerate = toSel cStrict -instance Serial Strict where - series = toSerial cStrict - coseries = undefined -cInlineSpec = [c1 (funcurry $ funcurry $ InlineSpec)] -instance Enumerable InlineSpec where - enumerate = toSel cInlineSpec -instance Serial InlineSpec where - series = toSerial cInlineSpec - coseries = undefined +--cStrict = [c0 IsStrict, c0 NotStrict, c0 Unpacked] +--instance Enumerable Strict where +-- enumerate = datatype cStrict -cOccName = +--cInlineSpec = [c3 $ InlineSpec)] +--instance Enumerable InlineSpec where +-- enumerate = datatype cInlineSpec + +instance Enumerable OccName where + enumerate = datatype [ c0 $ OccName "Con" , c0 $ OccName "var" ] -instance Enumerable OccName where - enumerate = toSel cOccName -instance Serial OccName where - series = toSerial cOccName - coseries = undefined -cBindN = [c0 $ BindN $ Name (OccName "var") NameS] instance Enumerable BindN where - enumerate = toSel cBindN -instance Serial BindN where - series = toSerial cBindN - coseries = undefined - -cLcaseN = [c1 $ \nf -> LcaseN $ Name (OccName "var") nf] + enumerate = datatype + [c0 $ BindN $ Name (OccName "var") NameS] + instance Enumerable LcaseN where - enumerate = toSel cLcaseN -instance Serial LcaseN where - series = toSerial cLcaseN - coseries = undefined - -cUpcaseName = [c1 $ \nf -> UpcaseName $ Name (OccName "Con") nf] -instance Serial UpcaseName where - series = toSerial cUpcaseName - coseries = undefined + enumerate = datatype + [c1 $ \nf -> LcaseN $ Name (OccName "var") nf] + instance Enumerable UpcaseName where - enumerate = toSel cUpcaseName - -cModName = [c0 $ ModName "M", c0 $ ModName "C.M"] + enumerate = datatype + [c1 $ \nf -> UpcaseName $ Name (OccName "Con") nf] + instance Enumerable ModName where - enumerate = toSel cModName -instance Serial ModName where - series = toSerial cModName - coseries = undefined - + enumerate = datatype + [c0 $ ModName "M", c0 $ ModName "C.M"] -cRange = - [ c1 FromR - , c1 (funcurry FromThenR) - , c1 (funcurry FromToR) - , c1 (funcurry $ funcurry FromThenToR) - ] instance Enumerable Range where - enumerate = toSel cRange -instance Serial Range where - series = toSerial cRange - coseries = undefined + enumerate = datatype + [ c1 FromR + , c2 FromThenR + , c2 FromToR + , c3 FromThenToR + ] -cNameFlavour = ( - [ c1 NameQ --- , funcurry $ funcurry NameG + +instance Enumerable NameFlavour where + enumerate = datatype + [c1 NameQ +-- , c3 NameG -- , \(I# x) -> NameU x -- , \(I# x) -> NameL x - , c0 NameS - ]) -instance Enumerable NameFlavour where - enumerate = toSel cNameFlavour -instance Serial NameFlavour where - series = toSerial cNameFlavour - coseries = undefined + , c0 NameS + ] -- main = test_parsesBounded -- or test_parsesAll, but that takes much longer to find bugs - -eExp :: Enumerate Exp -eExp = toSel cExp diff --git a/testing-feat.cabal b/testing-feat.cabal --- a/testing-feat.cabal +++ b/testing-feat.cabal @@ -1,5 +1,5 @@ Name: testing-feat -Version: 0.4.0.3 +Version: 1.0.0.0 Synopsis: Functional Enumeration of Algebraic Types Description: Feat (Functional Enumeration of Algebraic Types) provides enumerations as functions from natural numbers to values @@ -13,46 +13,43 @@ "Test.Feat" contain a subset of the other modules that should be sufficient for most test usage. There are some small and large example in the tar - ball. Builds with haskell-platform-2012-2.0.0 and with ghc-7.6.1. + ball. + . + The generators are provided by the size-based package. This means other libraries that implement the Sized class can use the same generator definitions. One such is the + , that uses laziness to search for values and test properties. This is typically a lot faster than Feat for properties that have preconditions (logical implication), but can not be used for random selection of values. License: BSD3 License-file: LICENSE Author: Jonas Duregård Maintainer: jonas.duregard@gmail.com +Homepage: https://github.com/JonasDuregard/testing-feat Copyright: Jonas Duregård Category: Testing Build-type: Simple - Extra-source-files: examples/template-haskell/th.hs examples/haskell-src-exts/hse.hs examples/lambda-terms/lambdas.hs - Cabal-version: >=1.6 - source-repository head type: git - location: git://github.com/JonasDuregard/testing-feat.git - + location: https://github.com/JonasDuregard/testing-feat Library + Hs-source-dirs: . Exposed-modules: Test.Feat, - Test.Feat.Access, - Test.Feat.Class, - Test.Feat.Class.Override, + Test.Feat.Finite, Test.Feat.Enumerate, - Test.Feat.Modifiers + Test.Feat.Access + Test.Feat.Driver + -- Compatibility + Test.Feat.Modifiers + Test.Feat.Class - Build-depends: - base >= 4.5 && <= 4.10, - template-haskell >= 2.5 && < 2.12, - mtl >= 1 && < 3, + Build-depends: + base >= 4.5 && < 5, QuickCheck > 2 && < 3, - tagshare<0.1 - - Other-modules: - Test.Feat.Internals.Derive - Test.Feat.Internals.Tag - Test.Feat.Internals.Newtypes + size-based < 0.2, + testing-type-modifiers < 0.2