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  = if isPrimType $ dataTypeOf $ type2val t
 215            then []
 216            else dataCons $ dataTypeOf $ type2val t
 217
 218   -- Query constructors
 219   query :: [r']
 220   query = map (f t) cons
 221
 222
 223 -- | Query all subterm types of a given constructor
 224
 225 gmapConstr :: ([r] -> r')
 226            -> GTypeFun r
 227            -> GTypeFun (Constr -> r')
 228
 229 gmapConstr (o::[r] -> r') f (t::TypeVal a) c
 230  =
 231    o $ query
 232
 233  where
 234
 235   -- Term for the given constructor
 236   term :: a
 237   term = fromConstr c
 238
 239   -- Query subterm types
 240   query ::  [r]
 241   query = gmapQ (f . val2type) term
 242
 243
 244 -- | Compute arity of a given constructor
 245 constrArity :: GTypeFun (Constr -> Int)
 246 constrArity t c = glength $ withType (fromConstr c) t
 247
 248
 249 -- | Query all immediate subterm types of a given type
 250 gmapSubtermTypes :: (Data a, Typeable r)
 251          => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r
 252 gmapSubtermTypes o (r::r) f (t::TypeVal a)
 253   =
 254     reduce (concat (map (gmapQ (query . val2type)) terms))
 255            (GTypeFun' f)
 256
 257  where
 258
 259   -- All constructors of the given type
 260   cons :: [Constr]
 261   cons  = if isPrimType $ dataTypeOf $ type2val t
 262            then []
 263            else dataCons $ dataTypeOf $ type2val t
 264
 265   -- Terms for all constructors
 266   terms :: [a]
 267   terms =  map fromConstr cons
 268
 269   -- Query a subterm type
 270   query :: Data b => TypeVal b -> GTypeFun' r -> (r,GTypeFun' r)
 271   query t f = (unGTypeFun' f t, GTypeFun' (disable t (unGTypeFun' f)))
 272
 273   -- Constant out given type
 274   disable :: Data b => TypeVal b -> GTypeFun r -> GTypeFun r
 275   disable (t::TypeVal b) f = f `extType` \(_::TypeVal b) -> r
 276
 277   -- Reduce all subterm types
 278   reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r
 279   reduce [] _ = r
 280   reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g))
 281
 282
 283 -- First-class polymorphic variation on GTypeFun
 284 newtype GTypeFun' r = GTypeFun' (GTypeFun r)
 285 unGTypeFun' (GTypeFun' f) = f
 286
 287
 288 -- | Query all immediate subterm types.
 289 --   There is an extra argument to \"constant out\" the type at hand.
 290 --   This can be used to avoid cycles.
 291
 292 gmapSubtermTypesConst :: (Data a, Typeable r)
 293                       => (r -> r -> r)
 294                       -> r
 295                       -> GTypeFun r
 296                       -> TypeVal a
 297                       -> r
 298 gmapSubtermTypesConst o (r::r) f (t::TypeVal a)
 299   =
 300     gmapSubtermTypes o r f' t
 301   where
 302     f' :: GTypeFun r
 303     f' = f `extType` \(_::TypeVal a) -> r
 304
 305
 306 -- Count all distinct subterm types
 307 gcountSubtermTypes :: Data a => TypeVal a -> Int
 308 gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1)
 309
 310
 311 -- | A simplied variation on gmapSubtermTypes.
 312 --   Weakness: no awareness of doubles.
 313 --   Strength: easy to comprehend as it uses gmapType and gmapConstr.
 314
 315 _gmapSubtermTypes :: (Data a, Typeable r)
 316                   => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r
 317 _gmapSubtermTypes o (r::r) f
 318   =
 319     gmapType otype (gmapConstr oconstr f)
 320
 321  where
 322
 323   otype :: [(Constr,r)] -> r
 324   otype = foldr (\x y -> snd x `o` y) r
 325
 326   oconstr :: [r] -> r
 327   oconstr = foldr o r
 328
 329
 330 -- | Reachability relation on types, i.e.,
 331 --   test if nodes of type @a@ are reachable from nodes of type @b@.
 332 --   The relation is defined to be reflexive.
 333
 334 reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool
 335 reachableType (a::TypeVal a) (b::TypeVal b)
 336   =
 337     or [ sameType a b
 338        , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b
 339        ]
 340
 341
 342 -- | Depth of a datatype as the constructor with the minimum depth.
 343 --   The outermost 'Nothing' denotes a type without constructors.
 344 --   The innermost 'Nothing' denotes potentially infinite.
 345
 346 depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int))
 347 depthOfType p (t::TypeVal a)
 348   =
 349     gmapType o f t
 350
 351  where
 352
 353   o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int)
 354   o l = if null l then Nothing else Just (foldr1 min' l)
 355
 356   f :: GTypeFun (Constr -> Maybe Int)
 357   f = depthOfConstr p'
 358
 359   -- Specific minimum operator
 360   min' :: (Constr, Maybe Int) -> (Constr, Maybe Int) -> (Constr, Maybe Int)
 361   min' x (_, Nothing) = x
 362   min' (_, Nothing) x = x
 363   min' (c, Just i) (c', Just i') | i <= i' = (c, Just i)
 364   min' (c, Just i) (c', Just i')           = (c', Just i')
 365
 366   -- Updated predicate for unblocked types
 367   p' :: GTypeFun Bool
 368   p' = p `extType` \(_::TypeVal a) -> False
 369
 370
 371 -- | Depth of a constructor.
 372 --   Depth is viewed as the maximum depth of all subterm types + 1.
 373 --   'Nothing' denotes potentially infinite.
 374
 375 depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int)
 376 depthOfConstr p (t::TypeVal a) c
 377   =
 378     gmapConstr o f t c
 379
 380  where
 381
 382   o :: [Maybe Int] -> Maybe Int
 383   o = inc' . foldr max' (Just 0)
 384
 385   f :: GTypeFun (Maybe Int)
 386   f t' = if p t'
 387             then
 388                  case depthOfType p t' of
 389                    Nothing     -> Just 0
 390                    Just (_, x) -> x
 391             else Nothing
 392
 393   -- Specific maximum operator
 394   max' Nothing _ = Nothing
 395   max' _ Nothing = Nothing
 396   max' (Just i) (Just i') | i >= i' = Just i
 397   max' (Just i) (Just i')           = Just i'
 398
 399   -- Specific increment operator
 400   inc' Nothing = Nothing
 401   inc' (Just i) = Just (i+1)