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
  59 import Data.Generics.Basics
  60 import Data.Generics.Aliases
  61 import Data.Generics.Schemes
  62
  63
  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)