1 -----------------------------------------------------------------------------
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)
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : non-portable
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.
17 -----------------------------------------------------------------------------
19 module Data.Generics.Reify (
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
35 -- * Generic operations to reify terms
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
56 ------------------------------------------------------------------------------
61 import Data.Generics.Basics
62 import Data.Generics.Aliases
63 import Data.Generics.Schemes
65 -------------------------------------------------------------
69 -------------------------------------------------------------
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.
83 -- | Type as values to stipulate use of undefineds
84 type TypeVal a = a -> ()
87 -- | The value that denotes a type
92 -- | Test for type equivalence
93 sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool
94 sameType tva tvb = typeOf (type2val tva) ==
98 -- | Map a value to its type
99 val2type :: a -> TypeVal a
103 -- | Stipulate this idiom!
104 type2val :: TypeVal a -> a
105 type2val _ = undefined
108 -- | Constrain a type
109 withType :: a -> TypeVal a -> a
113 -- | The argument type of a function
114 argType :: (a -> b) -> TypeVal a
118 -- | The result type of a function
119 resType :: (a -> b) -> TypeVal b
123 -- | The parameter type of type constructor
124 paraType :: t a -> TypeVal a
129 -- i.e., functions mapping types to values
131 type TypeFun a r = TypeVal a -> r
135 -- Generic type functions,
136 -- i.e., functions mapping types to values
138 type GTypeFun r = forall a. Data a => TypeFun a r
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
147 ------------------------------------------------------------------------------
149 -- Generic operations to reify terms
151 ------------------------------------------------------------------------------
154 -- | Count the number of immediate subterms of the given term
155 glength :: GenericQ Int
156 glength = length . gmapQ (const ())
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)
164 -- | Determine the number of all nodes in a given term
165 gnodecount :: GenericQ Int
166 gnodecount = gcount (const True)
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))
174 -- | Find (unambiguously) an immediate subterm of a given type
175 gfindtype :: (Data x, Data y) => x -> Maybe y
176 gfindtype = singleton
178 . gmapQ (Nothing `mkQ` Just)
180 unJust l (Just x) = x:l
182 singleton [s] = Just s
183 singleton _ = Nothing
187 ------------------------------------------------------------------------------
189 -- Generic operations to reify types
191 ------------------------------------------------------------------------------
194 -- | Query all constructors of a given type
196 gmapType :: ([(Constr,r')] -> r)
197 -> GTypeFun (Constr -> r')
200 gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a)
206 -- All constructors of the given type
208 cons = dataTypeCons $ dataTypeOf $ type2val t
210 -- Query constructors
212 query = map (f t) cons
215 -- | Query all subterm types of a given constructor
217 gmapConstr :: ([r] -> r')
219 -> GTypeFun (Constr -> r')
221 gmapConstr (o::[r] -> r') f (t::TypeVal a) c
227 -- Term for the given constructor
231 -- Query subterm types
233 query = gmapQ (f . val2type) term
236 -- | Compute arity of a given constructor
237 constrArity :: GTypeFun (Constr -> Int)
238 constrArity t c = glength $ withType (fromConstr c) t
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)
246 reduce (concat (map (gmapQ (query . val2type)) terms))
251 -- All constructors of the given type
253 cons = dataTypeCons $ dataTypeOf $ type2val t
255 -- Terms for all constructors
257 terms = map fromConstr cons
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)))
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
267 -- Reduce all subterm types
268 reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r
270 reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g))
273 -- First-class polymorphic variation on GTypeFun
274 newtype GTypeFun' r = GTypeFun' (GTypeFun r)
275 unGTypeFun' (GTypeFun' f) = f
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.
282 gmapSubtermTypesConst :: (Data a, Typeable r)
288 gmapSubtermTypesConst o (r::r) f (t::TypeVal a)
290 gmapSubtermTypes o r f' t
293 f' = f `extType` \(_::TypeVal a) -> r
296 -- Count all distinct subterm types
297 gcountSubtermTypes :: Data a => TypeVal a -> Int
298 gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1)
301 -- | A simplied variation on gmapSubtermTypes.
302 -- Weakness: no awareness of doubles.
303 -- Strength: easy to comprehend as it uses gmapType and gmapConstr.
305 _gmapSubtermTypes :: (Data a, Typeable r)
306 => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r
307 _gmapSubtermTypes o (r::r) f
309 gmapType otype (gmapConstr oconstr f)
313 otype :: [(Constr,r)] -> r
314 otype = foldr (\x y -> snd x `o` y) r
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.
324 reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool
325 reachableType (a::TypeVal a) (b::TypeVal b)
328 , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b
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.
336 depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int))
337 depthOfType p (t::TypeVal a)
343 o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int)
344 o l = if null l then Nothing else Just (foldr1 min' l)
346 f :: GTypeFun (Constr -> Maybe Int)
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')
356 -- Updated predicate for unblocked types
358 p' = p `extType` \(_::TypeVal a) -> False
361 -- | Depth of a constructor.
362 -- Depth is viewed as the maximum depth of all subterm types + 1.
363 -- 'Nothing' denotes potentially infinite.
365 depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int)
366 depthOfConstr p (t::TypeVal a) c
372 o :: [Maybe Int] -> Maybe Int
373 o = inc' . foldr max' (Just 0)
375 f :: GTypeFun (Maybe Int)
378 case depthOfType p t' of
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'
389 -- Specific increment operator
390 inc' Nothing = Nothing
391 inc' (Just i) = Just (i+1)