packages feed

Agata 0.1.1 → 0.2.0

raw patch · 7 files changed

+139/−140 lines, 7 filesdep +taggeddep ~QuickCheckdep ~basedep ~template-haskell

Dependencies added: tagged

Dependency ranges changed: QuickCheck, base, template-haskell

Files

Agata.cabal view
@@ -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,
+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/
Test/Agata.hs view
@@ -2,11 +2,12 @@     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
Test/Agata/Base.hs view
@@ -10,10 +10,11 @@ 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 @@ 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 @@ 
 
 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 @@ 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 @@ 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 @@        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 @@       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 @@ 
 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 @@ 
 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 @@ 
 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
Test/Agata/Common.hs view
@@ -1,14 +1,50 @@ 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)
 currentDimension = return `fmap` getLevel where
@@ -55,4 +91,6 @@       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))+        else (y:) `liftM` ((nx, x:xs) `merge'` (ny-1, ys))
+        
+
− Test/Agata/Related.hs 
@@ -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
-
Test/Agata/Strategies.hs view
@@ -21,6 +21,12 @@ 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)
@@ -30,6 +36,12 @@   (lvl,r,[]) <- get
   k <- lift $ choose (0,size*((fromIntegral lev0 - lvl) + 1))
   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
Test/AgataTH.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
+
 -- {-
 module Test.AgataTH (
       agatath
@@ -6,6 +8,7 @@     , DerivOption(..), (<++>)
     , echoAgata
     , module Test.Agata
+    , module Test.QuickCheck
     ) where
 -- }-
 -- module Test.AgataTH where
@@ -47,6 +50,8 @@ 
 
 
+
+
 (<++>) :: Derivation -> DerivOption -> Derivation
 (<++>) d o = d{derivOptions = o `Set.insert` derivOptions d}
 
@@ -60,15 +65,15 @@     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 @@     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 @@   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
@@ -287,6 +292,26 @@   collected_b <- collected b
   unless collected_b $ collect b >> x
 
+
+
+-- 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