summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJonasDuregard <>2010-02-17 11:44:59 (GMT)
committerLuite Stegeman <luite@luite.com>2010-02-17 11:44:59 (GMT)
commit34211e92e27d94737cbda62e83122f1958f35119 (patch)
tree4be8733e30434856fff6291108e7182b2c2e6726
version 0.1.10.1.1
-rw-r--r--Agata.cabal27
-rw-r--r--Example.hs17
-rw-r--r--LICENSE26
-rw-r--r--Setup.hs2
-rw-r--r--Test/Agata.hs12
-rw-r--r--Test/Agata/Base.hs272
-rw-r--r--Test/Agata/Common.hs58
-rw-r--r--Test/Agata/Instances.hs126
-rw-r--r--Test/Agata/Related.hs84
-rw-r--r--Test/Agata/Strategies.hs50
-rw-r--r--Test/AgataTH.hs303
11 files changed, 977 insertions, 0 deletions
diff --git a/Agata.cabal b/Agata.cabal
new file mode 100644
index 0000000..99ea164
--- /dev/null
+++ b/Agata.cabal
@@ -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 \ No newline at end of file
diff --git a/Example.hs b/Example.hs
new file mode 100644
index 0000000..5c7590c
--- /dev/null
+++ b/Example.hs
@@ -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))
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..a506429
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,26 @@
+Copyright (c) 2000-2006, Jonas Duregrd
+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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..c2d38c4
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain \ No newline at end of file
diff --git a/Test/Agata.hs b/Test/Agata.hs
new file mode 100644
index 0000000..a948b9c
--- /dev/null
+++ b/Test/Agata.hs
@@ -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 \ No newline at end of file
diff --git a/Test/Agata/Base.hs b/Test/Agata/Base.hs
new file mode 100644
index 0000000..433a290
--- /dev/null
+++ b/Test/Agata/Base.hs
@@ -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
+
+
+
diff --git a/Test/Agata/Common.hs b/Test/Agata/Common.hs
new file mode 100644
index 0000000..6ca0992
--- /dev/null
+++ b/Test/Agata/Common.hs
@@ -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)) \ No newline at end of file
diff --git a/Test/Agata/Instances.hs b/Test/Agata/Instances.hs
new file mode 100644
index 0000000..783c1dd
--- /dev/null
+++ b/Test/Agata/Instances.hs
@@ -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
+
diff --git a/Test/Agata/Related.hs b/Test/Agata/Related.hs
new file mode 100644
index 0000000..06aba42
--- /dev/null
+++ b/Test/Agata/Related.hs
@@ -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
+
diff --git a/Test/Agata/Strategies.hs b/Test/Agata/Strategies.hs
new file mode 100644
index 0000000..6fc8636
--- /dev/null
+++ b/Test/Agata/Strategies.hs
@@ -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
diff --git a/Test/AgataTH.hs b/Test/AgataTH.hs
new file mode 100644
index 0000000..c44697a
--- /dev/null
+++ b/Test/AgataTH.hs
@@ -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 []
+