testing-feat 0.4.0.3 → 1.0.0.0
raw patch · 17 files changed
+776/−1293 lines, 17 filesdep +size-baseddep +testing-type-modifiersdep −mtldep −tagsharedep −template-haskelldep ~basesetup-changed
Dependencies added: size-based, testing-type-modifiers
Dependencies removed: mtl, tagshare, template-haskell
Dependency ranges changed: base
Files
- LICENSE +2/−2
- Setup.lhs +0/−0
- Test/Feat.hs +22/−17
- Test/Feat/Access.hs +81/−149
- Test/Feat/Class.hs +32/−358
- Test/Feat/Class/Override.hs +0/−44
- Test/Feat/Driver.hs +133/−0
- Test/Feat/Enumerate.hs +47/−150
- Test/Feat/Finite.hs +68/−0
- Test/Feat/Internals/Derive.hs +0/−54
- Test/Feat/Internals/Newtypes.hs +0/−22
- Test/Feat/Internals/Tag.hs +0/−5
- Test/Feat/Modifiers.hs +26/−97
- examples/haskell-src-exts/hse.hs +123/−58
- examples/lambda-terms/lambdas.hs +8/−9
- examples/template-haskell/th.hs +216/−307
- testing-feat.cabal +18/−21
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2011, Jonas Duregrd+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 Duregrd 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.
Setup.lhs view
Test/Feat.hs view
@@ -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
Test/Feat/Access.hs view
@@ -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++
Test/Feat/Class.hs view
@@ -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
− Test/Feat/Class/Override.hs
@@ -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) --
+ Test/Feat/Driver.hs view
@@ -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+
Test/Feat/Enumerate.hs view
@@ -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--
+ Test/Feat/Finite.hs view
@@ -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) +
− Test/Feat/Internals/Derive.hs
@@ -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..])
− Test/Feat/Internals/Newtypes.hs
@@ -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)
− Test/Feat/Internals/Tag.hs
@@ -1,5 +0,0 @@-module Test.Feat.Internals.Tag where--data Tag = Class - | Source String String Int Int- deriving (Show,Eq,Ord)
Test/Feat/Modifiers.hs view
@@ -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
examples/haskell-src-exts/hse.hs view
@@ -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)]
examples/lambda-terms/lambdas.hs view
@@ -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-
examples/template-haskell/th.hs view
@@ -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
testing-feat.cabal view
@@ -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+ <https://hackage.haskell.org/package/lazy-search lazy-search package>, 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