packages feed

testing-feat 0.1 → 0.2

raw patch · 12 files changed

+890/−546 lines, 12 files

Files

Test/Feat.hs view
@@ -1,6 +1,8 @@+-- | 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(..),-  -- ** The type class+  -- * The type class   Enumerable(..),   nullary,   unary,@@ -8,12 +10,13 @@   consts,   deriveEnumerable,   FreePair(..),-  -- ** Accessing data+  -- * Accessing data   optimised,   index,   values,   bounded,   uniform,+  ioFeat,   ioAll,   ioBounded     ) where
Test/Feat/Access.hs view
@@ -1,5 +1,5 @@ -- | Functions for accessing the values of enumerations including --- compatability with the property based testing frameworks QuickCheck and+-- compatibility with the property based testing frameworks QuickCheck and -- SmallCheck. module Test.Feat.Access(   -- ** Accessing functions@@ -13,7 +13,7 @@   ioAll,   ioBounded,   -  -- ** Compatability+  -- ** Compatibility   -- *** QuickCheck   uniform,   -- *** SmallCheck@@ -47,12 +47,12 @@      else go (i-crd) (p+1)  -- | Mainly as a proof of concept we can use the isomorphism between --- natural numbers and (Part,Index) pairs to index into a type+-- natural numbers and @(Part,Index)@ pairs to index into a type. -- May not terminate for finite types. -- Might be slow the first time it is used with a specific enumeration  -- because cardinalities need to be calculated.--- The computation complexity after cardinalities are computed is a polynomial--- of the size of the resulting value.+-- The computational complexity (after cardinalities are computed) is a polynomial+-- in the size of the resulting value. index :: Enumerate a -> Integer -> a  index e = uncurry (select e) . split e @@ -74,34 +74,34 @@ bounded = boundedWith optimised  -- | A rather simple but general property testing driver.--- The property is a (funcurried) IO function that both tests and reports the +-- 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 the coverage and the number of -- tests before each new part. ioFeat :: [(Integer,[a])] -> (a -> IO ()) -> IO ()-ioFeat vs f = go vs 0 where-  go ((c,xs):xss) s = do-    putStrLn $ "--- Testing "++show c++" vales at size " ++ show s+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)-  go []           s = putStrLn $ "--- Done. Tested "++ show s++" values"+    go xss (s+1) (tot + c)+  go []           s tot = putStrLn $ "--- Done. Tested "++ show tot++" values" --- | ioAll = 'ioFeat' values+-- | Defined as @ioAll = 'ioFeat' 'values' @ ioAll :: Enumerable a => (a -> IO ()) -> IO () ioAll = ioFeat values --- | ioBounded @n = 'ioFeat' (bounded n)@+-- | Defined as @ioBounded n = 'ioFeat' ('bounded' n)@ ioBounded :: Enumerable a => Integer -> (a -> IO ()) -> IO () ioBounded n = ioFeat (bounded n)   --- | Compatability 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 optimised --- | Compatability with SmallCheck. +-- | Compatibility with SmallCheck.  toSeries :: Enumerable a => Int -> [a]  toSeries = toSeriesWith optimised
Test/Feat/Class.hs view
@@ -30,21 +30,25 @@   FreePair(..),      -  -- ** Deriving instances with template haskell+  -- ** 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@@ -52,6 +56,7 @@ import Data.Word import Data.Int import Data.Bits+import Data.Ratio  -- | A class of functionally enumerable types class Typeable a => Enumerable a where@@ -61,7 +66,7 @@   enumerate  :: Enumerate a      -- | Version of enumerate that ensures it is shared between-  -- all accessing functions. Should alwasy be used when +  -- all accessing functions. Should always be used when    -- combining enumerations.   -- Should typically be left to default behaviour.   shared     :: Enumerate a@@ -112,30 +117,53 @@  -- | Derive an instance of Enumberable with Template Haskell. deriveEnumerable :: Name -> Q [Dec]-deriveEnumerable = fmap return . instanceFor ''Enumerable [enumDef]+deriveEnumerable = deriveEnumerable' . dAll+  -- fmap return . instanceFor ''Enumerable [enumDef] --- -- | Derive the enumeration of a single constructor. Useful --- if 'deriveEnumerable' does not work for all constructors. --- autoCon :: Name -> Q Exp--- autoCon = undefined+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) --- -- | Splices a list of automatically derived constructors.--- autoCons :: [Name] -> Q Exp--- autoCons = listE . map autoCon+-- | 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+        +-- do+--          (_,ns,_) <- extractData n+--          if all (map snd nse) (`elem` ns) +--            then return () +--            else error $ "Invalid constructors for "++show n++": "+++--                        show (filter (`notElem` ns) (map fst nse))  -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) []     ++ --------------------------------------------------------------------- -- Instances @@ -156,8 +184,8 @@     , ''Ordering     ]   -- Circumventing the stage restrictions by means of code repetition.-  enumDef :: [(Name,[Type])] -> [Q Dec]-  enumDef cons = [fmap mk_freqs_binding [|consts $ex |]] where+  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) = @@ -170,8 +198,7 @@  -- This instance is quite important. It needs to be exponential for  -- the other instances to work.-newtype Natural = Natural {natural :: Integer} deriving (Typeable, Show)-instance Enumerable Natural where +instance Infinite a => Enumerable (Nat a) where    enumerate = let e = Enumerate{     card = crd,     select = sel,@@ -180,20 +207,24 @@         | p <= 0     = 0         | p == 1     = 1         | otherwise  = 2^(p-2)-      sel 1 0 = Natural 0-      sel p i = Natural $ 2^(p-2) + i+      sel :: Num a => Part -> 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,Natural i)) = if b then -i-1 else i-           +    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 . natural)+  e = cutOff (bitSize' e+1) $ unary (fromInteger . nat)    int :: (Bits a, Integral a) => Enumerate a  int = e where@@ -240,7 +271,15 @@ instance Enumerable Float where   enumerate = unary (funcurry encodeFloat) +-- This should be fixed with a bijective funtion.+-- | 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) ++  +
+ Test/Feat/Class/Override.hs view
@@ -0,0 +1,43 @@+-- | 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) as long as the instance does +-- not override the default definition of 'shared' so it does not use +-- 'tagShare' (no instance in the library does this).This function should not +-- be used for defining instances (doing so might increase memory usage).+override :: Enumerable a => Override -> Enumerate a+override = evalState (optimal shared) ++
Test/Feat/Enumerate.hs view
@@ -1,6 +1,6 @@ {-#LANGUAGE DeriveDataTypeable, TemplateHaskell #-} --- | Basic combinators fo building enumerations+-- | Basic combinators for building enumerations -- most users will want to use the type class  -- based combinators in "Test.Feat.Class" instead.  @@ -11,8 +11,10 @@   Enumerate(..),      -- ** Combinators for building enumerations-  module Control.Applicative,   module Data.Monoid,+  union,+  module Control.Applicative,+  singleton,   pay,      -- ** Memoisation@@ -44,8 +46,8 @@ type Part = Int type Index = Integer --- | A functional enumeration of type t is a partition of--- t into finite numbered sets called Parts. The number that+-- | A functional enumeration of type @t@ is a partition of+-- @t@ into finite numbered sets called Parts. The number that -- identifies each part is called the cost of the values in  -- that part. data Enumerate a = Enumerate@@ -53,9 +55,9 @@    -- | Computes the cardinality of a given part.    card      ::  Part -> Index,    -- | Selects a value from the enumeration-   -- For @select e p i@, @i@ should be less than @card e p@+   -- For @select e p i@, the index @i@ should be less than @card e p@    select    ::  Part -> Index -> a,-   -- | A self-optimising function. +   -- | A self-optimising function (mainly for internal use).     optimal   ::  Sharing Tag (Enumerate a)    } deriving Typeable      @@ -65,7 +67,7 @@     {select    = \p n -> f (select cf p n)     , optimal  = liftM (fmap f) (optimal cf) } --- | mappend = union+-- | The @'mappend'@ is (disjoint) @'union'@ instance Monoid (Enumerate a) where   mempty      = let e = Enumerate  (\p -> 0)                                     (\p i -> error "select: empty")@@ -77,7 +79,7 @@ union a b  =  infinite part (liftM2 union (optimal a) (optimal b)) where   part p   =  finUnion (finite a p) (finite b p) --- | <*> corresponds to product (as with lists)+-- | Pure is 'singleton' and '<*>' corresponds to cartesian product (as with lists) instance Applicative Enumerate where   pure     = singleton   f <*> a  = fmap (uncurry ($)) (cartesian f a)@@ -88,7 +90,7 @@   [finCart (finite a x) (finite b (p-x))| x <- [0..p]])     (liftM2 cartesian (optimal a) (optimal b)) --- | The definition of @pure@ for the applicaive instance. +-- | The definition of @pure@ for the applicative instance.  singleton :: a -> Enumerate a singleton a = let e = Enumerate car sel (return e) in e    where  car p    = if p == 0 then 1 else 0@@ -113,7 +115,7 @@     , optimal   = fmap mem (optimal sel)     } --- | A conventient combination of memoisation and guarded recursion.+-- | A convenient combination of memoisation and guarded recursion. mempay :: Enumerate a -> Enumerate a mempay = mem . pay            @@ -157,6 +159,4 @@   car = fCard f1 * fCard f2   sel i = let (q, r) = (i `quotRem` fCard f2)      in (fSelect f1 q, fSelect f2 r)---+
Test/Feat/Internals/Derive.hs view
@@ -3,7 +3,7 @@ import Language.Haskell.TH  -- General combinator for class derivation-instanceFor :: Name -> [[(Name,[Type])] -> [Q Dec]] -> Name -> Q Dec+instanceFor :: Name -> [[(Name,[Type])] -> Q Dec] -> Name -> Q Dec instanceFor clname confs dtname = do   (cxt,dtvs,cons) <- extractData dtname   cd              <- mapM conData cons@@ -12,7 +12,7 @@     mkTyp = mkInstanceType clname dtname dtvs     mkDecs conf = conf cd -  instanceD mkCxt mkTyp (concatMap mkDecs confs)+  instanceD mkCxt mkTyp (map mkDecs confs)   mkInstanceType :: Name -> Name -> [Name] -> Q Type
+ Test/Feat/Internals/Newtypes.hs view
@@ -0,0 +1,22 @@+{-#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/Modifiers.hs view
@@ -1,38 +1,50 @@ {-# LANGUAGE DeriveDataTypeable #-} --- | Types with invariants. Currently these are mostly examples of how to --- define such types, suggestions on useful types are appreciated.+-- | Modifiers for types, i.e. newtype wrappers where the values satisfy some +-- constraint (non-empty, positive etc.). Suggestions on useful types are +-- appreciated. ----- To use the invariant types you can use the record label. For instance:+-- 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)+--  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)+--  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 @.+-- 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 @@ -40,24 +52,45 @@ -- | A type of non empty lists. newtype NonEmpty a = NonEmpty {nonEmpty :: [a]}    deriving (Typeable, Show)-mkNonEmpty x xs = x:xs+mkNonEmpty :: (a,[a]) -> NonEmpty a+mkNonEmpty (x,xs) = NonEmpty $ x:xs instance Enumerable a => Enumerable (NonEmpty a) where-  enumerate = unary NonEmpty+  enumerate = unary $ mkNonEmpty --- Copy paste from Enumerate.hs--- | A type of natural numbers.-newtype Nat = Nat {nat :: Integer} ++enumerateBounded :: (Enum a) => Int -> Int -> Enumerate a+enumerateBounded from to = let e = Enumerate crd sel (return e) in e +  where+    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 = mempay $ 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 Nat where -  enumerate = let e = Enumerate{-    card = crd,-    select = sel,-    optimal = return e} in e where-      crd p-        | p <= 0     = 0-        | p == 1     = 1-        | otherwise  = 2^(p-2)-      sel 1 0 = Nat 0-      sel p i = Nat $ 2^(p-2) + i +instance Enumerable Printable where+  enumerate = mempay $ fmap Printable $ enumerateBounded 32 126 +-- | Smart constructor for printable ASCII strings+printables :: [Printable] -> String+printables = map printable+
− examples/TestTH.hs 
@@ -1,451 +0,0 @@-{-#LANGUAGE MagicHash, TemplateHaskell, DeriveDataTypeable, StandaloneDeriving, GeneralizedNewtypeDeriving #-} --- BangPatterns, ScopedTypeVariables, ViewPatterns, KindSignatures--module TestTH where --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(..))--- testing-feat-import Test.Feat-import Test.Feat.Access-import Test.Feat.Modifiers--- template-haskell-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)--- haskell-src-exts-import qualified Language.Haskell.Exts as E--- quickcheck-import Test.QuickCheck hiding (NonEmpty, (><))---base-import Data.Typeable(Typeable)-import Data.Ord-import Data.List--- smallcheck-import Test.SmallCheck.Series hiding (Nat)-import Test.SmallCheck---- Currently both of these spit out a lot of errors. Disabling a few of the--- buggier constructors might help.-test_parsesAll = ioAll report_parses-test_parsesBounded = ioBounded 10000 report_parses--report_parses e = case prop_parsesM e of-    Nothing -> return ()-    Just s  -> do-               putStrLn "Failure:"-               putStrLn (pprint e)-               print e-               putStrLn s-               putStrLn ""--prop_parsesM e = case myParse $ pprint (e :: Exp) :: E.ParseResult E.Exp of-  E.ParseOk _       -> Nothing-  E.ParseFailed _ s -> Just s---test_cycleAll = ioAll report_cycle-test_cycleBounded = ioBounded 10000 report_cycle-report_cycle e = case prop_cycle e of-    Nothing       -> return ()-    Just (ee,ex)  -> do-               putStrLn "Failure:"-               putStrLn (pprint ex)-               print ex-               putStrLn (E.prettyPrint  ee)-               putStrLn ""---- Round-trip property: TH -> String -> HSE -> TH--- Uses haskell-src-meta for HSE -> TH-prop_cycle :: Exp -> Maybe (E.Exp,Exp)-prop_cycle e = case myParse $ pprint (e :: Exp) :: E.ParseResult E.Exp of-  E.ParseOk hse       -> if e == toExp hse then Nothing else Just $ (hse, toExp hse)-  E.ParseFailed _ s   -> Nothing -- Parse failures do not count as errors!------ 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------ These statements are always expressions-newtype ExpStmt = ExpStmt Exp deriving Typeable---- Declarations allowed in where clauses-newtype WhereDec = WhereDec{unWhere :: Dec} deriving Typeable---- Lowecase names-newtype LcaseN = LcaseN {lcased :: Name} deriving Typeable--- Uppercase names-newtype UpcaseName = UpcaseName {ucased :: Name} deriving Typeable-newtype BindN = BindN Name deriving Typeable---instance (Enumerable a, Serial a) => Serial (NonEmpty a) where-  series = toSerial [c1 $ NonEmpty . funcurry (:)] -  coseries = undefined -  -instance Serial Nat 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 (,)] --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--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------ 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-  ]-instance Enumerable Stmt where- enumerate = toSel cStmt-instance Serial Stmt where-  series = toSerial cStmt-  coseries = undefined---cName = [ c1 (funcurry Name) ]-instance Enumerable Name where- enumerate = toSel cName-instance Serial Name where-  series = toSerial cName-  coseries = undefined--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----- 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---  -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 Clause where-  enumerate = toSel cClause-instance Serial Clause where-  series = toSerial cClause-  coseries = undefined-------- 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---- deriveEnumerable ''TyVarBndr-cTyVarBndr = -  [ c1 $ PlainTV-  , c1 $ funcurry KindedTV-  ]-instance Enumerable TyVarBndr where-  enumerate = toSel cTyVarBndr-instance Serial TyVarBndr where-  series = toSerial cTyVarBndr-  coseries = undefined---cKind = -  [c0 StarK-  ,c1 (funcurry ArrowK)-  ]-instance Enumerable Kind where-  enumerate = toSel cKind-instance Serial Kind where-  series = toSerial cKind-  coseries = undefined---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-  --cCallconv = [c0 CCall, c0 StdCall]-instance Enumerable Callconv where-  enumerate = toSel cCallconv-instance Serial Callconv where-  series = toSerial cCallconv-  coseries = undefined---cSafety = [c0 Unsafe, c0 Safe, c0 Interruptible]-instance Enumerable Safety where-  enumerate = toSel cSafety-instance Serial Safety where-  series = toSerial cSafety-  coseries = undefined-  --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--cOccName = -   [ 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]-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-instance Enumerable UpcaseName where-  enumerate = toSel cUpcaseName-  -cModName = [c0 $ ModName "M", c0 $ ModName "C.M"]-instance Enumerable ModName where-  enumerate = toSel cModName-instance Serial ModName where-  series = toSerial cModName-  coseries = undefined-   --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--cNameFlavour = (-  [ c1 NameQ---    , funcurry $ funcurry 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---- instance (Enumerable a, Integral a) => Enumerable (Ratio a) where---   enumerate = consts [c1 $ funcurry (:%)]--
+ examples/haskell-src-exts/hse.hs view
@@ -0,0 +1,202 @@+{-# Language TemplateHaskell #-}+import Test.Feat+import Test.Feat.Class+import Test.Feat.Modifiers++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: +--   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 +-- expression).+--+-- Catalogue and report all the bugs found.+++main = main_parse 100++run n = main_parse n+++-- 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())++rep_round :: (Eq a,Parseable a, Show a, Pretty a) => a -> IO ()+rep_round e = case myParse $ prettyPrint e of+  ParseOk e' -> if e == e' || prettyPrint e == prettyPrint e' then return () else do+    putStrLn $ "------ Error ------"+    putStrLn $ "e:          "++ (show  e)+    putStrLn $ "e(Pretty):  "++(prettyPrint e)+    putStrLn $ "e':         "++ (show  e')+    putStrLn $ "e'(Pretty): "++(prettyPrint e')+    putStrLn ""+  ParseFailed _ err -> return ()+  +++-- Everything produced by the pretty printer is parseable.+type TestParse = Module+main_parse n = ioFeat (take n values) (rep_parse :: TestParse -> IO())++rep_parse :: (Parseable a, Show a, Pretty a) => a -> IO ()+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 ""+++-- 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 +  (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 = knownExtensions +  }++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+    +  buggy3 = +    dExcluding 'XPcdata .+    dExcluding 'XExpTag .+    dExcluding 'XChildTag .+    dExcept 'XPcdata [| unary $ XPcdata . nonEmpty |] . dAll+  ++ in fmap concat $ mapM deriveEnumerable' [+  dAll ''Module,+--  dAll ''SrcLoc,+  dExcept 'LanguagePragma [|unary $ funcurry $ \x -> LanguagePragma x . nonEmpty|] +    $ dAll ''ModulePragma,+  dExcept 'WarnText [|unary $ WarnText . nonEmpty|]+    $ dExcept 'DeprText [|unary $ DeprText . nonEmpty|]  +    $ dAll ''WarningText,+  dAll ''ExportSpec,+  dAll ''ImportDecl,+  dAll ''Decl,+  dAll ''Tool,+  dAll ''QName,+  dAll ''ImportSpec,+  dAll ''Annotation,+  dAll ''Type,+  dAll ''Activation,+  dAll ''Rule,+  dAll ''CallConv,+  dAll ''Safety,+  buggy2 ''Pat,+  dAll ''Rhs,+  dAll ''Binds,+  dAll ''Match,+  buggy3 ''Exp,+  dAll ''Assoc,+  dAll ''Op,+  dAll ''Asst,+  dAll ''InstDecl,+  dAll ''TyVarBind,+  dAll ''FunDep,+  dAll ''ClassDecl,+  dAll ''DataOrNew,+  dAll ''Kind,+  dAll ''GadtDecl,+  dAll ''QualConDecl,+  buggy1 ''SpecialCon,+  dAll ''Boxed,+  dAll ''RuleVar,+  dAll ''XName,+  dAll ''PXAttr,+  dAll ''RPat,+  dAll ''PatField,+  dAll ''GuardedRhs,+  dAll ''IPBind,+  dAll ''XAttr,+  dAll ''Splice,+  dAll ''Bracket,+  dAll ''QualStmt,+  dAll ''FieldUpdate,+  dAll ''QOp,+  dAll ''Stmt,+  dAll ''Alt,+  dAll ''Literal,+  dAll ''IPName,+  dAll ''ConDecl,+  dAll ''RPatOp,+  dAll ''GuardedAlts,+  dAll ''BangType,+  dAll ''GuardedAlt+  ])++++instance Enumerable ModuleName where +  enumerate = consts +    [ nullary $ ModuleName "M"+    , nullary $ ModuleName "C.M"+    ]++-- 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 CName where+  enumerate = consts+    [ nullary $ VarName (Ident "v")+    , nullary $ ConName (Ident "C")+    ]++instance Enumerable SrcLoc where+  enumerate = consts+    [ nullary (SrcLoc "File.hs" 0 0)]+++++
+ examples/template-haskell/th.hs view
@@ -0,0 +1,450 @@+{-#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(..))+-- testing-feat+import Test.Feat+import Test.Feat.Access+import Test.Feat.Modifiers+-- template-haskell+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)+-- haskell-src-exts+import qualified Language.Haskell.Exts as E+-- quickcheck+import Test.QuickCheck hiding (NonEmpty, (><))+--base+import Data.Typeable(Typeable)+import Data.Ord+import Data.List+-- smallcheck+import Test.SmallCheck.Series hiding (Nat)+import Test.SmallCheck++-- Currently both of these spit out a lot of errors. Disabling a few of the+-- buggier constructors might help.+test_parsesAll = ioAll report_parses+test_parsesBounded = ioBounded 10000 report_parses++report_parses e = case prop_parsesM e of+    Nothing -> return ()+    Just s  -> do+               putStrLn "Failure:"+               putStrLn (pprint e)+               print e+               putStrLn s+               putStrLn ""++prop_parsesM e = case myParse $ pprint (e :: Exp) :: E.ParseResult E.Exp of+  E.ParseOk _       -> Nothing+  E.ParseFailed _ s -> Just s+++test_cycleAll = ioAll report_cycle+test_cycleBounded = ioBounded 10000 report_cycle+report_cycle e = case prop_cycle e of+    Nothing       -> return ()+    Just (ee,ex)  -> do+               putStrLn "Failure:"+               putStrLn (pprint ex)+               print ex+               putStrLn (E.prettyPrint  ee)+               putStrLn ""++-- Round-trip property: TH -> String -> HSE -> TH+-- Uses haskell-src-meta for HSE -> TH+prop_cycle :: Exp -> Maybe (E.Exp,Exp)+prop_cycle e = case myParse $ pprint (e :: Exp) :: E.ParseResult E.Exp of+  E.ParseOk hse       -> if e == toExp hse then Nothing else Just $ (hse, toExp hse)+  E.ParseFailed _ s   -> Nothing -- Parse failures do not count as errors!++++-- 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++++-- These statements are always expressions+newtype ExpStmt = ExpStmt Exp deriving Typeable++-- Declarations allowed in where clauses+newtype WhereDec = WhereDec{unWhere :: Dec} deriving Typeable++-- Lowecase names+newtype LcaseN = LcaseN {lcased :: Name} deriving Typeable+-- Uppercase names+newtype UpcaseName = UpcaseName {ucased :: Name} deriving Typeable+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 (,)] ++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++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++++-- 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+  ]+instance Enumerable Stmt where+ enumerate = toSel cStmt+instance Serial Stmt where+  series = toSerial cStmt+  coseries = undefined+++cName = [ c1 (funcurry Name) ]+instance Enumerable Name where+ enumerate = toSel cName+instance Serial Name where+  series = toSerial cName+  coseries = undefined++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+++-- 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+++  +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 Clause where+  enumerate = toSel cClause+instance Serial Clause where+  series = toSerial cClause+  coseries = undefined++++++-- 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++-- deriveEnumerable ''TyVarBndr+cTyVarBndr = +  [ c1 $ PlainTV+  , c1 $ funcurry KindedTV+  ]+instance Enumerable TyVarBndr where+  enumerate = toSel cTyVarBndr+instance Serial TyVarBndr where+  series = toSerial cTyVarBndr+  coseries = undefined+++cKind = +  [c0 StarK+  ,c1 (funcurry ArrowK)+  ]+instance Enumerable Kind where+  enumerate = toSel cKind+instance Serial Kind where+  series = toSerial cKind+  coseries = undefined+++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+  ++cCallconv = [c0 CCall, c0 StdCall]+instance Enumerable Callconv where+  enumerate = toSel cCallconv+instance Serial Callconv where+  series = toSerial cCallconv+  coseries = undefined+++cSafety = [c0 Unsafe, c0 Safe, c0 Interruptible]+instance Enumerable Safety where+  enumerate = toSel cSafety+instance Serial Safety where+  series = toSerial cSafety+  coseries = undefined+  ++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++cOccName = +   [ 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]+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+instance Enumerable UpcaseName where+  enumerate = toSel cUpcaseName+  +cModName = [c0 $ ModName "M", c0 $ ModName "C.M"]+instance Enumerable ModName where+  enumerate = toSel cModName+instance Serial ModName where+  series = toSerial cModName+  coseries = undefined+   ++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++cNameFlavour = (+  [ c1 NameQ+--    , funcurry $ funcurry 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++-- instance (Enumerable a, Integral a) => Enumerable (Ratio a) where+--   enumerate = consts [c1 $ funcurry (:%)]++
testing-feat.cabal view
@@ -1,5 +1,5 @@ Name:                testing-feat-Version:             0.1+Version:             0.2 Synopsis:            Functional enumeration for systematic and random testing Description:         Feat (Functional Enumeration of Abstract Types)                       provides an enumeration as a function from natural @@ -12,8 +12,9 @@                      class instance for most types.                      "Test.Feat" contain a subset of the other modules that                       should be sufficient for most test usage. There -                     is a large scale example in the tar ball (testing the -                     Template Haskell pretty printer).+                     are two (somewhat similar) large scale example in the tar +                     ball: testing the Template Haskell pretty printer and +                     testing haskell-src-exts.                                            License:             BSD3 License-file:        LICENSE@@ -24,7 +25,8 @@ Build-type:          Simple  Extra-source-files:  -    examples/TestTH.hs+    examples/template-haskell/th.hs+    examples/haskell-src-exts/hse.hs  Cabal-version:       >=1.2 @@ -34,6 +36,7 @@     Test.Feat,      Test.Feat.Access,     Test.Feat.Class,+    Test.Feat.Class.Override,     Test.Feat.Enumerate,     Test.Feat.Modifiers      Control.Monad.TagShare@@ -50,5 +53,5 @@   Other-modules:     Test.Feat.Internals.Derive     Test.Feat.Internals.Tag-    +    Test.Feat.Internals.Newtypes