1{-# OPTIONS -fglasgow-exts #-}
2
3module Twin (tests) where
4
5{-
6
7For the discussion in the 2nd boilerplate paper,
8we favour some simplified development of twin traversal.
9So the full general, stepwise story is in Data.Generics.Twin,
10but the short version from the paper is turned into a test
11case below.
12
13See the paper for an explanation.
14
15-}
16
17import Test.Tasty.HUnit
18
19import Data.Generics hiding (GQ,gzipWithQ,geq)
20
21geq' :: GenericQ (GenericQ Bool)
22geq' x y =  toConstr x == toConstr y
23         && and (gzipWithQ geq' x y)
24
25geq :: Data a => a -> a -> Bool
26geq a = geq' a
27
28newtype GQ r = GQ (GenericQ r)
29
30gzipWithQ :: GenericQ (GenericQ r)
31          -> GenericQ (GenericQ [r])
32gzipWithQ f t1 t2
33    = gApplyQ (gmapQ (\x -> GQ (f x)) t1) t2
34
35gApplyQ :: Data a => [GQ r] -> a -> [r]
36gApplyQ qs t = reverse (snd (gfoldlQ k z t))
37    where
38      k :: ([GQ r], [r]) -> GenericQ ([GQ r], [r])
39      k (GQ q : qs, rs) child = (qs, q child : rs)
40      z = (qs, [])
41
42newtype R r x = R { unR :: r }
43
44gfoldlQ :: (r -> GenericQ r)
45        -> r
46        -> GenericQ r
47
48gfoldlQ k z t = unR (gfoldl k' z' t)
49    where
50      z' _ = R z
51      k' (R r) c = R (k r c)
52
53-----------------------------------------------------------------------------
54
55-- A dependently polymorphic geq
56geq'' :: Data a => a -> a -> Bool
57geq'' x y =  toConstr x == toConstr y
58          && and (gzipWithQ' geq'' x y)
59
60-- A helper type for existentially quantified queries
61data XQ r = forall a. Data a => XQ (a -> r)
62
63-- A dependently polymorphic gzipWithQ
64gzipWithQ' :: (forall a. Data a => a -> a -> r)
65           -> (forall a. Data a => a -> a -> [r])
66gzipWithQ' f t1 t2
67    = gApplyQ' (gmapQ (\x -> XQ (f x)) t1) t2
68
69-- Apply existentially quantified queries
70-- Insist on equal types!
71--
72gApplyQ' :: Data a => [XQ r] -> a -> [r]
73gApplyQ' qs t = reverse (snd (gfoldlQ k z t))
74    where
75      z = (qs, [])
76      k :: ([XQ r], [r]) -> GenericQ ([XQ r], [r])
77      k (XQ q : qs, rs) child = (qs, q' child : rs)
78        where
79          q' = error "Twin mismatch" `extQ` q
80
81
82-----------------------------------------------------------------------------
83
84tests = ( geq   [True,True] [True,True]
85        , geq   [True,True] [True,False]
86        , geq'' [True,True] [True,True]
87        , geq'' [True,True] [True,False]
88        ) @=? output
89
90output = (True,False,True,False)
91