[project @ 2004-01-10 12:53:42 by panne]
[haskell-directory.git] / Data / Generics / Reify.hs
1 -----------------------------------------------------------------------------
2 -- |
3 -- Module      :  Data.Generics.Reify
4 -- Copyright   :  (c) The University of Glasgow, CWI 2001--2003
5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
6 -- 
7 -- Maintainer  :  libraries@haskell.org
8 -- Stability   :  experimental
9 -- Portability :  non-portable
10 --
11 -- \"Scrap your boilerplate\" --- Generic programming in Haskell 
12 -- See <http://www.cs.vu.nl/boilerplate/>. The present module provides
13 -- some preliminary support some sort of structural reflection. This
14 -- module is presumably less common sense that most other boilerplate
15 -- modules. Also, it is a bit less easy-going.
16 --
17 -----------------------------------------------------------------------------
18
19 module Data.Generics.Reify ( 
20
21         -- * Types as values
22         TypeVal,                -- view type "a" as "a -> ()"
23         typeVal,                -- :: TypeVal a
24         sameType,               -- two type values are the same
25         val2type,               -- :: a -> TypeVal a
26         type2val,               -- :: TypeVal a -> a
27         withType,               -- :: a -> TypeVal a -> a
28         argType,                -- :: (a -> b) -> TypeVal a
29         resType,                -- :: (a -> b) -> TypeVal b
30         paraType,               -- :: t a -> TypeVal a
31         TypeFun,                -- functions on types
32         GTypeFun,               -- polymorphic functions on types
33         extType,                -- extend a function on types
34
35         -- * Generic operations to reify terms
36         glength,
37         gcount,
38         gnodecount,
39         gtypecount,
40         gfindtype,
41
42         -- * Generic operations to reify types
43         gmapType,               -- query all constructors of a type
44         gmapConstr,             -- query all subterm types of a constructor
45         constrArity,            -- compute arity of constructor
46         gmapSubtermTypes,       -- query all subterm types of a type
47         gmapSubtermTypesConst,  -- variation on gmapSubtermTypes
48         gcountSubtermTypes,     -- count all types of immediate subterms
49         reachableType,          -- test for reachability on types
50         depthOfType,            -- compute minimum depth of type
51         depthOfConstr           -- compute minimum depth of constructor
52
53  ) where
54
55
56 ------------------------------------------------------------------------------
57
58 #ifdef __HADDOCK__
59 import Prelude
60 #endif
61 import Data.Generics.Basics
62 import Data.Generics.Aliases
63 import Data.Generics.Schemes
64
65 -------------------------------------------------------------
66 --
67 --      Types as values
68 --
69 -------------------------------------------------------------
70
71 {- 
72
73 This group provides a style of encoding types as values and using
74 them. This style is seen as an alternative to the pragmatic style used
75 in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined"
76 to denote a type argument. This pragmatic style suffers from lack
77 of robustness: one feels tempted to pattern match on undefineds.
78 Maybe Data.Typeable.typeOf etc. should be rewritten accordingly.
79
80 -}
81
82
83 -- | Type as values to stipulate use of undefineds
84 type TypeVal a = a -> ()
85
86
87 -- | The value that denotes a type
88 typeVal :: TypeVal a
89 typeVal = const ()
90
91
92 -- | Test for type equivalence
93 sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool
94 sameType tva tvb = typeOf (type2val tva) ==
95                    typeOf (type2val tvb)
96
97
98 -- | Map a value to its type
99 val2type :: a -> TypeVal a
100 val2type _ = typeVal
101
102
103 -- | Stipulate this idiom!
104 type2val :: TypeVal a -> a
105 type2val _ = undefined
106
107
108 -- | Constrain a type
109 withType :: a -> TypeVal a -> a
110 withType x _ = x
111
112
113 -- | The argument type of a function
114 argType :: (a -> b) -> TypeVal a
115 argType _ = typeVal
116
117
118 -- | The result type of a function
119 resType :: (a -> b) -> TypeVal b
120 resType _ = typeVal
121
122
123 -- | The parameter type of type constructor
124 paraType :: t a -> TypeVal a
125 paraType _ = typeVal
126
127
128 -- Type functions,
129 -- i.e., functions mapping types to values
130 --
131 type TypeFun a r = TypeVal a -> r
132
133
134
135 -- Generic type functions,
136 -- i.e., functions mapping types to values
137 --
138 type GTypeFun r  = forall a. Data a => TypeFun a r
139
140
141 -- | Extend a type function
142 extType :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r
143 extType f = maybe f id . cast
144
145
146
147 ------------------------------------------------------------------------------
148 --
149 --      Generic operations to reify terms
150 --
151 ------------------------------------------------------------------------------
152
153
154 -- | Count the number of immediate subterms of the given term
155 glength :: GenericQ Int
156 glength = length . gmapQ (const ())
157
158
159 -- | Determine the number of all suitable nodes in a given term
160 gcount :: GenericQ Bool -> GenericQ Int
161 gcount p =  everything (+) (\x -> if p x then 1 else 0)
162
163
164 -- | Determine the number of all nodes in a given term
165 gnodecount :: GenericQ Int
166 gnodecount = gcount (const True)
167
168
169 -- | Determine the number of nodes of a given type in a given term
170 gtypecount :: Typeable a => (a -> ()) -> GenericQ Int
171 gtypecount f = gcount (False `mkQ` (const True . f))
172
173
174 -- | Find (unambiguously) an immediate subterm of a given type
175 gfindtype :: (Data x, Data y) => x -> Maybe y
176 gfindtype = singleton
177           . foldl unJust []
178           . gmapQ (Nothing `mkQ` Just)
179  where
180   unJust l (Just x) = x:l
181   unJust l Nothing  = l
182   singleton [s] = Just s
183   singleton _   = Nothing
184
185
186
187 ------------------------------------------------------------------------------
188 --
189 --      Generic operations to reify types
190 --
191 ------------------------------------------------------------------------------
192
193
194 -- | Query all constructors of a given type
195
196 gmapType :: ([(Constr,r')] -> r)
197          -> GTypeFun (Constr -> r')
198          -> GTypeFun r
199
200 gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a)
201  = 
202    o $ zip cons query
203
204  where
205
206   -- All constructors of the given type
207   cons :: [Constr]
208   cons  = dataTypeCons $ dataTypeOf $ type2val t
209
210   -- Query constructors
211   query :: [r']
212   query = map (f t) cons
213
214
215 -- | Query all subterm types of a given constructor
216
217 gmapConstr :: ([r] -> r')
218            -> GTypeFun r
219            -> GTypeFun (Constr -> r')
220
221 gmapConstr (o::[r] -> r') f (t::TypeVal a) c
222  = 
223    o $ query
224
225  where
226
227   -- Term for the given constructor
228   term :: a
229   term = fromConstr c
230
231   -- Query subterm types
232   query ::  [r]
233   query = gmapQ (f . val2type) term
234
235
236 -- | Compute arity of a given constructor
237 constrArity :: GTypeFun (Constr -> Int)
238 constrArity t c = glength $ withType (fromConstr c) t
239
240
241 -- | Query all immediate subterm types of a given type
242 gmapSubtermTypes :: (Data a, Typeable r) 
243          => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r
244 gmapSubtermTypes o (r::r) f (t::TypeVal a)
245   =
246     reduce (concat (map (gmapQ (query . val2type)) terms))
247            (GTypeFun' f)
248
249  where
250
251   -- All constructors of the given type
252   cons :: [Constr]
253   cons  = dataTypeCons $ dataTypeOf $ type2val t
254
255   -- Terms for all constructors
256   terms :: [a]
257   terms =  map fromConstr cons
258
259   -- Query a subterm type
260   query :: Data b => TypeVal b -> GTypeFun' r -> (r,GTypeFun' r)
261   query t f = (unGTypeFun' f t, GTypeFun' (disable t (unGTypeFun' f)))
262
263   -- Constant out given type
264   disable :: Data b => TypeVal b -> GTypeFun r -> GTypeFun r
265   disable (t::TypeVal b) f = f `extType` \(_::TypeVal b) -> r
266
267   -- Reduce all subterm types
268   reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r
269   reduce [] _ = r
270   reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g))
271
272
273 -- First-class polymorphic variation on GTypeFun
274 newtype GTypeFun' r = GTypeFun' (GTypeFun r)
275 unGTypeFun' (GTypeFun' f) = f
276
277
278 -- | Query all immediate subterm types.
279 --   There is an extra argument to \"constant out\" the type at hand.
280 --   This can be used to avoid cycles.
281
282 gmapSubtermTypesConst :: (Data a, Typeable r)
283                       => (r -> r -> r)
284                       -> r
285                       -> GTypeFun r 
286                       -> TypeVal a 
287                       -> r
288 gmapSubtermTypesConst o (r::r) f (t::TypeVal a)
289   =
290     gmapSubtermTypes o r f' t
291   where
292     f' :: GTypeFun r
293     f' = f `extType` \(_::TypeVal a) -> r
294
295
296 -- Count all distinct subterm types
297 gcountSubtermTypes :: Data a => TypeVal a -> Int
298 gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1)
299
300
301 -- | A simplied variation on gmapSubtermTypes.
302 --   Weakness: no awareness of doubles.
303 --   Strength: easy to comprehend as it uses gmapType and gmapConstr.
304
305 _gmapSubtermTypes :: (Data a, Typeable r) 
306                   => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r
307 _gmapSubtermTypes o (r::r) f
308   =
309     gmapType otype (gmapConstr oconstr f)
310
311  where
312
313   otype :: [(Constr,r)] -> r
314   otype = foldr (\x y -> snd x `o` y) r
315
316   oconstr :: [r] -> r
317   oconstr = foldr o r
318
319
320 -- | Reachability relation on types, i.e.,
321 --   test if nodes of type @a@ are reachable from nodes of type @b@.
322 --   The relation is defined to be reflexive.
323
324 reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool
325 reachableType (a::TypeVal a) (b::TypeVal b)
326   =
327     or [ sameType a b
328        , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b
329        ]
330
331
332 -- | Depth of a datatype as the constructor with the minimum depth.
333 --   The outermost 'Nothing' denotes a type without constructors.
334 --   The innermost 'Nothing' denotes potentially infinite.
335
336 depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int))
337 depthOfType p (t::TypeVal a)
338   = 
339     gmapType o f t
340
341  where
342    
343   o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int)
344   o l = if null l then Nothing else Just (foldr1 min' l)
345
346   f :: GTypeFun (Constr -> Maybe Int)
347   f = depthOfConstr p'
348
349   -- Specific minimum operator
350   min' :: (Constr, Maybe Int) -> (Constr, Maybe Int) -> (Constr, Maybe Int)
351   min' x (_, Nothing) = x
352   min' (_, Nothing) x = x
353   min' (c, Just i) (c', Just i') | i <= i' = (c, Just i)
354   min' (c, Just i) (c', Just i')           = (c', Just i')
355
356   -- Updated predicate for unblocked types
357   p' :: GTypeFun Bool
358   p' = p `extType` \(_::TypeVal a) -> False
359
360
361 -- | Depth of a constructor.
362 --   Depth is viewed as the maximum depth of all subterm types + 1.
363 --   'Nothing' denotes potentially infinite.
364
365 depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int)
366 depthOfConstr p (t::TypeVal a) c
367   =
368     gmapConstr o f t c
369
370  where
371
372   o :: [Maybe Int] -> Maybe Int
373   o = inc' . foldr max' (Just 0)
374
375   f :: GTypeFun (Maybe Int)
376   f t' = if p t'
377             then
378                  case depthOfType p t' of
379                    Nothing     -> Just 0
380                    Just (_, x) -> x
381             else Nothing
382
383   -- Specific maximum operator
384   max' Nothing _ = Nothing
385   max' _ Nothing = Nothing
386   max' (Just i) (Just i') | i >= i' = Just i
387   max' (Just i) (Just i')           = Just i'
388
389   -- Specific increment operator
390   inc' Nothing = Nothing
391   inc' (Just i) = Just (i+1)