Agata (empty) → 0.1.1

raw patch · 11 files changed

+977/−0 lines, 11 filesdep +QuickCheckdep +basedep +containerssetup-changed

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

Files

• Agata.cabal +27/−0
• Example.hs +17/−0
• LICENSE +26/−0
• Setup.hs +2/−0
• Test/Agata.hs +12/−0
• Test/Agata/Base.hs +272/−0
• Test/Agata/Common.hs +58/−0
• Test/Agata/Instances.hs +126/−0
• Test/Agata/Related.hs +84/−0
• Test/Agata/Strategies.hs +50/−0
• Test/AgataTH.hs +303/−0

@@ -0,0 +1,27 @@+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

@@ -0,0 +1,17 @@+{-#LANGUAGE TemplateHaskell #-}+import Test.QuickCheck+import Test.AgataTH++data X a b = X [Either a b] deriving Show+data Y = Y deriving Show+data Z = Z deriving Show+++$(agatath $ derive ''X <++> NoArbitrary)+instance (Buildable a, Buildable b) => Arbitrary (X a b) where+ arbitrary = agataWith partitions+++$(agatath $ deriveall [''Y,''Z])++main = sample (arbitrary :: Gen (X Y Z))

@@ -0,0 +1,26 @@+Copyright (c) 2000-2006, 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 names of the copyright owners nor the names of the +  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.

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

@@ -0,0 +1,12 @@+module Test.Agata (
+    module Test.Agata.Base
+  , module Test.Agata.Strategies
+  , module Test.Agata.Common
+  , module Test.Agata.Related
+  ) where
+
+import Test.Agata.Base
+import Test.Agata.Strategies
+import Test.Agata.Common
+import Test.Agata.Related
+import Test.Agata.Instances

@@ -0,0 +1,272 @@+module Test.Agata.Base 
+    ( agata, agataWith, agataSC, agataEnum
+    , Buildable(..), Builder
+    , rebuild, rb, (>=>), (*>), ($>), (.>), graft, inline, automutrec
+    , use, construct, autorec, nonrec, mutrec, rec
+    ) where
+
+
+import Test.QuickCheck
+import Control.Monad.State.Lazy
+import Control.Monad (liftM2)
+import Control.Applicative((<$>))
+import Data.Maybe(mapMaybe)
+
+import Test.Agata.Common
+import Test.Agata.Related
+import Test.Agata.Strategies
+
+
+agata :: Buildable a => Gen a
+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")
+  where
+    ii :: Buildable a => Improving () -> a -> Improving a
+    ii dist a = currentDimension >>= \lvl -> case unrelated lvl of
+      0 -> put (0,0,[]) >> realImp a
+      _ -> do
+        x <- realImp a 
+        dec
+        dist
+        ii dist x
+
+    dec = get >>= \(lvl,r,[]) -> put (lvl-1,r,[])
+
+
+evalImproving :: (Dimension a,Int,[Int]) -> Improving a -> Gen a
+evalImproving (d,k,ss) = flip evalStateT (unrelated d,k,ss)
+
+agataSC :: Buildable a => Int -> [a]
+agataSC = snd . agataEnum
+
+agataEnum :: Buildable a => Int -> (Integer,[a])
+agataEnum 0 = (toInteger $ length xs, xs) where 
+  xs = concat $ snd $ unzip [benum c 0|c<-build]
+agataEnum n
+ | n < 0 = (0,[])
+ | otherwise = (sum ms, concat xs) where 
+  (ms,xs) = unzip [benum c n|c<-build]
+
+
+
+
+
+class Buildable a where
+  build :: [Builder a]
+  improve :: a -> Improving a
+  improve = return
+  dimension :: Dimension a
+  dimension = autoDim
+
+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 = return build
+
+data Builder a = MkBuilder {
+  bskel :: Int -> Improving a,
+  benter :: a, 
+  benum :: Int -> (Integer,[a]),
+  bfields :: [Recursivity a],
+  bweight :: Int
+  }
+
+instance Show (Builder a) where
+  show = show . bfields
+
+
+brec :: Builder a -> Dimension a -> Bool
+brec b d = d > 0 && (not . null $ filter (rc d) (bfields b))
+
+
+
+realBuild :: (Buildable a) => Int -> Improving a
+realBuild n = do
+  c <- currentDimension
+  let recs   = [bskel b n|b<- build, brec b c]
+  let nrecs  = [bskel b n|b<- build, not $ brec b c]
+  let exits   = [bskel b n|b<- build, brec b c, Rec `notElem` bfields b]
+  join (lift $ elements $ if n > 0 then 
+    if null recs then [get >>= error . show] else recs
+    else if null nrecs then recs else nrecs)
+      -- FIXME : Get exits
+      -- _ -> nrecs
+  
+
+
+-- Determines if a value is defined, should be defined, or left undefined
+realImp :: Buildable a => a -> Improving a
+realImp a = do
+  cur <- currentDimension
+  case compare (dimension `relatedTo` 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
+
+breq :: Buildable a => Related 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 a = isAlwaysRecursive >>= \b -> return $ if b then acquire >>= realBuild else improve a
+
+rebuild :: a -> (a -> Improving b) -> Improving b
+rebuild a f = f a 
+
+rb :: Buildable a => a -> (a->b) -> Improving b
+rb a f = f <$> realImp a
+
+
+data Recursivity a = 
+    NonRec (Dimension a) 
+  | Rec 
+  | MutRec 
+  | AutoMutRec (Dimension a) 
+  | AutoRec (Dimension a) 
+    deriving (Show,Eq)
+
+erc r = case r of
+       MutRec    -> True
+       Rec       -> True
+       AutoMutRec _ -> True
+       AutoRec _ -> False
+       NonRec _  -> False
+
+rc d r = case r of
+       MutRec    -> True
+       Rec       -> True
+       AutoMutRec n -> n >= fromIntegral d
+       AutoRec n -> n >= fromIntegral d
+       NonRec _  -> False
+
+isAlwaysRecursive :: Buildable a => Related a Bool
+isAlwaysRecursive =
+  any erc . concatMap bfields <$> rbuild
+
+
+-- A type that represents four possible computations on constructors
+--  Build a value with a list of sizes for recursive fields
+--  Collect informations about the fields of the constructor
+--  Enumerate all values to a specific depth
+--  Return a value where all fields are undefined
+data Application b a = 
+    Build (Improving (a,[Int]))
+  | Fields [Recursivity b]
+  | Enumerate Int Integer [a]
+  | Enter a
+
+a $> b = [construct a b]
+infixr 8 $>
+
+
+inline :: Buildable a => (a -> b) -> [Builder b]
+inline f = map trans build where
+  trans b = MkBuilder
+    (\n -> f <$> bskel b n)
+    (f $ benter b)
+    (\n -> if n <= 0 then (0,[]) else 
+             let (m1,ys) = agataEnum (n-1) in 
+               if m1 <= 0 then (0,[]) else (m1,[f a|a <- ys]))
+    (map refield $ bfields b)
+    (bweight b)
+    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)
+
+construct :: a -> (Application b a -> Application b b) -> Builder b
+construct c f = MkBuilder skel enter enm fields 1 where
+  fields = case f $ Fields [] of
+    Fields ls -> ls
+  recfields lev = filter (rc lev) fields
+  isrec lev = not $ null $ recfields lev
+  skel n        = do
+    rs <- length . recfields <$> currentDimension
+    ns <- if rs == 0 then return $ repeat 0 else lift $ piles rs (n-1)
+    let Build m = f (Build $ return (c,ns))
+    fst <$> m
+  enm n = case f $ Enumerate n 1 [c] of
+    Enumerate _ m ls -> (m,ls)
+  enter = case f $ Enter c of
+    Enter x -> x
+
+graft :: Gen a -> (Int -> (Integer,[a])) -> [Builder a]
+graft g e = [MkBuilder (lift . flip resize g) undefined e [MutRec] 1]
+
+use :: a -> [Builder a]
+use x = [construct x id]
+
+
+(.>) a b = b . a
+(*>) a b = a >=> b
+
+autoDim :: Buildable a => Dimension a
+autoDim = do 
+  r <- isAlwaysRecursive
+  if r then (+1) <$> maxdim else maxdim where
+    maxdim :: Buildable a => Dimension a
+    maxdim = (maximum . (0:)) <$> (rbuild >>= sequence . mapMaybe dimOf . concatMap bfields)  where
+      dimOf r = case r of
+        NonRec d  -> Just d
+        AutoRec d -> Just d
+        _         -> Nothing
+
+
+def :: Buildable a => Application c (a -> b) -> Application c b
+def (Enter f)          = Enter $ f (error "Entry-value")
+def (Enumerate n 0 []) = Enumerate n 0 []
+def (Enumerate n m xs) = Enumerate n (m1*m) [f a|f <- xs, a <- ys] where
+  (m1,ys) = agataEnum (n-1)
+
+
+mutrec :: Buildable a => Application c (a -> b) -> Application c b
+mutrec x = case x of
+  Fields xs -> Fields $ MutRec : xs
+  Build mf  -> Build $ do
+    (f,x:xs) <- mf
+    realBuild x >>= \e -> return (f e,xs)
+  _         -> def x
+
+rec :: Buildable c => Application c (c -> b) -> Application c b
+rec x = case x of
+  Fields xs -> Fields $ Rec : xs
+  _ -> mutrec x
+
+nonrec :: Buildable a => Application c (a -> b) -> Application c b
+nonrec x = case x of
+  Fields xs -> Fields $ NonRec (rerelate $ appDimension x) : xs
+  Build mf  -> Build $ do
+    (f,ns) <- mf
+    realImp undefined >>= \e -> return (f e,ns)
+  _         -> def x
+
+autorec :: Buildable a => Application c (a -> b) -> Application c b
+autorec x = case x of
+  Fields xs -> Fields $ AutoRec (rerelate $ appDimension x) : xs
+  Build mf  -> Build $ do
+    c <- currentDimension
+    let isRec = appDimension x >= c
+    if isRec then unbuild $ mutrec x else unbuild $ nonrec x
+    where
+      unbuild (Build x) = x
+  _         -> def x
+
+automutrec :: Buildable a => Application c (a -> b) -> Application c b
+automutrec x = case x of
+  Fields xs -> Fields $ AutoMutRec (rerelate $ appDimension x) : xs
+  _         -> autorec x
+
+appDimension :: Buildable a => Application c (a->b) -> Dimension a
+appDimension f = dimension
+
+
+

@@ -0,0 +1,58 @@+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
+
+
+type Improving a = StateT (Int, Int, [Int]) Gen a
+currentDimension :: Improving (Dimension a)
+currentDimension = return `fmap` getLevel where
+  getLevel :: Improving Int
+  getLevel = gets $ \(l,r,ss) -> l
+request :: Improving ()
+request = modify $ \(l,r,ss) -> (l,r+1,ss)
+acquire :: Improving Int
+acquire = do
+  get >>= check
+  (l,r,s:ss) <- get
+  put (l,r,ss)
+  return s
+  where
+    check s = case s of
+      (l,r,s:ss) -> return ()
+      _ -> error $ "acquire: " ++ show s
+
+
+piles 0 _      = return []
+piles a b 
+  | a <= 0     = error "piling 0 or fever piles"
+  | otherwise  = genSorted a b b >>= permute where
+  genSorted 1 n _ = return [n]
+  genSorted p n m = do 
+    r <- choose (ceiling $ fromIntegral  n / fromIntegral p,min m n)
+    liftM (r:) $ genSorted (p-1) (n-r) (min m r)
+
+permute :: [a] -> Gen [a]
+permute = fromList
+  where
+  fromList []  = return []
+  fromList [x] = return [x]
+  fromList xs  = fromList l `merge` fromList r
+      where (l,r) = splitAt (length xs `div` 2) xs
+  merge :: Gen [a] -> Gen [a] -> Gen [a]
+  merge rxs rys = do
+    xs <- rxs; ys <- rys
+    merge' (length xs, xs) (length ys, ys)
+   where
+    merge' (0 , [])   (_ , ys)   = return ys
+    merge' (_ , xs)   (0 , [])   = return xs
+    merge' (nx, x:xs) (ny, y:ys) = do
+      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))

