1{-# OPTIONS -fglasgow-exts #-}
2
3module GenUpTo (tests) where
4
5{-
6
7This example illustrate test-set generation,
8namely all terms of a given depth are generated.
9
10-}
11
12import Test.Tasty.HUnit
13
14import Data.Generics
15
16
17{-
18
19The following datatypes comprise the abstract syntax of a simple
20imperative language. Some provisions are such that the discussion
21of test-set generation is simplified. In particular, we do not
22consider anything but monomorphic *data*types --- no primitive
23types, no tuples, ...
24
25-}
26
27data Prog = Prog Dec Stat
28            deriving (Show, Eq, Typeable, Data)
29
30data Dec  = Nodec
31          | Ondec Id Type
32          | Manydecs Dec Dec
33            deriving (Show, Eq, Typeable, Data)
34
35data Id = A | B
36          deriving (Show, Eq, Typeable, Data)
37
38data Type = Int | Bool
39            deriving (Show, Eq, Typeable, Data)
40
41data Stat = Noop
42          | Assign Id Exp
43          | Seq Stat Stat
44            deriving (Show, Eq, Typeable, Data)
45
46data Exp = Zero
47         | Succ Exp
48           deriving (Show, Eq, Typeable, Data)
49
50
51-- Generate all terms of a given depth
52genUpTo :: Data a => Int -> [a]
53genUpTo 0 = []
54genUpTo d = result
55   where
56     -- Getting hold of the result (type)
57     result = concat (map recurse cons)
58
59     -- Retrieve constructors of the requested type
60     cons :: [Constr]
61     cons = dataTypeConstrs (dataTypeOf (head result))
62
63     -- Find all terms headed by a specific Constr
64     recurse :: Data a => Constr -> [a]
65     recurse con = gmapM (\_ -> genUpTo (d-1))
66                         (fromConstr con)
67
68     -- We could also deal with primitive types easily.
69     -- Then we had to use cons' instead of cons.
70     --
71     cons' :: [Constr]
72     cons' = case dataTypeRep ty of
73              AlgRep cons -> cons
74              IntRep      -> [mkIntegralConstr ty 0]
75              FloatRep    -> [mkIntegralConstr ty 0]
76              CharRep     -> [mkCharConstr ty 'x']
77      where
78        ty = dataTypeOf (head result)
79
80
81-- For silly tests
82data T0 = T0 T1 T2 T3 deriving (Show, Eq, Typeable, Data)
83data T1 = T1a | T1b   deriving (Show, Eq, Typeable, Data)
84data T2 = T2a | T2b   deriving (Show, Eq, Typeable, Data)
85data T3 = T3a | T3b   deriving (Show, Eq, Typeable, Data)
86
87tests = (   genUpTo 0 :: [Id]
88        , ( genUpTo 1 :: [Id]
89        , ( genUpTo 2 :: [Id]
90        , ( genUpTo 2 :: [T0]
91        , ( genUpTo 3 :: [Prog]
92        ))))) @=? output
93
94output = ([],([A,B],([A,B],([T0 T1a T2a T3a,T0 T1a T2a T3b,T0 T1a T2b T3a,T0 T1a T2b T3b,T0 T1b T2a T3a,T0 T1b T2a T3b,T0 T1b T2b T3a,T0 T1b T2b T3b],[Prog Nodec Noop,Prog Nodec (Assign A Zero),Prog Nodec (Assign B Zero),Prog Nodec (Seq Noop Noop),Prog (Ondec A Int) Noop,Prog (Ondec A Int) (Assign A Zero),Prog (Ondec A Int) (Assign B Zero),Prog (Ondec A Int) (Seq Noop Noop),Prog (Ondec A Bool) Noop,Prog (Ondec A Bool) (Assign A Zero),Prog (Ondec A Bool) (Assign B Zero),Prog (Ondec A Bool) (Seq Noop Noop),Prog (Ondec B Int) Noop,Prog (Ondec B Int) (Assign A Zero),Prog (Ondec B Int) (Assign B Zero),Prog (Ondec B Int) (Seq Noop Noop),Prog (Ondec B Bool) Noop,Prog (Ondec B Bool) (Assign A Zero),Prog (Ondec B Bool) (Assign B Zero),Prog (Ondec B Bool) (Seq Noop Noop),Prog (Manydecs Nodec Nodec) Noop,Prog (Manydecs Nodec Nodec) (Assign A Zero),Prog (Manydecs Nodec Nodec) (Assign B Zero),Prog (Manydecs Nodec Nodec) (Seq Noop Noop)]))))
95