packages feed

testing-feat (empty) → 0.1

raw patch · 12 files changed

+1304/−0 lines, 12 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, data-memocombinators, mtl, template-haskell

Files

+ Control/Monad/TagShare.hs view
@@ -0,0 +1,62 @@++-- | A monad for binding values to tags to ensure sharing, +-- with the added twist that the value can be polymorphic+-- and each monomorphic instance is bound separately.+module Control.Monad.TagShare(+  -- ** Dynamic map+  DynMap,+  dynEmpty,+  dynInsert,+  dynLookup,+  -- ** Sharing monad+  Sharing,+  runSharing,+  share+  ) where+import Control.Monad.State+import Data.Typeable+import Data.Dynamic(Dynamic, fromDynamic, toDyn)+import Data.Map as M++-- |  A dynamic map with type safe+-- insertion and lookup.+newtype DynMap tag = +  DynMap (M.Map (tag, TypeRep) Dynamic) +  deriving Show++dynEmpty :: DynMap tag+dynEmpty = DynMap M.empty  +  +dynInsert :: (Typeable a, Ord tag) => +                tag -> a -> DynMap tag -> DynMap tag+dynInsert u a (DynMap m) = +          DynMap (M.insert (u,typeOf a) (toDyn a) m)++dynLookup :: (Typeable a, Ord tag) => +                tag -> DynMap tag -> Maybe a+dynLookup u (DynMap m) = hlp fun undefined where +    hlp :: Typeable a => +      (TypeRep -> Maybe a) -> a -> Maybe a+    hlp f a = f (typeOf a)+    fun tr = M.lookup (u,tr) m >>= fromDynamic++ +-- | A sharing monad+-- with a function that binds a tag to a value.+type Sharing tag a = State (DynMap tag) a++runSharing :: Sharing tag a -> a+runSharing m = evalState m dynEmpty++share :: (Typeable a, Ord tag) => +  tag -> Sharing tag a -> Sharing tag a+share t m = do+    mx <- gets $ (dynLookup t)+    case mx of+      Just e      ->  return e+      Nothing     ->  mfix $ \e -> do+        modify (dynInsert t e)+        m+++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Jonas Dureg†rd++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+> import Distribution.Simple+> main :: IO ()+> main = defaultMain
+ Test/Feat.hs view
@@ -0,0 +1,24 @@+module Test.Feat(+  Enumerate(..),+  -- ** The type class+  Enumerable(..),+  nullary,+  unary,+  funcurry,+  consts,+  deriveEnumerable,+  FreePair(..),+  -- ** Accessing data+  optimised,+  index,+  values,+  bounded,+  uniform,+  ioAll,+  ioBounded  +  ) where++import Test.Feat.Access+import Test.Feat.Class+import Test.Feat.Enumerate+-- import Test.Feat.Modifiers
+ Test/Feat/Access.hs view
@@ -0,0 +1,156 @@+-- | Functions for accessing the values of enumerations including +-- compatability with the property based testing frameworks QuickCheck and+-- SmallCheck.+module Test.Feat.Access(+  -- ** Accessing functions+  index,+  values,+  striped,+  bounded,+  +  -- ** A simple property tester+  ioFeat,+  ioAll,+  ioBounded,+  +  -- ** Compatability+  -- *** QuickCheck+  uniform,+  -- *** SmallCheck+  toSeries,+  +  -- ** Non-class versions of the access functions+  valuesWith,+  stripedWith,+  boundedWith,+  uniformWith,+  toSeriesWith+  )where++-- testing-feat+import Test.Feat.Enumerate +import Test.Feat.Class+-- base+import Data.List+-- quickcheck+import Test.QuickCheck+-- smallcheck+-- import Test.SmallCheck.Series -- Not needed++group :: Enumerate a -> Part -> Index -> Integer+group e p i = sum (map (card e) [0..p-1]) + i++split :: Enumerate a -> Integer -> (Part, Index)+split e i0 = go i0 0 where+  go i p = let crd = card e p in +     if i < crd then (p,i)+     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+-- 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.+index :: Enumerate a -> Integer -> a +index e = uncurry (select e) . split e++-- | All values of the enumeration by increasing cost (which is the number+-- of constructors for most types). Also contains the cardinality of each list.+values :: Enumerable a => [(Integer,[a])]+values = valuesWith optimised++-- | A generalisation of @values@ that enumerates every nth value of the +-- enumeration from a given starting point.+-- As a special case @values = striped 0 0 1@.+striped ::  Enumerable a => Part -> Index -> Integer -> [(Integer,[a])]+striped = stripedWith optimised ++-- | A version of vales that has a limited number of values in each inner list.+-- If the list corresponds to a Part which is larger than the bound it evenly+-- intersperses the values across the enumeration of the Part.+bounded :: Enumerable a => Integer -> [(Integer,[a])]+bounded = boundedWith optimised++-- | A rather simple but general property testing driver.+-- The property is a (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+    mapM f xs+    go xss (s+1)+  go []           s = putStrLn $ "--- Done. Tested "++ show s++" values"++-- | ioAll = 'ioFeat' values+ioAll :: Enumerable a => (a -> IO ()) -> IO ()+ioAll = ioFeat values++-- | 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 +-- values bounded by the given size. Typical use: @sized uniform@.+uniform :: Enumerable a => Int -> Gen a+uniform = uniformWith optimised++-- | Compatability with SmallCheck. +toSeries :: Enumerable a => Int -> [a] +toSeries = toSeriesWith optimised++-- | Non class version of 'values'.+valuesWith :: Enumerate a -> [(Integer,[a])]+valuesWith e = +  [(crd,[select e p i|i <- [0..crd - 1]]) +    |p <- [0..], let crd = card e p]++-- | Non class version of 'striped'.+stripedWith :: Enumerate a -> Part -> Index -> Integer -> [(Integer,[a])]+stripedWith e p o step = if space <= 0 +  then (0,[]) : stripedWith e (p+1) (o - crd) step+  else (d,thisP) : stripedWith e (p+1) (step-m-1) step+  where+    thisP = +      [select e p x|x <- genericTake d $ iterate (+step) o]+    space = crd - o+    (d,m) = divMod space step+    crd = card e p++-- | Non class version of 'bounded'.+boundedWith :: Enumerate a -> Integer -> [(Integer,[a])]+boundedWith e n = map (samplePart e n) [0..]++samplePart :: Enumerate a -> Index -> Part -> (Integer,[a])+samplePart e m p = +  let+    top   =  toRational $ (card e p) - 1+    step  =  top / toRational (m-1) +    crd = card e p+  in if toRational m >= top +       then (crd, map (select e p) [0..crd - 1])+       else let d = floor ((toRational crd)/ step) in +         (d+1,[select e p (round (k * step))|k <- map toRational [0..d]])++-- | Non class version of 'uniform'.+uniformWith :: Enumerate a -> Part -> Gen a+uniformWith e maxp = let+  cards  = [(card e x, x) | x <- [maxp, maxp-1 .. 0]]+  tot    = sum $ fst $ unzip cards+  in if tot == 0 then uniformWith e (maxp+1) else do+    i <- choose (0,tot-1)+    return $ uncurry (select e) (lu i cards)+  where+    lu i ((crd,p):xs)  = if i<crd +      then (p,i) +      else lu (i-crd) xs+      +-- | Non class version of 'toSeries'.+toSeriesWith :: Enumerate a -> Int -> [a]+toSeriesWith e d = concat (take (d+1) $ map snd $ valuesWith e)
+ Test/Feat/Class.hs view
@@ -0,0 +1,246 @@+{-#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+  optimised,+  +  -- *** Free pairs+  FreePair(..),+  +  +  -- ** Deriving instances with template haskell+  deriveEnumerable,+  -- autoCon,+  -- autoCons+  +  ++  ) where++-- testing-feat+import Test.Feat.Enumerate+import Test.Feat.Internals.Tag(Tag(Class))+import Test.Feat.Internals.Derive+-- base+import Data.Typeable+-- template-haskell+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+-- base - only for instances+import Data.Word+import Data.Int+import Data.Bits++-- | A class of functionally enumerable types+class Typeable a => Enumerable a where+  -- | This is the interface for defining an instance. Memoisation needs to +  -- be ensured e.g. using 'mempay' but sharing is handled automatically by +  -- the default implementation of 'shared'.+  enumerate  :: Enumerate a+  +  -- | Version of enumerate that ensures it is shared between+  -- all accessing functions. Should alwasy be used when +  -- combining enumerations.+  -- Should typically be left to default behaviour.+  shared     :: Enumerate a+  shared  = tagShare Class enumerate++-- | An optimised version of enumerate. Used by all+-- library functions that access enumerated values (but not +-- by combining functions). Library functions should ensure that +-- @optimised@ is not reevaluated.+optimised :: Enumerable a => Enumerate a+optimised = 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 = mem $ 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 = mempay $ mconcat xs +++--------------------------------------------------------------------+-- Automatic derivation++-- | Derive an instance of Enumberable with Template Haskell.+deriveEnumerable :: Name -> Q [Dec]+deriveEnumerable = 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++-- -- | Splices a list of automatically derived constructors.+-- autoCons :: [Name] -> Q Exp+-- autoCons = listE . map autoCon++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+++(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)+  +++-- 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 +  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 = Natural 0+      sel p i = Natural $ 2^(p-2) + 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+           ++-- 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)+  +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 = e{+  card = \p -> if p > n then 0 else card e p, +  optimal = fmap (cutOff n) $ optimal 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)++-- | Contains only ASCII characters+instance Enumerable Char where+  enumerate = cutOff 8 $ unary (toEnum . fromIntegral :: Word -> Char)+
+ Test/Feat/Enumerate.hs view
@@ -0,0 +1,162 @@+{-#LANGUAGE DeriveDataTypeable, TemplateHaskell #-}++-- | Basic combinators fo building enumerations+-- most users will want to use the type class +-- based combinators in "Test.Feat.Class" instead. ++module Test.Feat.Enumerate(+  +  Part,+  Index,+  Enumerate(..),+  +  -- ** Combinators for building enumerations+  module Control.Applicative,+  module Data.Monoid,+  pay,+  +  -- ** Memoisation+  mem,+  mempay,+    +  -- *** Polymorphic memoisation+  module Data.Typeable,+  Tag(Source),+  tag,+  tagShare,+  optimise  +  ) where++-- testing-feat+import Control.Monad.TagShare(Sharing, runSharing, share)+import Test.Feat.Internals.Tag(Tag(Source))+-- base+import Control.Applicative+import Control.Monad+import Data.Monoid+import Data.Typeable+import Language.Haskell.TH+-- data-memocombinators+import Data.MemoCombinators++++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+-- identifies each part is called the cost of the values in +-- that part.+data Enumerate a = Enumerate+   {  +   -- | 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@+   select    ::  Part -> Index -> a,+   -- | A self-optimising function. +   optimal   ::  Sharing Tag (Enumerate a)+   } deriving Typeable     ++-- | Only use fmap with bijective functions (e.g. data constructors)+instance Functor Enumerate where +  fmap f cf = cf+    {select    = \p n -> f (select cf p n)+    , optimal  = liftM (fmap f) (optimal cf) }++-- | mappend = union+instance Monoid (Enumerate a) where+  mempty      = let e = Enumerate  (\p -> 0) +                                   (\p i -> error "select: empty")+                                   (return e) in e+  mappend     = union++-- | Disjoint union+union :: Enumerate a -> Enumerate a -> Enumerate a+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)+instance Applicative Enumerate where+  pure     = singleton+  f <*> a  = fmap (uncurry ($)) (cartesian f a)++-- | The product of two enumerations+cartesian :: Enumerate a -> Enumerate b -> Enumerate (a,b)+cartesian a b = infinite (\p -> foldl1 finUnion+  [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. +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+         sel 0 0  = a+         sel _ _  = +           error "select: index out of bounds"++-- | Increases the cost of all values in an enumeration by one.+pay :: Enumerate a -> Enumerate a+pay sel = Enumerate+    {  card      = \p -> if p <= 0 then 0 else card sel (p-1)+    ,  select    = \p -> select sel (p-1)+    ,  optimal   = liftM pay (optimal sel)+    }++-------------------------------------------------------+-- Memoisation++mem :: Enumerate a -> Enumerate a+mem sel = sel+    { card      = bits (card sel)+    , optimal   = fmap mem (optimal sel)+    }++-- | A conventient combination of memoisation and guarded recursion.+mempay :: Enumerate a -> Enumerate a+mempay = mem . pay+           ++-------------------------------------------------------+-- Polymorphic memoisation+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|]++tagShare :: Typeable a => Tag -> Enumerate a -> Enumerate a+tagShare t e = e{optimal = share t (optimal e)}++optimise :: Enumerate a -> Enumerate a+optimise e = let e' = runSharing (optimal e) in+  e'{optimal = return e'}   ++           +--------------------------------------------------------+-- Operations on finite sets+data Finite a = Finite {fCard :: Index, fSelect :: Index -> a}++finite :: Enumerate a -> Part -> Finite a+finite e p = Finite (card e p) (select e p) ++infinite :: (Part -> Finite a) -> Sharing Tag (Enumerate a) -> Enumerate a+infinite f m = Enumerate (fCard . f) (fSelect . f) m++finUnion :: Finite a -> Finite a -> Finite a+finUnion f1 f2 = Finite car sel where+  car = fCard f1 + fCard f2+  sel i = if i < fCard f1+    then fSelect f1 i+    else fSelect f2 (i-fCard f1)  ++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 (fSelect f1 q, fSelect f2 r)+++
+ Test/Feat/Internals/Derive.hs view
@@ -0,0 +1,48 @@+{-#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 (concatMap 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+  TyConI (DataD cxt _ tvbs cons _)   -> (cxt, map tvbName tvbs, cons)+  TyConI (NewtypeD cxt _ tvbs con _) -> (cxt, map tvbName tvbs, [con])+  _ -> 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/Tag.hs view
@@ -0,0 +1,5 @@+module Test.Feat.Internals.Tag where++data Tag  =  Class                       +          |  Source String String Int Int+   deriving (Show,Eq,Ord)
+ Test/Feat/Modifiers.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Types with invariants. Currently these are mostly examples of how to +-- define such types, suggestions on useful types are appreciated.+--+-- To use the invariant 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(+  NonEmpty(..),+  mkNonEmpty,++  Nat(..),+    +  ) where++-- testing-feat+import Test.Feat.Enumerate +import Test.Feat.Class+-- 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 x xs = x:xs+instance Enumerable a => Enumerable (NonEmpty a) where+  enumerate = unary NonEmpty++-- Copy paste from Enumerate.hs+-- | A type of natural numbers.+newtype Nat = Nat {nat :: Integer} +  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++
+ examples/TestTH.hs view
@@ -0,0 +1,451 @@+{-#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 (:%)]++
+ testing-feat.cabal view
@@ -0,0 +1,54 @@+Name:                testing-feat+Version:             0.1+Synopsis:            Functional enumeration for systematic and random testing+Description:         Feat (Functional Enumeration of Abstract Types) +                     provides an enumeration as a function from natural +                     numbers to values (similar to @toEnum@). This can be used+                     both for SmallCheck-style systematic testing and QuickCheck +                     style random testing, and hybrids of the two.+                     .+                     The enumerators are defined in a very boilerplate manner+                     and there is a Template Haskell script for deriving the +                     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).+                                          +License:             BSD3+License-file:        LICENSE+Author:              Jonas Duregård+Maintainer:          jonas.duregard@gmail.com+Copyright:           Jonas Duregård+Category:            Testing+Build-type:          Simple++Extra-source-files:  +    examples/TestTH.hs++Cabal-version:       >=1.2++Library+  Hs-source-dirs:       .+  Exposed-modules:+    Test.Feat, +    Test.Feat.Access,+    Test.Feat.Class,+    Test.Feat.Enumerate,+    Test.Feat.Modifiers +    Control.Monad.TagShare++  +  Build-depends: +    base >= 4.5 && <= 5,+    template-haskell >= 2.4 && < 2.8,+    mtl >= 1 && < 3,+    QuickCheck > 2 && < 3,+    containers < 1,+    data-memocombinators >= 0.4.2 && < 0.5+    +  Other-modules:+    Test.Feat.Internals.Derive+    Test.Feat.Internals.Tag+    +