@@ -0,0 +1,126 @@+module Test.Agata.Instances where
+
+import Test.Agata.Base
+
+import Test.QuickCheck (arbitrary)
+
+
+instance Buildable a => Buildable (Maybe a) where
+  improve x = case x of
+    Just a1 -> rebuild Just $ rb a1
+    _ -> return x
+  build =
+    use Nothing ++
+    Just $> autorec
+
+    
+
+instance (Buildable a, Buildable b) => Buildable (Either a b) where
+  improve x = case x of
+    Left a1 -> rebuild Left $ rb a1
+    Right a1 -> rebuild Right $ rb a1
+  build = 
+    Left $> autorec ++
+    Right $> autorec
+
+instance Buildable a => Buildable [a] where
+  improve x = case x of
+    (a:b) -> rebuild (:) $ rb a *> rb b
+    _     -> return x
+  build = 
+    use [] ++ 
+    (:)  $> autorec .> rec
+
+
+instance Buildable () where
+  improve x = case x of
+    _     -> return x
+  build = use ()
+    
+instance Buildable Bool where
+  improve x = case x of
+    _     -> return x
+  build = use True ++ use False
+
+
+instance Buildable Char where
+  dimension = return 0
+  improve x = case x of
+    _     -> return x
+  build = graft arbitrary (\n -> (toInteger (n+1),take (n+1) ['a'..'z'] ))
+
+      
+      
+instance Buildable Int where
+  dimension = return 1
+  improve x = case x of
+    _     -> return x
+  build = graft arbitrary (\n -> (toInteger (n+1),[0..n]) )
+
+
+
+
+
+
+
+
+instance (Buildable a,Buildable b) => Buildable (a,b) where
+  improve x = case x of
+    (a1, a2) -> rebuild (,) $ rb a1 *> rb a2
+  build = (,) $> autorec . autorec
+
+instance (Buildable a,Buildable b,Buildable c) => Buildable (a,b,c) where
+  improve x = case x of
+    (a1,a2,a3) -> 
+      rebuild (,,) $ rb a1 *> rb a2 *> rb a3
+  build =  (,,) $> autorec . autorec . autorec 
+
+
+instance (Buildable a,Buildable b,Buildable c,Buildable d) => Buildable (a,b,c,d) where
+  improve x = case x of
+    (a1,a2,a3,a4) -> 
+      rebuild (,,,) $ rb a1 *> rb a2 *> rb a3 *> rb a4
+  build = (,,,) $> autorec . autorec . autorec . autorec
+
+
+instance (Buildable a,Buildable b,Buildable c,Buildable d,Buildable e) => Buildable (a,b,c,d,e) where
+  improve x = case x of
+    (a1,a2,a3,a4,a5) -> 
+      rebuild (,,,,) $ rb a1 *> rb a2 *> rb a3 *> rb a4 *> rb a5
+  build = (,,,,) $> autorec . autorec . autorec . autorec . autorec
+
+
+instance (Buildable a,Buildable b,Buildable c,Buildable d,Buildable e,Buildable f) => Buildable (a,b,c,d,e,f) where
+  improve x = case x of
+    (a1,a2,a3,a4,a5,a6) -> 
+      rebuild (,,,,,) $ rb a1 *> rb a2 *> rb a3 *> rb a4 *> rb a5 *> rb a6 
+  build = (,,,,,) $> autorec . autorec . autorec . autorec . autorec . autorec 
+
+
+instance (Buildable a,Buildable b,Buildable c,Buildable d,Buildable e,Buildable f,Buildable g) => Buildable (a,b,c,d,e,f,g) where
+  improve x = case x of
+    (a1,a2,a3,a4,a5,a6,a7) -> 
+      rebuild (,,,,,,) $ rb a1 *> rb a2 *> rb a3 *> rb a4 *> rb a5 *> rb a6 *> rb a7 
+  build = (,,,,,,) $> autorec . autorec . autorec . autorec . autorec . autorec . autorec 
+
+
+instance (Buildable a,Buildable b,Buildable c,Buildable d,Buildable e,Buildable f,Buildable g,Buildable h) => Buildable (a,b,c,d,e,f,g,h) where
+  improve x = case x of
+    (a1,a2,a3,a4,a5,a6,a7,a8) -> 
+      rebuild (,,,,,,,) $ rb a1 *> rb a2 *> rb a3 *> rb a4 *> rb a5 *> rb a6 *> rb a7 *> rb a8
+  build = (,,,,,,,) $> autorec . autorec . autorec . autorec . autorec . autorec . autorec . autorec 
+
+
+instance (Buildable a,Buildable b,Buildable c,Buildable d,Buildable e,Buildable f,Buildable g,Buildable h,Buildable i) => Buildable (a,b,c,d,e,f,g,h,i) where
+  improve x = case x of
+    (a1,a2,a3,a4,a5,a6,a7,a8,a9) -> 
+      rebuild (,,,,,,,,) $ rb a1 *> rb a2 *> rb a3 *> rb a4 *> rb a5 *> rb a6 *> rb a7 *> rb a8 *> rb a9
+  build = (,,,,,,,,) $> autorec . autorec . autorec . autorec . autorec . autorec . autorec . autorec . autorec
+
+
+instance (Buildable a,Buildable b,Buildable c,Buildable d,Buildable e,Buildable f,Buildable g,Buildable h,Buildable i,Buildable j) => Buildable (a,b,c,d,e,f,g,h,i,j) where
+  improve x = case x of
+    (a1,a2,a3,a4,a5,a6,a7,a8,a9,a10) -> 
+      rebuild (,,,,,,,,,) $ rb a1 *> rb a2 *> rb a3 *> rb a4 *> rb a5 *> rb a6 *> rb a7 *> rb a8 *> rb a9 *> rb a10
+  build = (,,,,,,,,,) $> autorec . autorec . autorec . autorec . autorec . autorec . autorec . autorec . autorec . autorec 
+

