ghc/lib/exts/Dynamic.lhs

   1 %
   2 % (c) AQUA Project, Glasgow University, 1998
   3 %
   4
   5 Cheap and cheerful dynamic types.
   6
   7 The Dynamic interface is part of the Hugs/GHC standard
   8 libraries, providing basic support for dynamic types.
   9
  10 Operations for injecting values of arbitrary type into
  11 a dynamically typed value, Dynamic, are provided, together
  12 with operations for converting dynamic values into a concrete
  13 (monomorphic) type.
  14
  15 The Dynamic implementation provided is closely based on code
  16 contained in Hugs library of the same name.
  17
  18 \begin{code}
  19 module Dynamic
  20     (
  21       -- dynamic type
  22       Dynamic     -- abstract, instance of: Show (?)
  23     , toDyn       -- :: Typeable a => a -> Dynamic
  24     , fromDyn     -- :: Typeable a => Dynamic -> a -> a
  25     , fromDynamic -- :: Typeable a => Dynamic -> Maybe a
  26
  27       -- type representation
  28
  29     , Typeable(typeOf)
  30       -- class Typeable a where { typeOf :: a -> TypeRep }
  31
  32       -- Dynamic defines Typeable instances for the following
  33       -- Prelude types: Char, Int, Float, Double, Bool
  34       --                (), Maybe a, (a->b), [a]
  35       --                (a,b) (a,b,c) (a,b,c,d) (a,b,c,d,e)
  36
  37     , TypeRep      -- abstract, instance of: Eq, Show
  38     , TyCon        -- abstract, instance of: Eq, Show
  39
  40       -- type representation constructors/operators:
  41     , mkTyCon      -- :: String  -> TyCon
  42     , mkAppTy      -- :: TyCon   -> [TypeRep] -> TypeRep
  43     , mkFunTy      -- :: TypeRep -> TypeRep   -> TypeRep
  44     , applyTy      -- :: TypeRep -> TypeRep   -> Maybe TypeRep
  45
  46       --
  47       -- let iTy = mkTyCon "Int" in show (mkAppTy (mkTyCon ",,")
  48       --                                 [iTy,iTy,iTy])
  49       --
  50       -- returns "(Int,Int,Int)"
  51       --
  52       -- The TypeRep Show instance promises to print tuple types
  53       -- correctly. Tuple type constructors are specified by a
  54       -- sequence of commas, e.g., (mkTyCon ",,,,,,") returns
  55       -- the 7-tuple tycon.
  56     ) where
  57
  58 {- BEGIN_FOR_GHC
  59 import GlaExts
  60    END_FOR_GHC -}
  61
  62 -- the following type imports are only needed in order to define
  63 -- Typeable instances locally.
  64 import IO    ( Handle )
  65 import Array ( Array )
  66 import Complex ( Complex )
  67 import Foreign ( ForeignObj, StablePtr )
  68 {- BEGIN_FOR_GHC
  69 import PrelConc ( MVar )
  70    END_FOR_GHC -}
  71 {- BEGIN_FOR_HUGS -}
  72 import   -- fool mkdependHS
  73         Concurrent ( MVar )
  74 {- END_FOR_HUGS -}
  75 import Word  ( Word8, Word16, Word32, Word64 )
  76 import Int   ( Int8, Int16, Int32 )
  77 {- BEGIN_FOR_GHC
  78 import Int   ( Int64 )
  79    END_FOR_GHC -}
  80
  81 import IOExts
  82        ( unsafePerformIO,
  83          IORef, newIORef, readIORef, writeIORef
  84         )
  85
  86 {- BEGIN_FOR_HUGS -}
  87 primitive unsafeCoerce "primUnsafeCoerce" :: a -> b
  88 {- END_FOR_HUGS -}
  89
  90 {- BEGIN_FOR_GHC
  91 unsafeCoerce :: a -> b
  92 unsafeCoerce = unsafeCoerce#
  93    END_FOR_GHC -}
  94 \end{code}
  95
  96 The dynamic type is represented by Dynamic, carrying
  97 the dynamic value along with its type representation:
  98
  99 \begin{code}
 100 data Dynamic = Dynamic TypeRep Obj
 101
 102 data Obj = Obj
 103  -- dummy type to hold the dynamically typed value.
 104
 105 -- the instance just prints the type representation.
 106 instance Show Dynamic where
 107    showsPrec _ (Dynamic t _) =
 108           showString "<<" .
 109           showsPrec 0 t   .
 110           showString ">>"
 111 \end{code}
 112
 113 Operations for going to and from Dynamic:
 114
 115 \begin{code}
 116 toDyn :: Typeable a => a -> Dynamic
 117 toDyn v = Dynamic (typeOf v) (unsafeCoerce v)
 118
 119 fromDyn :: Typeable a => Dynamic -> a -> a
 120 fromDyn (Dynamic t v) def
 121   | typeOf def == t = unsafeCoerce v
 122   | otherwise       = def
 123
 124 fromDynamic :: Typeable a => Dynamic -> Maybe a
 125 fromDynamic (Dynamic t v) =
 126   case unsafeCoerce v of
 127     r | t == typeOf r -> Just r
 128       | otherwise     -> Nothing
 129 \end{code}
 130
 131 (Abstract) universal datatype:
 132
 133 \begin{code}
 134 data TypeRep
 135  = App TyCon   [TypeRep]
 136  | Fun TypeRep TypeRep
 137    deriving ( Eq )
 138
 139 -- type constructors are
 140 data TyCon = TyCon Int String
 141
 142 instance Show TypeRep where
 143   showsPrec p (App tycon tys) =
 144     case tys of
 145       [] -> showsPrec p tycon
 146       [x] | tycon == listTc    -> showChar '[' . shows x . showChar ']'
 147       xs  | isTupleTyCon tycon -> showTuple tycon xs
 148       xs -> showParen (p > 9) $
 149             showsPrec p tycon . showChar ' ' . showArgs tys
 150   showsPrec p (Fun f a) =
 151      showParen (p > 8) $
 152      showsPrec 9 f . showString " -> " . showsPrec 8 a
 153 \end{code}
 154
 155 To make it possible to convert values with user-defined types
 156 into type Dynamic, we need a systematic way of getting
 157 the type representation of an arbitrary type. Type class
 158 provide a good fit, here
 159
 160 \begin{code}
 161 class Typeable a where
 162   typeOf :: a -> TypeRep
 163 \end{code}
 164
 165 NOTE: The argument to the overloaded `typeOf' is only
 166 used to carry type information, and Typeable instances
 167 should *never* look at its value.
 168
 169 \begin{code}
 170 isTupleTyCon :: TyCon -> Bool
 171 isTupleTyCon (TyCon _ (',':_)) = True
 172 isTupleTyCon _                 = False
 173
 174 instance Eq TyCon where
 175   (TyCon t1 _) == (TyCon t2 _) = t1 == t2
 176
 177 instance Show TyCon where
 178   showsPrec d (TyCon _ s) = showString s
 179
 180 --
 181 -- If we enforce the restriction that TyCons are
 182 -- shared, we can map them onto Ints very simply
 183 -- which allows for efficient comparison.
 184 --
 185 mkTyCon :: String -> TyCon
 186 mkTyCon str = unsafePerformIO $ do
 187    v <- readIORef uni
 188    writeIORef uni (v+1)
 189    return (TyCon v str)
 190
 191 uni :: IORef Int
 192 uni = unsafePerformIO ( newIORef 0 )
 193 \end{code}
 194
 195 Some (Show.TypeRep) helpers:
 196
 197 \begin{code}
 198 showArgs [] = id
 199 showArgs [a] = showsPrec 10 a
 200 showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
 201
 202 showTuple :: TyCon -> [TypeRep] -> ShowS
 203 showTuple (TyCon _ str) args = showChar '(' . go str args
 204  where
 205   go [] [a] = showsPrec 10 a . showChar ')'
 206   go _  []  = showChar ')' -- a failure condition, really.
 207   go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
 208   go _ _   = showChar ')'
 209 \end{code}
 210
 211 \begin{code}
 212 mkAppTy  :: TyCon   -> [TypeRep] -> TypeRep
 213 mkAppTy tyc args = App tyc args
 214
 215 mkFunTy  :: TypeRep -> TypeRep   -> TypeRep
 216 mkFunTy f a = Fun f a
 217 \end{code}
 218
 219 Auxillary functions
 220
 221 \begin{code}
 222 -- (f::(a->b)) `dynApply` (x::a) = (f a)::b
 223 dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
 224 dynApply (Dynamic t1 f) (Dynamic t2 x) =
 225   case applyTy t1 t2 of
 226     Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
 227     Nothing -> Nothing
 228
 229 dynApp :: Dynamic -> Dynamic -> Dynamic
 230 dynApp f x = case dynApply f x of
 231              Just r -> r
 232              Nothing -> error ("Type error in dynamic application.\n" ++
 233                                "Can't apply function " ++ show f ++
 234                                " to argument " ++ show x)
 235
 236 applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
 237 applyTy (Fun t1 t2) t3
 238   | t1 == t3    = Just t2
 239 applyTy _ _     = Nothing
 240
 241 \end{code}
 242
 243 \begin{code}
 244 instance Typeable Int where
 245   typeOf _ = mkAppTy intTc []
 246
 247 instance Typeable Char where
 248   typeOf _ = mkAppTy charTc []
 249
 250 instance Typeable Bool where
 251   typeOf _ = mkAppTy boolTc []
 252
 253 instance Typeable Float where
 254   typeOf _ = mkAppTy floatTc []
 255
 256 instance Typeable Double where
 257   typeOf _ = mkAppTy doubleTc []
 258
 259 instance Typeable Integer where
 260   typeOf _ = mkAppTy integerTc []
 261
 262 instance Typeable a => Typeable (IO a) where
 263   typeOf action = mkAppTy ioTc [typeOf (doIO action)]
 264     where
 265       doIO :: IO a -> a
 266       doIO = undefined
 267
 268 instance Typeable a => Typeable [a] where
 269   typeOf ls = mkAppTy listTc [typeOf (hd ls)]
 270     where
 271       hd :: [a] -> a
 272       hd = undefined
 273
 274 instance Typeable a => Typeable (Maybe a) where
 275   typeOf mb = mkAppTy maybeTc [typeOf (getJ mb)]
 276     where
 277       getJ :: Maybe a -> a
 278       getJ = undefined
 279
 280 instance (Typeable a, Typeable b) => Typeable (Either a b) where
 281   typeOf ei = mkAppTy maybeTc [typeOf (getL ei), typeOf (getR ei)]
 282     where
 283       getL :: Either a b -> a
 284       getL = undefined
 285       getR :: Either a b -> a
 286       getR = undefined
 287
 288 instance (Typeable a, Typeable b) => Typeable (a -> b) where
 289   typeOf f = mkFunTy (typeOf (arg f)) (typeOf (res f))
 290    where
 291     arg :: (a -> b) -> a
 292     arg = undefined
 293
 294     res :: (a -> b) -> b
 295     res = undefined
 296
 297 instance Typeable () where
 298   typeOf _ = mkAppTy unitTc []
 299
 300 instance Typeable TypeRep where
 301   typeOf _ = mkAppTy typeRepTc []
 302
 303 instance Typeable TyCon where
 304   typeOf _ = mkAppTy tyConTc []
 305
 306 instance Typeable Dynamic where
 307   typeOf _ = mkAppTy dynamicTc []
 308
 309 instance Typeable Ordering where
 310   typeOf _ = mkAppTy orderingTc []
 311
 312 instance (Typeable ix, Typeable a) => Typeable (Array ix a) where
 313   typeOf a = mkAppTy arrayTc [typeOf (ix a), typeOf (elt a)]
 314    where
 315     ix :: Array ix a -> ix
 316     ix = undefined
 317
 318     elt :: Array ix a -> a
 319     elt = undefined
 320
 321 instance (Typeable a) => Typeable (Complex a) where
 322   typeOf c = mkAppTy complexTc [typeOf (v c)]
 323    where
 324     v :: Complex a -> a
 325     v = undefined
 326
 327 instance Typeable Handle where
 328   typeOf _ = mkAppTy handleTc []
 329
 330 instance (Typeable a, Typeable b) => Typeable (a,b) where
 331   typeOf tu = mkAppTy tup2Tc [typeOf (fst tu), typeOf (snd tu)]
 332     where
 333       fst :: (a,b) -> a
 334       fst = undefined
 335       snd :: (a,b) -> b
 336       snd = undefined
 337
 338       tup2Tc = mkTyCon ","
 339
 340 instance ( Typeable a
 341          , Typeable b
 342          , Typeable c) => Typeable (a,b,c) where
 343   typeOf tu = mkAppTy tup3Tc [ typeOf (fst tu)
 344                              , typeOf (snd tu)
 345                              , typeOf (thd tu)
 346                              ]
 347     where
 348       fst :: (a,b,c) -> a
 349       fst = undefined
 350       snd :: (a,b,c) -> b
 351       snd = undefined
 352       thd :: (a,b,c) -> c
 353       thd = undefined
 354
 355       tup3Tc = mkTyCon ",,"
 356
 357 instance ( Typeable a
 358          , Typeable b
 359          , Typeable c
 360          , Typeable d) => Typeable (a,b,c,d) where
 361   typeOf tu = mkAppTy tup4Tc [ typeOf (fst tu)
 362                              , typeOf (snd tu)
 363                              , typeOf (thd tu)
 364                              , typeOf (fth tu)
 365                              ]
 366     where
 367       fst :: (a,b,c,d) -> a
 368       fst = undefined
 369       snd :: (a,b,c,d) -> b
 370       snd = undefined
 371       thd :: (a,b,c,d) -> c
 372       thd = undefined
 373       fth :: (a,b,c,d) -> d
 374       fth = undefined
 375
 376       tup4Tc = mkTyCon ",,,"
 377
 378 instance ( Typeable a
 379          , Typeable b
 380          , Typeable c
 381          , Typeable d
 382          , Typeable e) => Typeable (a,b,c,d,e) where
 383   typeOf tu = mkAppTy tup5Tc [ typeOf (fst tu)
 384                              , typeOf (snd tu)
 385                              , typeOf (thd tu)
 386                              , typeOf (fth tu)
 387                              , typeOf (ffth tu)
 388                              ]
 389     where
 390       fst :: (a,b,c,d,e) -> a
 391       fst = undefined
 392       snd :: (a,b,c,d,e) -> b
 393       snd = undefined
 394       thd :: (a,b,c,d,e) -> c
 395       thd = undefined
 396       fth :: (a,b,c,d,e) -> d
 397       fth = undefined
 398       ffth :: (a,b,c,d,e) -> e
 399       ffth = undefined
 400
 401       tup5Tc = mkTyCon ",,,,"
 402
 403 -- Hugs/GHC extension lib types:
 404 instance Typeable Addr where
 405    typeOf _ = mkAppTy addrTc []
 406
 407 instance Typeable a => Typeable (StablePtr a) where
 408    typeOf s = mkAppTy stablePtrTc [typeOf (t s)]
 409     where
 410       t  :: StablePtr a -> a
 411       t = undefined
 412
 413 instance Typeable a => Typeable (MVar a) where
 414    typeOf m = mkAppTy mvarTc [typeOf (t m)]
 415     where
 416       t  :: MVar a -> a
 417       t = undefined
 418
 419 instance (Typeable s, Typeable a) => Typeable (ST s a) where
 420    typeOf st = mkAppTy stTc [typeOf (s st), typeOf (a st)]
 421     where
 422       s  :: ST s a -> s
 423       s = undefined
 424
 425       a  :: ST s a -> a
 426       a = undefined
 427
 428 instance Typeable ForeignObj where
 429    typeOf _ = mkAppTy foreignObjTc []
 430
 431 instance Typeable Int8 where
 432    typeOf _ = mkAppTy int8Tc []
 433
 434 instance Typeable Int16 where
 435    typeOf _ = mkAppTy int16Tc []
 436
 437 instance Typeable Int32 where
 438    typeOf _ = mkAppTy int32Tc []
 439
 440 {- BEGIN_FOR_GHC
 441 instance Typeable Int64 where
 442    typeOf _ = mkAppTy int64Tc []
 443    END_FOR_GHC -}
 444
 445 instance Typeable Word8 where
 446    typeOf _ = mkAppTy word8Tc []
 447
 448 instance Typeable Word16 where
 449    typeOf _ = mkAppTy word16Tc []
 450
 451 instance Typeable Word32 where
 452    typeOf _ = mkAppTy word32Tc []
 453
 454 instance Typeable Word64 where
 455    typeOf _ = mkAppTy word64Tc []
 456
 457 {- BEGIN_FOR_GHC
 458 instance Typeable Word where
 459    typeOf _ = mkAppTy wordTc []
 460
 461 instance Typeable a => Typeable (ByteArray a) where
 462    typeOf b = mkAppTy byteArrayTc [typeOf (t b)]
 463     where
 464      t :: ByteArray t -> t
 465      t = undefined
 466
 467 instance (Typeable s, Typeable a) => Typeable (MutableByteArray s a) where
 468    typeOf mb = mkAppTy byteArrayTc [typeOf (s mb), typeOf (a mb)]
 469     where
 470      s :: MutableByteArray s a -> s
 471      s = undefined
 472
 473      a :: MutableByteArray s a -> a
 474      a = undefined
 475
 476    END_FOR_GHC -}
 477
 478 \end{code}
 479
 480 @TyCon@s are provided for the following:
 481
 482 \begin{code}
 483 -- prelude types:
 484 intTc      = mkTyCon "Int"
 485 charTc     = mkTyCon "Char"
 486 boolTc     = mkTyCon "Bool"
 487 floatTc    = mkTyCon "Float"
 488 doubleTc   = mkTyCon "Double"
 489 integerTc  = mkTyCon "Integer"
 490 ioTc       = mkTyCon "IO"
 491 maybeTc    = mkTyCon "Maybe"
 492 eitherTc   = mkTyCon "Either"
 493 listTc     = mkTyCon "[]"
 494 unitTc     = mkTyCon "()"
 495 orderingTc = mkTyCon "Ordering"
 496 arrayTc    = mkTyCon "Array"
 497 complexTc  = mkTyCon "Complex"
 498 handleTc   = mkTyCon "Handle"
 499
 500 -- Hugs/GHC extension lib types:
 501 addrTc       = mkTyCon "Addr"
 502 stablePtrTc  = mkTyCon "StablePtr"
 503 mvarTc       = mkTyCon "MVar"
 504 foreignObjTc = mkTyCon "ForeignObj"
 505 stTc         = mkTyCon "ST"
 506 int8Tc       = mkTyCon "Int8"
 507 int16Tc      = mkTyCon "Int16"
 508 int32Tc      = mkTyCon "Int32"
 509 int64Tc      = mkTyCon "Int64"
 510 word8Tc      = mkTyCon "Word8"
 511 word16Tc     = mkTyCon "Word16"
 512 word32Tc     = mkTyCon "Word32"
 513 word64Tc     = mkTyCon "Word64"
 514 tyConTc      = mkTyCon "TyCon"
 515 typeRepTc    = mkTyCon "Type"
 516 dynamicTc    = mkTyCon "Dynamic"
 517
 518 -- GHC specific:
 519 {- BEGIN_FOR_GHC
 520 byteArrayTc  = mkTyCon "ByteArray"
 521 mutablebyteArrayTc = mkTyCon "MutableByteArray"
 522 wordTc       = mkTyCon "Word"
 523    END_FOR_GHC -}
 524
 525 \end{code}
 526