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