@@ -0,0 +1,84 @@+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
+

@@ -0,0 +1,50 @@+module Test.Agata.Strategies where
+
+import Test.QuickCheck
+import Control.Monad.State.Lazy
+import Test.Agata.Common
+
+
+type Strategy a = Int -> Dimension a -> Gen(Improving ())
+
+listStrategy :: (Int -> Dimension a -> Gen [Int]) -> Strategy a
+listStrategy f lev0 s = do
+    lvls <- f lev0 s
+    return $ do
+      (lvl,r,[]) <- get
+      let d = (lev0 - lvl) + 1
+      let k = lvls !! (lvl-1)
+      ms <- lift $ piles r k
+      put(lvl,0,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)
+
+quadraticSize :: Strategy a
+quadraticSize size lev0 = return $ do
+  (lvl,r,[]) <- get
+  k <- lift $ choose (0,size*((fromIntegral lev0 - lvl) + 1))
+  ms <- lift $ piles r k
+  put(lvl,0,ms) 
+
+partitions :: Strategy a
+partitions = listStrategy $ \s l -> do
+      xs <- sequence $ replicate (fromIntegral l-1) $ choose (0,s)
+      permute (s:xs)
+
+exponentialSize :: Strategy a
+exponentialSize s _ = return $ do 
+  (lvl,r,[]) <- get
+  ns <- sequence $ replicate r $ lift $ choose (0,s)
+  put (lvl,0,ns)
+
+fixedSize :: Strategy a
+fixedSize = listStrategy $ \s l -> piles (fromIntegral l) s
+  
+randomStrategy :: [Strategy a] -> Strategy a
+randomStrategy ls l s = oneof $ map (\f -> f l s) ls

