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.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 = geq' 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