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