@@ -0,0 +1,303 @@+{-# LANGUAGE TemplateHaskell #-}
+-- {-
+module Test.AgataTH (
+      agatath
+    , derive, deriveall
+    , DerivOption(..), (<++>)
+    , echoAgata
+    , module Test.Agata
+    ) where
+-- }-
+-- module Test.AgataTH where
+
+import Language.Haskell.TH.Syntax hiding (lift)
+import qualified Language.Haskell.TH.Syntax as TH (lift)
+import Language.Haskell.TH
+import Control.Monad
+
+import Test.Agata
+import Test.QuickCheck(Arbitrary(..))
+
+import Data.List(nub, union)
+import Data.Maybe(fromMaybe)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Control.Monad.State.Lazy
+
+
+---------------------------------------------------------------------
+-- Some day this file might be tidied up into a presentable state...
+--   
+data Derivation = Derivation {
+    derivNames :: [Name]
+  , derivOptions :: Set.Set DerivOption
+  }
+
+data DerivOption = 
+    Inline Name
+  | NoArbitrary
+    deriving (Show,Eq,Ord)
+
+deriveall :: [Name] -> Derivation
+deriveall ns = Derivation ns Set.empty
+
+derive :: Name -> Derivation
+derive n = deriveall [n]
+
+
+
+(<++>) :: Derivation -> DerivOption -> Derivation
+(<++>) d o = d{derivOptions = o `Set.insert` derivOptions d}
+
+
+echoAgata s n =  agatath (derive  n) >>= (\r -> return [FunD (mkName s) [Clause [] (NormalB $ LitE $ StringL r)  []]]) . dump
+
+agatath :: Derivation -> Q [Dec]
+agatath der@(Derivation ts ss) = fmap concat $ mapM deriveAgata ts where
+  isSet o = o `Set.member` ss
+  deriveAgata n = do
+    i@(TyConI d)  <-  reify n
+  
+    nns <- replicateM (length $ dParams d) (newName "a")
+    nns1 <- replicateM (length $ dParams d) (newName "b")
+    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_ _))) []]] <-
+       [d| instance Buildable T1 where
+             improve = undefined
+             build = undefined
+             dimension = rerelate dimension :: Dimension T1
+       |]
+
+    impbody <- mapM impClause (dConsts d)
+    buildbody <- fmap NormalB $ bldClauses (dConsts d) -- mapM (bldClause t) (dConsts d) >>= return . NormalB . ListE
+
+    allTypesT_t <- fmap (nub . concat) $ mapM (recs n . cFields) (dConsts d)
+  
+  
+    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))
+      dimbody = NormalB $ AppE (SigE rerelate_ dimtyp) (if isRecursive then dimplus else VarE dimension_)
+
+    let preqs = map (AppT cBuildable_) vs 
+
+    arb <- arbInstance preqs vs
+  
+    return $ [
+      InstanceD preqs (AppT cBuildable_ (rt vs n)) 
+        [FunD improve_ impbody
+        , ValD (VarP build_) buildbody []
+        , ValD (VarP dimension_) dimbody []
+        ]] ++ if isSet NoArbitrary then [] else [arb]
+  
+
+    where
+      rt :: [Type] -> Name -> Type
+      rt [] n = ConT n
+      rt (v:vs) n = AppT (rt vs n) v
+      genPE n = do
+        ids <- replicateM n (newName "x")
+        return (map varP ids, map varE ids)
+      
+      bldClauses [c]     = bldClause c
+      bldClauses (c:cs)  = [| $(bldClause c) ++ $(bldClauses cs) |]
+     
+      bldClause :: Con -> Q Exp
+      bldClause c 
+        | isSet $ Inline $ cName c =
+          [| inline $(conE $ cName c) |]
+        | otherwise               = do
+          let ts   = cFields c
+              name = cName c
+              f [] = [| id |]
+              f (Auto:vars) = [| autorec .> ($(f vars)) |]
+              f (Mut:vars) = [| automutrec .> ($(f vars)) |]
+          [| $(conE name) $> $(recs n ts >>= f) |]
+      
+      impClause c = do
+        let fields = cFields c
+        let name   = cName c
+        let idExp  = cId c
+        (pats,vars) <- genPE (length fields)
+        let f []       = [| return . id |]
+            f (v:vars) = [| rb $v *> $(f vars) |]
+        clause [conP name pats]                                 -- (A x1 x2)
+               (normalB [| rebuild $(idExp) $(f vars) |]) []  -- "A "++show x1++" "++show x2
+
+      arbInstance preqs vs = do
+        m@[InstanceD [] (AppT cArbitrary_ _) body_] <-
+          [d| instance Arbitrary T1 where
+                arbitrary = agata
+          |]
+        return $ InstanceD preqs (AppT cArbitrary_ (rt vs n)) body_
+
+data Recu = Mut | Auto deriving (Eq,Show)
+recs :: Name -> [Type] -> Q [Recu]
+recs n []     = return []
+recs n (t:ts) = do
+  ats <- allTypesT t
+  rest  <- recs n ts
+  return $ (if n `Set.member` ats then Mut else Auto) : rest
+
+
+allTypesT :: Type -> Q (Set.Set Name)
+allTypesT t = getCollected (xf t) where
+  f n1 = do
+    i <- lift $ reify n1
+    mapM_ xf (iTypes i)
+  xf :: Type -> Collecting Name ()
+  xf t = case t of
+        ConT n2	-> collectIf n2 (f n2)
+        AppT t1 t2  -> xf t1 >> xf t2 
+        VarT n	-> return ()
+        TupleT x	-> return ()
+        ArrowT	-> return ()         
+        ListT	-> return ()
+
+
+
+contains :: Type -> Name -> Q Bool
+contains t n = fmap (Set.member n) $ allTypesT t
+
+flat :: Type -> (Type,[Type])
+flat = flat' where
+  flat' (AppT t1 t2) = case flat' t1 of
+    (t,ts) -> (t,ts++[t2])
+  flat' x = (x,[])
+
+
+getType :: Name -> [Name] -> Type
+getType n [] = ConT n
+getType n (n1:ns) = AppT (getType n ns) (VarT n1)
+
+
+
+expand :: Name -> [Name] -> Q Type
+expand n0 ns = fmap simplify $ applic [] (getType n0 ns) where
+  applic :: [(Type,[Type])] -> Type -> Q Type
+  applic nts t0 = do
+    b <- t0 `contains` n0
+    if not b then return t0 else case flat t0 of
+      (TupleT _,ts) -> fmap toTuple $ mapM (applic nts) ts
+      (ConT n, ts)  ->
+        if (ConT n,ts) `elem` nts then return (ConT n0) else do
+          let rec = applic $ (ConT n,ts) : nts
+          i <- reify n
+          let fs = toTuple $ nub $ iTypes i
+          rec $ subst (zip (iParams i) ts) fs
+
+    where
+            subst nmap t1 = case t1 of
+              AppT t2 t3  -> AppT (subst nmap t2) (subst nmap t3)
+              VarT n1	-> fromMaybe t1 $ lookup n1 nmap
+              _		-> t1
+  simplify :: Type -> Type
+  simplify = toTuple . filter filt . nub . toList
+
+  filt t = case t of
+   ConT n -> n0/=n
+   AppT t1 t2 -> filt t1 && filt t2
+   _ -> True
+
+toList :: Type -> [Type]
+toList t = toList' $ flat t where
+  toList' :: (Type,[Type]) -> [Type]
+  toList' (TupleT _,ts) = concatMap toList ts
+  toList' _ = [t]
+
+toTuple :: [Type] -> Type
+toTuple [t] = t
+toTuple ts = toTuple' ts where
+  toTuple' []      = TupleT (length ts)
+  toTuple' (t:ts') = AppT (toTuple' ts') t
+  
+reTuple :: Type -> Type
+reTuple = reTuple' . toList where
+  reTuple' [] = TupleT 0
+  reTuple' [t] = t
+  reTuple' (t:ts) = AppT (AppT (TupleT 2) t) $ reTuple' ts
+
+
+iName :: Info -> Name
+iName i = case i of 
+  TyConI d -> dName d
+iTypes :: Info -> [Type]
+iTypes i = case i of 
+  TyConI d -> dTypes d
+  PrimTyConI n _ _ -> [ConT n]
+  _ -> error (show i)
+iParams :: Info -> [Name]
+iParams i = case i of 
+  TyConI d -> dParams d
+  
+
+dName d = case d of
+  DataD _ n _ _ _ -> n
+dTypes d = case d of
+  DataD _ _ _ cs _ ->  concatMap cFields cs
+  NewtypeD _ _ _ c _ -> cFields c
+  TySynD _ _ t    -> [t]
+dParams :: Dec -> [Name]
+dParams d = case d of
+  DataD _ _ ns _ _ -> ns
+  NewtypeD _ _ ns _ _ -> ns
+dConsts :: Dec -> [Con]
+dConsts d = case d of
+  DataD _ _ _ cs _ -> cs
+  NewtypeD _ _ _ c _ -> [c]
+
+cName :: Con -> Name
+cName c = case c of 
+  NormalC n sts     	-> n
+  RecC n _ 		-> n	
+  InfixC _ n _ 		-> n	
+  ForallC _ _ c1 	-> cName c1
+cId = conE . cName
+cFields :: Con -> [Type]
+cFields c = case c of 
+  NormalC n sts		-> map snd sts
+  InfixC st n st' 	-> [snd st,snd st']
+
+
+
+
+data T1 = T1
+
+
+dump :: Ppr a => a -> String
+dump = show . ppr
+
+
+type Collecting b a = StateT (Set.Set b) Q a
+collected :: (Ord b) => b -> Collecting b Bool
+collected = gets . Set.member
+
+collect :: (Ord b) => b -> Collecting b ()
+collect b = modify (Set.insert b)
+
+getCollected :: Collecting b a -> Q (Set.Set b)
+getCollected = flip execStateT Set.empty
+
+collectIf :: Ord b => b -> Collecting b () -> Collecting b ()
+collectIf b x = do
+  collected_b <- collected b
+  unless collected_b $ collect b >> x
+
+
+
+
+
+
+-- DEBUG
+topApp :: Name -> Q [Dec]
+topApp n = do
+  i@(TyConI (DataD _ _ ns _ _))  <-  reify n
+  nns1 <- replicateM (length ns) (newName "b")
+  expand n nns1 >>= error . dump
+testDimVal :: Name -> Q [Dec]
+testDimVal n = return []
+