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