Data/Typeable.hs

   1 {-# OPTIONS -fno-implicit-prelude #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  Data.Typeable
   5 -- Copyright   :  (c) The University of Glasgow 2001
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  experimental
  10 -- Portability :  portable
  11 --
  12 -- The Typeable class reifies types to some extent by associating type
  13 -- representations to types. These type representations can be compared,
  14 -- and one can in turn define a type-safe cast operation. To this end,
  15 -- an unsafe cast is guarded by a test for type (representation)
  16 -- equivalence. The module Data.Dynamic uses Typeable for an
  17 -- implementation of dynamics. The module Data.Generics uses Typeable
  18 -- and type-safe cast (but not dynamics) to support the "Scrap your
  19 -- boilerplate" style of generic programming.
  20 --
  21 -----------------------------------------------------------------------------
  22
  23 module Data.Typeable
  24   (
  25
  26         -- * The Typeable class
  27         Typeable( typeOf ),     -- :: a -> TypeRep
  28
  29         -- * Type-safe cast and other clients
  30         cast,                   -- :: (Typeable a, Typeable b) => a -> Maybe b
  31         sameType,               -- two type values are the same
  32
  33         -- * Type representations
  34         TypeRep,        -- abstract, instance of: Eq, Show, Typeable
  35         TyCon,          -- abstract, instance of: Eq, Show, Typeable
  36
  37         -- * Construction of type representations
  38         mkTyCon,        -- :: String  -> TyCon
  39         mkAppTy,        -- :: TyCon   -> [TypeRep] -> TypeRep
  40         mkFunTy,        -- :: TypeRep -> TypeRep   -> TypeRep
  41         applyTy,        -- :: TypeRep -> TypeRep   -> Maybe TypeRep
  42
  43         -- * Types as values
  44         TypeVal,                -- view type "a" as "a -> ()"
  45         typeVal,                -- :: TypeVal a
  46         typeValOf,              -- :: a -> TypeVal a
  47         undefinedType,          -- :: TypeVal a -> a
  48         withType,               -- :: a -> TypeVal a -> a
  49         argType,                -- :: (a -> b) -> TypeVal a
  50         resType,                -- :: (a -> b) -> TypeVal b
  51         paraType,               -- :: t a -> TypeVal a
  52         TypeFun                 -- functions on types
  53
  54   ) where
  55
  56
  57 import qualified Data.HashTable as HT
  58 import Data.Maybe
  59 import Data.Either
  60 import Data.Int
  61 import Data.Word
  62 import Data.List( foldl )
  63
  64 #ifdef __GLASGOW_HASKELL__
  65 import GHC.Base
  66 import GHC.Show
  67 import GHC.Err
  68 import GHC.Num
  69 import GHC.Float
  70 import GHC.Real( rem, Ratio )
  71 import GHC.IOBase
  72 import GHC.Ptr          -- So we can give Typeable instance for Ptr
  73 import GHC.Stable       -- So we can give Typeable instance for StablePtr
  74 #endif
  75
  76 #ifdef __HUGS__
  77 import Hugs.Prelude
  78 import Hugs.IO
  79 import Hugs.IORef
  80 import Hugs.IOExts
  81 #endif
  82
  83 #ifdef __GLASGOW_HASKELL__
  84 unsafeCoerce :: a -> b
  85 unsafeCoerce = unsafeCoerce#
  86 #endif
  87
  88 #ifdef __NHC__
  89 import NonStdUnsafeCoerce (unsafeCoerce)
  90 import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
  91 #else
  92 #include "Typeable.h"
  93 #endif
  94
  95
  96 #ifndef __HUGS__
  97 -------------------------------------------------------------
  98 --
  99 --              Type representations
 100 --
 101 -------------------------------------------------------------
 102
 103
 104 -- | A concrete representation of a (monomorphic) type.  'TypeRep'
 105 -- supports reasonably efficient equality.
 106 data TypeRep = TypeRep !Key TyCon [TypeRep]
 107
 108 -- Compare keys for equality
 109 instance Eq TypeRep where
 110   (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
 111
 112 -- | An abstract representation of a type constructor.  'TyCon' objects can
 113 -- be built using 'mkTyCon'.
 114 data TyCon = TyCon !Key String
 115
 116 instance Eq TyCon where
 117   (TyCon t1 _) == (TyCon t2 _) = t1 == t2
 118
 119 #endif
 120
 121         --
 122         -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
 123         --                                 [fTy,fTy,fTy])
 124         --
 125         -- returns "(Foo,Foo,Foo)"
 126         --
 127         -- The TypeRep Show instance promises to print tuple types
 128         -- correctly. Tuple type constructors are specified by a
 129         -- sequence of commas, e.g., (mkTyCon ",,,,") returns
 130         -- the 5-tuple tycon.
 131
 132 ----------------- Construction --------------------
 133
 134 -- | Applies a type constructor to a sequence of types
 135 mkAppTy  :: TyCon -> [TypeRep] -> TypeRep
 136 mkAppTy tc@(TyCon tc_k _) args
 137   = TypeRep (appKeys tc_k arg_ks) tc args
 138   where
 139     arg_ks = [k | TypeRep k _ _ <- args]
 140
 141 funTc :: TyCon
 142 funTc = mkTyCon "->"
 143
 144 -- | A special case of 'mkAppTy', which applies the function
 145 -- type constructor to a pair of types.
 146 mkFunTy  :: TypeRep -> TypeRep -> TypeRep
 147 mkFunTy f a = mkAppTy funTc [f,a]
 148
 149 -- | Applies a type to a function type.  Returns: @'Just' u@ if the
 150 -- first argument represents a function of type @t -> u@ and the
 151 -- second argument represents a function of type @t@.  Otherwise,
 152 -- returns 'Nothing'.
 153 applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
 154 applyTy (TypeRep _ tc [t1,t2]) t3
 155   | tc == funTc && t1 == t3     = Just t2
 156 applyTy _ _                     = Nothing
 157
 158 -- If we enforce the restriction that there is only one
 159 -- @TyCon@ for a type & it is shared among all its uses,
 160 -- we can map them onto Ints very simply. The benefit is,
 161 -- of course, that @TyCon@s can then be compared efficiently.
 162
 163 -- Provided the implementor of other @Typeable@ instances
 164 -- takes care of making all the @TyCon@s CAFs (toplevel constants),
 165 -- this will work.
 166
 167 -- If this constraint does turn out to be a sore thumb, changing
 168 -- the Eq instance for TyCons is trivial.
 169
 170 -- | Builds a 'TyCon' object representing a type constructor.  An
 171 -- implementation of "Data.Typeable" should ensure that the following holds:
 172 --
 173 -- >  mkTyCon "a" == mkTyCon "a"
 174 --
 175
 176 mkTyCon :: String       -- ^ the name of the type constructor (should be unique
 177                         -- in the program, so it might be wise to use the
 178                         -- fully qualified name).
 179         -> TyCon        -- ^ A unique 'TyCon' object
 180 mkTyCon str = TyCon (mkTyConKey str) str
 181
 182
 183
 184 ----------------- Showing TypeReps --------------------
 185
 186 instance Show TypeRep where
 187   showsPrec p (TypeRep _ tycon tys) =
 188     case tys of
 189       [] -> showsPrec p tycon
 190       [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'
 191       [a,r] | tycon == funTc  -> showParen (p > 8) $
 192                                  showsPrec 9 a . showString " -> " . showsPrec 8 r
 193       xs | isTupleTyCon tycon -> showTuple tycon xs
 194          | otherwise         ->
 195             showParen (p > 9) $
 196             showsPrec p tycon .
 197             showChar ' '      .
 198             showArgs tys
 199
 200 instance Show TyCon where
 201   showsPrec _ (TyCon _ s) = showString s
 202
 203 isTupleTyCon :: TyCon -> Bool
 204 isTupleTyCon (TyCon _ (',':_)) = True
 205 isTupleTyCon _                 = False
 206
 207 -- Some (Show.TypeRep) helpers:
 208
 209 showArgs :: Show a => [a] -> ShowS
 210 showArgs [] = id
 211 showArgs [a] = showsPrec 10 a
 212 showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
 213
 214 showTuple :: TyCon -> [TypeRep] -> ShowS
 215 showTuple (TyCon _ str) args = showChar '(' . go str args
 216  where
 217   go [] [a] = showsPrec 10 a . showChar ')'
 218   go _  []  = showChar ')' -- a failure condition, really.
 219   go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
 220   go _ _   = showChar ')'
 221
 222
 223 -------------------------------------------------------------
 224 --
 225 --      The Typeable class
 226 --
 227 -------------------------------------------------------------
 228
 229 -- | The class 'Typeable' allows a concrete representation of a type to
 230 -- be calculated.
 231 class Typeable a where
 232   typeOf :: a -> TypeRep
 233   -- ^ Takes a value of type @a@ and returns a concrete representation
 234   -- of that type.  The /value/ of the argument should be ignored by
 235   -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
 236   -- the argument.
 237
 238
 239 -------------------------------------------------------------
 240 --
 241 --              Type-safe cast and other clients
 242 --
 243 -------------------------------------------------------------
 244
 245 -- | The type-safe cast operation
 246 cast :: (Typeable a, Typeable b) => a -> Maybe b
 247 cast x = r
 248        where
 249          r = if typeOf x == typeOf (fromJust r) then
 250                         Just (unsafeCoerce x)
 251              else
 252                         Nothing
 253
 254
 255 -- | Test for type equivalence
 256 sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool
 257 sameType tva tvb = typeOf (undefinedType tva) ==
 258                    typeOf (undefinedType tvb)
 259
 260
 261 -------------------------------------------------------------
 262 --
 263 --      Instances of the Typeable class for Prelude types
 264 --
 265 -------------------------------------------------------------
 266
 267 listTc :: TyCon
 268 listTc = mkTyCon "[]"
 269
 270 instance Typeable a => Typeable [a] where
 271   typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)]
 272         -- In GHC we can say
 273         --      typeOf (undefined :: a)
 274         -- using scoped type variables, but we use the
 275         -- more verbose form here, for compatibility with Hugs
 276
 277 unitTc :: TyCon
 278 unitTc = mkTyCon "()"
 279
 280 instance Typeable () where
 281   typeOf _ = mkAppTy unitTc []
 282
 283 tup2Tc :: TyCon
 284 tup2Tc = mkTyCon ","
 285
 286 instance (Typeable a, Typeable b) => Typeable (a,b) where
 287   typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
 288                               typeOf ((undefined :: (a,b) -> b) tu)]
 289
 290 tup3Tc :: TyCon
 291 tup3Tc = mkTyCon ",,"
 292
 293 instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
 294   typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
 295                               typeOf ((undefined :: (a,b,c) -> b) tu),
 296                               typeOf ((undefined :: (a,b,c) -> c) tu)]
 297
 298 tup4Tc :: TyCon
 299 tup4Tc = mkTyCon ",,,"
 300
 301 instance ( Typeable a
 302          , Typeable b
 303          , Typeable c
 304          , Typeable d) => Typeable (a,b,c,d) where
 305   typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
 306                               typeOf ((undefined :: (a,b,c,d) -> b) tu),
 307                               typeOf ((undefined :: (a,b,c,d) -> c) tu),
 308                               typeOf ((undefined :: (a,b,c,d) -> d) tu)]
 309 tup5Tc :: TyCon
 310 tup5Tc = mkTyCon ",,,,"
 311
 312 instance ( Typeable a
 313          , Typeable b
 314          , Typeable c
 315          , Typeable d
 316          , Typeable e) => Typeable (a,b,c,d,e) where
 317   typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
 318                               typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
 319                               typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
 320                               typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
 321                               typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
 322
 323 instance (Typeable a, Typeable b) => Typeable (a -> b) where
 324   typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
 325                      (typeOf ((undefined :: (a -> b) -> b) f))
 326
 327
 328 -------------------------------------------------------------
 329 --
 330 --      Types as values
 331 --
 332 -------------------------------------------------------------
 333
 334 {-
 335
 336 This group provides a style of encoding types as values and using
 337 them. This style is seen as an alternative to the pragmatic style used
 338 in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined"
 339 to denote a type argument. This pragmatic style suffers from lack
 340 of robustness: one feels tempted to pattern match on undefineds.
 341 Maybe Data.Typeable.typeOf etc. should be rewritten accordingly.
 342
 343 -}
 344
 345
 346 -- | Type as values to stipulate use of undefineds
 347 type TypeVal a = a -> ()
 348
 349
 350 -- | The value that denotes a type
 351 typeVal :: TypeVal a
 352 typeVal = const ()
 353
 354
 355 -- | Map a value to its type
 356 typeValOf :: a -> TypeVal a
 357 typeValOf _ = typeVal
 358
 359
 360 -- | Stipulate this idiom!
 361 undefinedType :: TypeVal a -> a
 362 undefinedType _ = undefined
 363
 364
 365 -- | Constrain a type
 366 withType :: a -> TypeVal a -> a
 367 withType x _ = x
 368
 369
 370 -- | The argument type of a function
 371 argType :: (a -> b) -> TypeVal a
 372 argType _ = typeVal
 373
 374
 375 -- | The result type of a function
 376 resType :: (a -> b) -> TypeVal b
 377 resType _ = typeVal
 378
 379
 380 -- | The parameter type of type constructor
 381 paraType :: t a -> TypeVal a
 382 paraType _ = typeVal
 383
 384
 385 -- Type functions,
 386 -- i.e., functions mapping types to values
 387 --
 388 type TypeFun a r = TypeVal a -> r
 389
 390
 391
 392 -------------------------------------------------------
 393 --
 394 -- Generate Typeable instances for standard datatypes
 395 --
 396 -------------------------------------------------------
 397
 398 #ifndef __NHC__
 399 INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
 400 INSTANCE_TYPEABLE0(Char,charTc,"Char")
 401 INSTANCE_TYPEABLE0(Float,floatTc,"Float")
 402 INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
 403 INSTANCE_TYPEABLE0(Int,intTc,"Int")
 404 INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
 405 INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
 406 INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
 407 INSTANCE_TYPEABLE1(IO,ioTc,"IO")
 408 INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
 409 INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
 410 INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
 411 INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
 412 INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
 413
 414 INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
 415 INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
 416 INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
 417 INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
 418
 419 INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
 420 INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
 421 INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
 422 INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
 423
 424 INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
 425 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
 426
 427 INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
 428 #endif
 429
 430
 431 ---------------------------------------------
 432 --
 433 --              Internals
 434 --
 435 ---------------------------------------------
 436
 437 #ifndef __HUGS__
 438 newtype Key = Key Int deriving( Eq )
 439 #endif
 440
 441 data KeyPr = KeyPr !Key !Key deriving( Eq )
 442
 443 hashKP :: KeyPr -> Int32
 444 hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
 445
 446 data Cache = Cache { next_key :: !(IORef Key),
 447                      tc_tbl   :: !(HT.HashTable String Key),
 448                      ap_tbl   :: !(HT.HashTable KeyPr Key) }
 449
 450 {-# NOINLINE cache #-}
 451 cache :: Cache
 452 cache = unsafePerformIO $ do
 453                 empty_tc_tbl <- HT.new (==) HT.hashString
 454                 empty_ap_tbl <- HT.new (==) hashKP
 455                 key_loc      <- newIORef (Key 1)
 456                 return (Cache { next_key = key_loc,
 457                                 tc_tbl = empty_tc_tbl,
 458                                 ap_tbl = empty_ap_tbl })
 459
 460 newKey :: IORef Key -> IO Key
 461 newKey kloc = do { k@(Key i) <- readIORef kloc ;
 462                    writeIORef kloc (Key (i+1)) ;
 463                    return k }
 464
 465 mkTyConKey :: String -> Key
 466 mkTyConKey str
 467   = unsafePerformIO $ do
 468         let Cache {next_key = kloc, tc_tbl = tbl} = cache
 469         mb_k <- HT.lookup tbl str
 470         case mb_k of
 471           Just k  -> return k
 472           Nothing -> do { k <- newKey kloc ;
 473                           HT.insert tbl str k ;
 474                           return k }
 475
 476 appKey :: Key -> Key -> Key
 477 appKey k1 k2
 478   = unsafePerformIO $ do
 479         let Cache {next_key = kloc, ap_tbl = tbl} = cache
 480         mb_k <- HT.lookup tbl kpr
 481         case mb_k of
 482           Just k  -> return k
 483           Nothing -> do { k <- newKey kloc ;
 484                           HT.insert tbl kpr k ;
 485                           return k }
 486   where
 487     kpr = KeyPr k1 k2
 488
 489 appKeys :: Key -> [Key] -> Key
 490 appKeys k ks = foldl appKey k ks