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