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