summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJonasDuregard <>2010-04-17 23:06:42 (GMT)
committerLuite Stegeman <luite@luite.com>2010-04-17 23:06:42 (GMT)
commit739bce7b13891aa0e5af0db2087c4e740ca9fce0 (patch)
treef74a6f87dc7c0c31dc05d0b09054265e28c5958e
parent34211e92e27d94737cbda62e83122f1958f35119 (diff)
version 0.2.00.2.0
-rw-r--r--Agata.cabal60
-rw-r--r--Test/Agata.hs5
-rw-r--r--Test/Agata/Base.hs35
-rw-r--r--Test/Agata/Common.hs44
-rw-r--r--Test/Agata/Related.hs84
-rw-r--r--Test/Agata/Strategies.hs12
-rw-r--r--Test/AgataTH.hs41
7 files changed, 140 insertions, 141 deletions
diff --git a/Agata.cabal b/Agata.cabal
index 99ea164..574da85 100644
--- a/Agata.cabal
+++ b/Agata.cabal
@@ -1,27 +1,33 @@
-Name: Agata
-Version: 0.1.1
-Cabal-Version: >= 1.2
-build-type: Simple
-License: BSD3
-Copyright: Jonas Duregård
-License-file: LICENSE
-Author: Jonas Duregård
-Maintainer: Jonas Duregård (jonas.duregard@gmail.com)
-Homepage: http://patch-tag.com/r/jonas_duregard/Agata
-Category: Testing
-Synopsis: Generator-generator for QuickCheck
-Description: Agata (Agata Generates Algebraic Types Automatically) uses Tempalte Haskell to derive QuickCheck generators for Haskell data types. Based on the master thesis work of Jonas Duregård.
-
-Extra-source-files: Example.hs
-
-
-Library
- Build-Depends: mtl, base>=3&&<5, template-haskell, QuickCheck>=2, containers
- Exposed-modules:
- Test.Agata,
- Test.AgataTH,
- Test.Agata.Common
- Test.Agata.Strategies,
- Test.Agata.Related,
- Test.Agata.Instances,
- Test.Agata.Base \ No newline at end of file
+Name: Agata
+version: 0.2.0
+cabal-Version: >= 1.6
+build-type: Simple
+license: BSD3
+copyright: Jonas Duregård
+license-file: LICENSE
+author: Jonas Duregård
+maintainer: Jonas Duregård (jonas.duregard@gmail.com)
+category: Testing
+synopsis: Generator-generator for QuickCheck
+description: Agata (Agata Generates Algebraic Types Automatically) uses Template Haskell to derive QuickCheck generators for Haskell data types.
+extra-source-files: Example.hs
+
+
+Library
+ Build-Depends:
+ mtl, base>=4&&<5,
+ template-haskell<2.5,
+ QuickCheck>=2.1&&<2.2,
+ containers,
+ tagged
+ Exposed-modules:
+ Test.Agata,
+ Test.AgataTH,
+ Test.Agata.Common
+ Test.Agata.Strategies,
+ Test.Agata.Instances,
+ Test.Agata.Base
+
+source-repository head
+ type: darcs
+ location: http://patch-tag.com/r/jonas_duregard/Agata/ \ No newline at end of file
diff --git a/Test/Agata.hs b/Test/Agata.hs
index a948b9c..9fbd39a 100644
--- a/Test/Agata.hs
+++ b/Test/Agata.hs
@@ -2,11 +2,12 @@ module Test.Agata (
module Test.Agata.Base
, module Test.Agata.Strategies
, module Test.Agata.Common
- , module Test.Agata.Related
+ , module Data.Tagged
) where
+import Data.Tagged
+
import Test.Agata.Base
import Test.Agata.Strategies
import Test.Agata.Common
-import Test.Agata.Related
import Test.Agata.Instances \ No newline at end of file
diff --git a/Test/Agata/Base.hs b/Test/Agata/Base.hs
index 433a290..e6c34ea 100644
--- a/Test/Agata/Base.hs
+++ b/Test/Agata/Base.hs
@@ -10,10 +10,11 @@ import Test.QuickCheck
import Control.Monad.State.Lazy
import Control.Monad (liftM2)
import Control.Applicative((<$>))
+
import Data.Maybe(mapMaybe)
+import Data.Tagged
import Test.Agata.Common
-import Test.Agata.Related
import Test.Agata.Strategies
@@ -23,10 +24,10 @@ agata = agataWith linearSize
agataWith :: Buildable a => Strategy a -> Gen a
agataWith s = do
dist <- sized $ flip s dimension
- evalImproving (dimension+1,0,[]) $ ii dist (error "Origin")
+ evalImproving (dimension+1,0,[]) $ ii dist undefined
where
ii :: Buildable a => Improving () -> a -> Improving a
- ii dist a = currentDimension >>= \lvl -> case unrelated lvl of
+ ii dist a = currentDimension >>= \lvl -> case unTagged lvl of
0 -> put (0,0,[]) >> realImp a
_ -> do
x <- realImp a
@@ -38,7 +39,7 @@ agataWith s = do
evalImproving :: (Dimension a,Int,[Int]) -> Improving a -> Gen a
-evalImproving (d,k,ss) = flip evalStateT (unrelated d,k,ss)
+evalImproving (d,k,ss) = flip evalStateT (unTagged d,k,ss)
agataSC :: Buildable a => Int -> [a]
agataSC = snd . agataEnum
@@ -67,7 +68,7 @@ data DB a = BuildDebug (Dimension a) [Builder a] deriving Show
db :: Buildable a => DB a
db = BuildDebug dimension build
-rbuild :: Buildable a => Related a [Builder a]
+rbuild :: Buildable a => Tagged a [Builder a]
rbuild = return build
data Builder a = MkBuilder {
@@ -105,15 +106,15 @@ realBuild n = do
realImp :: Buildable a => a -> Improving a
realImp a = do
cur <- currentDimension
- case compare (dimension `relatedTo` a) cur of
+ case compare (dimension `taggedWith` a) cur of
GT -> improve a
- EQ -> if cur == 0 then realBuild 0 else unrelated (bacq a)
- LT -> if (dimension `relatedTo` a) == cur - 1 then unrelated breq else return a
+ EQ -> if cur == 0 then realBuild 0 else unTagged (bacq a)
+ LT -> if (dimension `taggedWith` a) == cur - 1 then unTagged breq else return a
-breq :: Buildable a => Related a (Improving a)
+breq :: Buildable a => Tagged a (Improving a)
breq = isAlwaysRecursive >>= \b -> return $ if b then request >> return (error "1") else lift (elements (map benter build)) >>= improve
-bacq :: Buildable a => a -> Related a (Improving a)
+bacq :: Buildable a => a -> Tagged a (Improving a)
bacq a = isAlwaysRecursive >>= \b -> return $ if b then acquire >>= realBuild else improve a
rebuild :: a -> (a -> Improving b) -> Improving b
@@ -145,7 +146,7 @@ rc d r = case r of
AutoRec n -> n >= fromIntegral d
NonRec _ -> False
-isAlwaysRecursive :: Buildable a => Related a Bool
+isAlwaysRecursive :: Buildable a => Tagged a Bool
isAlwaysRecursive =
any erc . concatMap bfields <$> rbuild
@@ -179,9 +180,9 @@ inline f = map trans build where
refield r = case r of
MutRec -> MutRec
Rec -> Rec
- AutoMutRec n -> AutoMutRec (rerelate n)
- AutoRec n -> AutoRec (rerelate n)
- NonRec n -> NonRec (rerelate n)
+ AutoMutRec n -> AutoMutRec (retag n)
+ AutoRec n -> AutoRec (retag n)
+ NonRec n -> NonRec (retag n)
construct :: a -> (Application b a -> Application b b) -> Builder b
construct c f = MkBuilder skel enter enm fields 1 where
@@ -243,7 +244,7 @@ rec x = case x of
nonrec :: Buildable a => Application c (a -> b) -> Application c b
nonrec x = case x of
- Fields xs -> Fields $ NonRec (rerelate $ appDimension x) : xs
+ Fields xs -> Fields $ NonRec (retag $ appDimension x) : xs
Build mf -> Build $ do
(f,ns) <- mf
realImp undefined >>= \e -> return (f e,ns)
@@ -251,7 +252,7 @@ nonrec x = case x of
autorec :: Buildable a => Application c (a -> b) -> Application c b
autorec x = case x of
- Fields xs -> Fields $ AutoRec (rerelate $ appDimension x) : xs
+ Fields xs -> Fields $ AutoRec (retag $ appDimension x) : xs
Build mf -> Build $ do
c <- currentDimension
let isRec = appDimension x >= c
@@ -262,7 +263,7 @@ autorec x = case x of
automutrec :: Buildable a => Application c (a -> b) -> Application c b
automutrec x = case x of
- Fields xs -> Fields $ AutoMutRec (rerelate $ appDimension x) : xs
+ Fields xs -> Fields $ AutoMutRec (retag $ appDimension x) : xs
_ -> autorec x
appDimension :: Buildable a => Application c (a->b) -> Dimension a
diff --git a/Test/Agata/Common.hs b/Test/Agata/Common.hs
index 6ca0992..352f7d9 100644
--- a/Test/Agata/Common.hs
+++ b/Test/Agata/Common.hs
@@ -1,13 +1,49 @@
module Test.Agata.Common where
-import Test.Agata.Related
+
import Test.QuickCheck
import Control.Monad (liftM)
import Control.Monad.State.Lazy
-type Dimension a = Related a Int
+import Data.Tagged
+
+
+type Dimension a = Tagged a Int
+
+instance Num b => Num (Tagged a b) where
+ (+) = liftM2 (+)
+ (*) = liftM2 (*)
+ (-) = liftM2 (-)
+ negate = liftM negate
+ abs = liftM abs
+ signum = liftM signum
+ fromInteger = return . fromInteger
+
+instance Real b => Real (Tagged a b) where
+ toRational = toRational . unTagged
+
+instance Integral b => Integral (Tagged a b) where
+ quot = liftM2 quot
+ rem = liftM2 rem
+ div = liftM2 div
+ mod = liftM2 mod
+ quotRem a b = unTagged $ liftM2 quotRem a b >>= \(x,y) -> return (return x,return y)
+ divMod a b = unTagged $ liftM2 divMod a b >>= \(x,y) -> return (return x,return y)
+ toInteger = toInteger . unTagged
+
+instance Enum b => Enum (Tagged a b) where
+ succ = liftM succ
+ pred = liftM pred
+ toEnum = return . toEnum
+ fromEnum = fromEnum . unTagged
+ enumFrom = map return . unTagged . liftM enumFrom
+ enumFromThen a = map return . unTagged . liftM2 enumFromThen a
+ enumFromTo a = map return . unTagged . liftM2 enumFromTo a
+ enumFromThenTo a b = map return . unTagged . liftM3 enumFromThenTo a b
+taggedWith :: Tagged b a -> b -> Tagged b a
+taggedWith = const
type Improving a = StateT (Int, Int, [Int]) Gen a
currentDimension :: Improving (Dimension a)
@@ -55,4 +91,6 @@ permute = fromList
k <- choose (1,nx+ny)
if k <= nx
then (x:) `liftM` ((nx-1, xs) `merge'` (ny, y:ys))
- else (y:) `liftM` ((nx, x:xs) `merge'` (ny-1, ys)) \ No newline at end of file
+ else (y:) `liftM` ((nx, x:xs) `merge'` (ny-1, ys))
+
+
diff --git a/Test/Agata/Related.hs b/Test/Agata/Related.hs
deleted file mode 100644
index 06aba42..0000000
--- a/Test/Agata/Related.hs
+++ /dev/null
@@ -1,84 +0,0 @@
-module Test.Agata.Related where
-
-import Control.Monad
-
-
--- -XGeneralizedNewtypeDeriving would be nice
-newtype Related a b = Related b deriving (Eq,Ord,Show)
-
-instance Num b => Num (Related a b) where
- (+) = liftM2 (+)
- (*) = liftM2 (*)
- (-) = liftM2 (-)
- negate = liftM negate
- abs = liftM abs
- signum = liftM signum
- fromInteger = return . fromInteger
-
-instance Real b => Real (Related a b) where
- toRational = toRational . unrelated
-
-instance Integral b => Integral (Related a b) where
- quot = liftM2 quot
- rem = liftM2 rem
- div = liftM2 div
- mod = liftM2 mod
- quotRem a b = unrelated $ liftM2 quotRem a b >>= \(x,y) -> return (return x,return y)
- divMod a b = unrelated $ liftM2 divMod a b >>= \(x,y) -> return (return x,return y)
- toInteger = toInteger . unrelated
-
-instance Enum b => Enum (Related a b) where
- succ = liftM succ
- pred = liftM pred
- toEnum = return . toEnum
- fromEnum = fromEnum . unrelated
- enumFrom = map return . unrelated . liftM enumFrom
- enumFromThen a = map return . unrelated . liftM2 enumFromThen a
- enumFromTo a = map return . unrelated . liftM2 enumFromTo a
- enumFromThenTo a b = map return . unrelated . liftM3 enumFromThenTo a b
-
-
-instance Functor (Related a) where
- fmap f (Related a) = Related $ f a
-
-instance Monad (Related a) where
- return = Related
- (Related a) >>= f = f a
-
-
-
-unrelated :: Related a b -> b
-unrelated (Related b) = b
-
-rerelate :: Related a b -> Related c b
-rerelate = return . unrelated
-
-relatedTo :: Related a b -> a -> Related a b
-r `relatedTo` _ = r
-
-relatedTo1 :: Related a b -> x a -> Related a b
-r `relatedTo1` _ = r
-
-relatedTo2 :: Related a b -> x a x1 -> Related a b
-r `relatedTo2` _ = r
-
-relatedTo3 :: Related a b -> x a x1 x2 -> Related a b
-r `relatedTo3` _ = r
-
-
-related :: a -> b -> Related a b
-related _ = return
-
-related1 :: x1 a -> b -> Related a b
-related1 _ = return
-
-related2 :: x1 a x2 -> b -> Related a b
-related2 _ = return
-
-related3 :: x1 a x2 x3 -> b -> Related a b
-related3 _ = return
-
-
-param1 :: Related a b -> Related (x1 a) b
-param1 = rerelate
-
diff --git a/Test/Agata/Strategies.hs b/Test/Agata/Strategies.hs
index 6fc8636..dbe1b09 100644
--- a/Test/Agata/Strategies.hs
+++ b/Test/Agata/Strategies.hs
@@ -21,6 +21,12 @@ listStrategy f lev0 s = do
linearSize :: Strategy a
linearSize size _ = return $ do
(lvl,r,[]) <- get
+ ms <- lift $ piles (r+1) size
+ put(lvl,0,tail ms)
+
+linearSize' :: Strategy a
+linearSize' size _ = return $ do
+ (lvl,r,[]) <- get
k <- lift $ choose (0,size)
ms <- lift $ piles r k
put(lvl,0,ms)
@@ -32,6 +38,12 @@ quadraticSize size lev0 = return $ do
ms <- lift $ piles r k
put(lvl,0,ms)
+quadraticSize' :: Strategy a
+quadraticSize' size lev0 = return $ do
+ (lvl,r,[]) <- get
+ ms <- lift $ piles (r+1) $ size*((fromIntegral lev0 - lvl) + 1)
+ put(lvl,0,ms)
+
partitions :: Strategy a
partitions = listStrategy $ \s l -> do
xs <- sequence $ replicate (fromIntegral l-1) $ choose (0,s)
diff --git a/Test/AgataTH.hs b/Test/AgataTH.hs
index c44697a..8f0423f 100644
--- a/Test/AgataTH.hs
+++ b/Test/AgataTH.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
+
-- {-
module Test.AgataTH (
agatath
@@ -6,6 +8,7 @@ module Test.AgataTH (
, DerivOption(..), (<++>)
, echoAgata
, module Test.Agata
+ , module Test.QuickCheck
) where
-- }-
-- module Test.AgataTH where
@@ -47,6 +50,8 @@ derive n = deriveall [n]
+
+
(<++>) :: Derivation -> DerivOption -> Derivation
(<++>) d o = d{derivOptions = o `Set.insert` derivOptions d}
@@ -60,15 +65,15 @@ agatath der@(Derivation ts ss) = fmap concat $ mapM deriveAgata ts where
i@(TyConI d) <- reify n
nns <- replicateM (length $ dParams d) (newName "a")
- nns1 <- replicateM (length $ dParams d) (newName "b")
+ nns1 <- replicateM (length $ dParams d) (newName "b") -- >>= mapM unVarBndr
let vs = map VarT nns
expanded <- fmap reTuple $ expand n nns1
- m@[InstanceD [] (AppT cBuildable_ _) [ValD (VarP improve_) _ _,ValD (VarP build_) _ _,ValD (VarP dimension_) (NormalB (SigE (AppE rerelate_ _) (AppT tDimension_ _))) []]] <-
+ m@[InstanceD [] (AppT (ConT cBuildable_) _) [ValD (VarP improve_) _ _,ValD (VarP build_) _ _,ValD (VarP dimension_) (NormalB (SigE (AppE rerelate_ _) (AppT tDimension_ _))) []]] <-
[d| instance Buildable T1 where
improve = undefined
build = undefined
- dimension = rerelate dimension :: Dimension T1
+ dimension = retag dimension :: Dimension T1
|]
impbody <- mapM impClause (dConsts d)
@@ -80,15 +85,15 @@ agatath der@(Derivation ts ss) = fmap concat $ mapM deriveAgata ts where
let
isRecursive = Mut `elem` allTypesT_t
dimplus = InfixE (Just $ VarE dimension_) (VarE $ mkName "+") (Just (LitE (IntegerL 1)))
- dimtyp = ForallT nns1 [] $ AppT (AppT ArrowT (AppT tDimension_ expanded)) (AppT tDimension_ (getType n nns1))
+ dimtyp = ForallT (map varBndr nns1) [] $ AppT (AppT ArrowT (AppT tDimension_ expanded)) (AppT tDimension_ (getType n nns1))
dimbody = NormalB $ AppE (SigE rerelate_ dimtyp) (if isRecursive then dimplus else VarE dimension_)
- let preqs = map (AppT cBuildable_) vs
+ let preqs = allInClass cBuildable_ vs
arb <- arbInstance preqs vs
return $ [
- InstanceD preqs (AppT cBuildable_ (rt vs n))
+ InstanceD preqs (AppT (ConT cBuildable_) (rt vs n))
[FunD improve_ impbody
, ValD (VarP build_) buildbody []
, ValD (VarP dimension_) dimbody []
@@ -243,8 +248,8 @@ dTypes d = case d of
TySynD _ _ t -> [t]
dParams :: Dec -> [Name]
dParams d = case d of
- DataD _ _ ns _ _ -> ns
- NewtypeD _ _ ns _ _ -> ns
+ DataD _ _ ns _ _ -> map unVarBndr ns
+ NewtypeD _ _ ns _ _ -> map unVarBndr ns
dConsts :: Dec -> [Con]
dConsts d = case d of
DataD _ _ _ cs _ -> cs
@@ -289,6 +294,26 @@ collectIf b x = do
+-- TH 2.4 compatability
+-- #if __GLASGOW_HASKELL__ >= 611
+#if MIN_VERSION_template_haskell(2,4,0)
+unVarBndr :: TyVarBndr -> Name
+unVarBndr (PlainTV n) = n
+unVarBndr (KindedTV n _) = n
+
+varBndr :: Name -> TyVarBndr
+varBndr n = (PlainTV n)
+
+allInClass :: Name -> [Type] -> [Pred]
+allInClass n vs = map (ClassP n) (map (:[]) vs)
+
+#else
+unVarBndr = id
+varBndr = id
+allInClass n vs = map (AppT (ConT n)) vs
+#endif
+
+