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