1{-# OPTIONS -fglasgow-exts #-}
2{-# LANGUAGE CPP #-}
3
4module Ext1 (tests) where
5
6{-
7
8This example records some experiments with polymorphic datatypes.
9
10-}
11
12import Test.HUnit
13
14import Data.Generics
15#if MIN_VERSION_base(4,8,0)
16import GHC.Base hiding(foldr)
17#else
18import GHC.Base
19#endif
20
21-- Unsafe coerce
22unsafeCoerce :: a -> b
23unsafeCoerce = unsafeCoerce#
24
25
26-- Handy type constructors
27newtype ID x = ID { unID :: x }
28newtype CONST c a = CONST { unCONST :: c }
29
30
31-- Extension of a query with a para. poly. list case
32extListQ' :: Data d
33          => (d -> q)
34          -> (forall d. [d] -> q)
35          -> d -> q
36extListQ' def ext d =
37  if isList d
38    then ext (unsafeCoerce d)
39    else def d
40
41
42-- Test extListQ'
43foo1 :: Data d => d -> Int
44foo1 = const 0 `extListQ'` length
45t1 = foo1 True -- should count as 0
46t2 = foo1 [True,True] -- should count as 2
47
48
49-- Infeasible extension of a query with a data-polymorphic list case
50extListQ'' :: Data d
51           => (d -> q)
52           -> (forall d. Data d => [d] -> q)
53           -> d -> q
54extListQ'' def ext d =
55  if isList d
56    then undefined -- hard to avoid an ambiguous type
57    else def d
58
59
60-- Test extListQ from Data.Generics.Aliases
61foo2 :: Data a => a -> Int
62foo2 = const 0 `ext1Q` list
63 where
64  list :: Data a => [a] -> Int
65  list l = foldr (+) 0 $ map glength l
66
67t3 = foo2 (True,True) -- should count as 0
68t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4
69
70
71-- Customisation for lists without type cast
72foo3 :: Data a => a -> Int
73foo3 x = if isList x
74          then foldr (+) 0 $ gmapListQ glength x
75          else 0
76
77t5 = foo3 (True,True) -- should count as 0
78t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4
79
80
81-- Test for list datatype
82isList :: Data a => a -> Bool
83isList x = typeRepTyCon (typeOf x) ==
84           typeRepTyCon (typeOf (undefined::[()]))
85
86
87-- Test for nil
88isNil :: Data a => a -> Bool
89isNil x = toConstr x == toConstr ([]::[()])
90
91
92-- Test for cons
93isCons :: Data a => a -> Bool
94isCons x = toConstr x == toConstr (():[])
95
96
97-- gmapQ for polymorphic lists
98gmapListQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> [q]
99gmapListQ f x =
100  if not $ isList x
101    then error "gmapListQ"
102    else if isNil x
103           then []
104           else if isCons x
105                  then ( gmapQi 0 f x : gmapQi 1 (gmapListQ f) x )
106                  else error "gmapListQ"
107
108
109-- Build nil
110mkNil :: Data a => a
111mkNil = fromConstr $ toConstr ([]::[()])
112
113
114-- Build cons
115mkCons :: Data a => a
116mkCons = fromConstr $ toConstr ((undefined:undefined)::[()])
117
118
119-- Main function for testing
120tests = ( t1
121        , ( t2
122        , ( t3
123        , ( t4
124        , ( t5
125        , ( t6
126        )))))) ~=? output
127
128output = (0,(2,(0,(4,(0,4)))))
129