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. Type class
 137 provide a good fit, here
 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* 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 --
 157 -- If we enforce the restriction that TyCons are
 158 -- shared, we can map them onto Ints very simply
 159 -- which allows for efficient comparison.
 160 --
 161 mkTyCon :: String -> TyCon
 162 mkTyCon str = unsafePerformIO $ do
 163    v <- readIORef uni
 164    writeIORef uni (v+1)
 165    return (TyCon v str)
 166
 167 uni :: IORef Int
 168 uni = unsafePerformIO ( newIORef 0 )
 169 \end{code}
 170
 171 Some (Show.TypeRep) helpers:
 172
 173 \begin{code}
 174 showArgs :: Show a => [a] -> ShowS
 175 showArgs [] = id
 176 showArgs [a] = showsPrec 10 a
 177 showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
 178
 179 showTuple :: TyCon -> [TypeRep] -> ShowS
 180 showTuple (TyCon _ str) args = showChar '(' . go str args
 181  where
 182   go [] [a] = showsPrec 10 a . showChar ')'
 183   go _  []  = showChar ')' -- a failure condition, really.
 184   go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
 185   go _ _   = showChar ')'
 186 \end{code}
 187
 188 \begin{code}
 189 mkAppTy  :: TyCon   -> [TypeRep] -> TypeRep
 190 mkAppTy tyc args = App tyc args
 191
 192 mkFunTy  :: TypeRep -> TypeRep   -> TypeRep
 193 mkFunTy f a = Fun f a
 194 \end{code}
 195
 196 Auxillary functions
 197
 198 \begin{code}
 199 -- (f::(a->b)) `dynApply` (x::a) = (f a)::b
 200 dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
 201 dynApply (Dynamic t1 f) (Dynamic t2 x) =
 202   case applyTy t1 t2 of
 203     Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
 204     Nothing -> Nothing
 205
 206 dynApp :: Dynamic -> Dynamic -> Dynamic
 207 dynApp f x = case dynApply f x of
 208              Just r -> r
 209              Nothing -> error ("Type error in dynamic application.\n" ++
 210                                "Can't apply function " ++ show f ++
 211                                " to argument " ++ show x)
 212
 213 applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
 214 applyTy (Fun t1 t2) t3
 215   | t1 == t3    = Just t2
 216 applyTy _ _     = Nothing
 217
 218 \end{code}
 219
 220 \begin{code}
 221 instance Typeable Int where
 222   typeOf _ = mkAppTy intTc []
 223
 224 instance Typeable Char where
 225   typeOf _ = mkAppTy charTc []
 226
 227 instance Typeable Bool where
 228   typeOf _ = mkAppTy boolTc []
 229
 230 instance Typeable Float where
 231   typeOf _ = mkAppTy floatTc []
 232
 233 instance Typeable Double where
 234   typeOf _ = mkAppTy doubleTc []
 235
 236 instance Typeable Integer where
 237   typeOf _ = mkAppTy integerTc []
 238
 239 instance Typeable a => Typeable (IO a) where
 240   typeOf action = mkAppTy ioTc [typeOf (doIO action)]
 241     where
 242       doIO :: IO a -> a
 243       doIO = undefined
 244
 245 instance Typeable a => Typeable [a] where
 246   typeOf ls = mkAppTy listTc [typeOf (hd ls)]
 247     where
 248       hd :: [a] -> a
 249       hd = undefined
 250
 251 instance Typeable a => Typeable (Maybe a) where
 252   typeOf mb = mkAppTy maybeTc [typeOf (getJ mb)]
 253     where
 254       getJ :: Maybe a -> a
 255       getJ = undefined
 256
 257 instance (Typeable a, Typeable b) => Typeable (Either a b) where
 258   typeOf ei = mkAppTy maybeTc [typeOf (getL ei), typeOf (getR ei)]
 259     where
 260       getL :: Either a b -> a
 261       getL = undefined
 262       getR :: Either a b -> a
 263       getR = undefined
 264
 265 instance (Typeable a, Typeable b) => Typeable (a -> b) where
 266   typeOf f = mkFunTy (typeOf (arg f)) (typeOf (res f))
 267    where
 268     arg :: (a -> b) -> a
 269     arg = undefined
 270
 271     res :: (a -> b) -> b
 272     res = undefined
 273
 274 instance Typeable () where
 275   typeOf _ = mkAppTy unitTc []
 276
 277 instance Typeable TypeRep where
 278   typeOf _ = mkAppTy typeRepTc []
 279
 280 instance Typeable TyCon where
 281   typeOf _ = mkAppTy tyConTc []
 282
 283 instance Typeable Dynamic where
 284   typeOf _ = mkAppTy dynamicTc []
 285
 286 instance Typeable Ordering where
 287   typeOf _ = mkAppTy orderingTc []
 288
 289 instance (Typeable a, Typeable b) => Typeable (a,b) where
 290   typeOf tu = mkAppTy tup2Tc [typeOf (fst tu), typeOf (snd tu)]
 291     where
 292       fst :: (a,b) -> a
 293       fst = undefined
 294       snd :: (a,b) -> b
 295       snd = undefined
 296
 297       tup2Tc = mkTyCon ","
 298
 299 instance ( Typeable a
 300          , Typeable b
 301          , Typeable c) => Typeable (a,b,c) where
 302   typeOf tu = mkAppTy tup3Tc [ typeOf (fst tu)
 303                              , typeOf (snd tu)
 304                              , typeOf (thd tu)
 305                              ]
 306     where
 307       fst :: (a,b,c) -> a
 308       fst = undefined
 309       snd :: (a,b,c) -> b
 310       snd = undefined
 311       thd :: (a,b,c) -> c
 312       thd = undefined
 313
 314       tup3Tc = mkTyCon ",,"
 315
 316 instance ( Typeable a
 317          , Typeable b
 318          , Typeable c
 319          , Typeable d) => Typeable (a,b,c,d) where
 320   typeOf tu = mkAppTy tup4Tc [ typeOf (fst tu)
 321                              , typeOf (snd tu)
 322                              , typeOf (thd tu)
 323                              , typeOf (fth tu)
 324                              ]
 325     where
 326       fst :: (a,b,c,d) -> a
 327       fst = undefined
 328       snd :: (a,b,c,d) -> b
 329       snd = undefined
 330       thd :: (a,b,c,d) -> c
 331       thd = undefined
 332       fth :: (a,b,c,d) -> d
 333       fth = undefined
 334
 335       tup4Tc = mkTyCon ",,,"
 336
 337 instance ( Typeable a
 338          , Typeable b
 339          , Typeable c
 340          , Typeable d
 341          , Typeable e) => Typeable (a,b,c,d,e) where
 342   typeOf tu = mkAppTy tup5Tc [ typeOf (fst tu)
 343                              , typeOf (snd tu)
 344                              , typeOf (thd tu)
 345                              , typeOf (fth tu)
 346                              , typeOf (ffth tu)
 347                              ]
 348     where
 349       fst :: (a,b,c,d,e) -> a
 350       fst = undefined
 351       snd :: (a,b,c,d,e) -> b
 352       snd = undefined
 353       thd :: (a,b,c,d,e) -> c
 354       thd = undefined
 355       fth :: (a,b,c,d,e) -> d
 356       fth = undefined
 357       ffth :: (a,b,c,d,e) -> e
 358       ffth = undefined
 359
 360       tup5Tc = mkTyCon ",,,,"
 361
 362 \end{code}
 363
 364 @TyCon@s are provided for the following:
 365
 366 \begin{code}
 367 -- prelude types:
 368 intTc, charTc, boolTc :: TyCon
 369 intTc      = mkTyCon "Int"
 370 charTc     = mkTyCon "Char"
 371 boolTc     = mkTyCon "Bool"
 372
 373 floatTc, doubleTc, integerTc :: TyCon
 374 floatTc    = mkTyCon "Float"
 375 doubleTc   = mkTyCon "Double"
 376 integerTc  = mkTyCon "Integer"
 377
 378 ioTc, maybeTc, eitherTc, listTc :: TyCon
 379 ioTc       = mkTyCon "IO"
 380 maybeTc    = mkTyCon "Maybe"
 381 eitherTc   = mkTyCon "Either"
 382 listTc     = mkTyCon "[]"
 383
 384 unitTc, orderingTc, arrayTc, complexTc, handleTc :: TyCon
 385 unitTc     = mkTyCon "()"
 386 orderingTc = mkTyCon "Ordering"
 387 arrayTc    = mkTyCon "Array"
 388 complexTc  = mkTyCon "Complex"
 389 handleTc   = mkTyCon "Handle"
 390
 391 -- Hugs/GHC extension lib types:
 392 addrTc, stablePtrTc, mvarTc :: TyCon
 393 addrTc       = mkTyCon "Addr"
 394 stablePtrTc  = mkTyCon "StablePtr"
 395 mvarTc       = mkTyCon "MVar"
 396
 397 foreignObjTc, stTc :: TyCon
 398 foreignObjTc = mkTyCon "ForeignObj"
 399 stTc         = mkTyCon "ST"
 400
 401 int8Tc, int16Tc, int32Tc, int64Tc :: TyCon
 402 int8Tc       = mkTyCon "Int8"
 403 int16Tc      = mkTyCon "Int16"
 404 int32Tc      = mkTyCon "Int32"
 405 int64Tc      = mkTyCon "Int64"
 406
 407 word8Tc, word16Tc, word32Tc, word64Tc :: TyCon
 408 word8Tc      = mkTyCon "Word8"
 409 word16Tc     = mkTyCon "Word16"
 410 word32Tc     = mkTyCon "Word32"
 411 word64Tc     = mkTyCon "Word64"
 412
 413 tyConTc, typeRepTc, dynamicTc :: TyCon
 414 tyConTc      = mkTyCon "TyCon"
 415 typeRepTc    = mkTyCon "Type"
 416 dynamicTc    = mkTyCon "Dynamic"
 417
 418 -- GHC specific:
 419 {- BEGIN_FOR_GHC
 420 byteArrayTc, mutablebyteArrayTc, wordTc :: TyCon
 421 byteArrayTc  = mkTyCon "ByteArray"
 422 mutablebyteArrayTc = mkTyCon "MutableByteArray"
 423 wordTc       = mkTyCon "Word"
 424    END_FOR_GHC -}
 425
 426 \end{code}
 427
 428 begin{code}
 429 test1,test2, test3, test4 :: Dynamic
 430
 431 test1 = toDyn (1::Int)
 432 test2 = toDyn ((+) :: Int -> Int -> Int)
 433 test3 = dynApp test2 test1
 434 test4 = dynApp test3 test1
 435
 436 test5, test6,test7 :: Int
 437 test5 = fromDyn test4 0
 438 test6 = fromDyn test1 0
 439 test7 = fromDyn test2 0
 440
 441 test8 :: Dynamic
 442 test8 = toDyn (mkAppTy listTc)
 443
 444 test9 :: Float
 445 test9 = fromDyn test8 0
 446
 447 printf :: String -> [Dynamic] -> IO ()
 448 printf str args = putStr (decode str args)
 449  where
 450   decode [] [] = []
 451   decode ('%':'n':cs) (d:ds) =
 452     (\ v -> show v++decode cs ds) (fromDyn  d (0::Int))
 453   decode ('%':'c':cs) (d:ds) =
 454     (\ v -> show v++decode cs ds) (fromDyn  d ('\0'))
 455   decode ('%':'b':cs) (d:ds) =
 456     (\ v -> show v++decode cs ds) (fromDyn  d (False::Bool))
 457   decode (x:xs) ds = x:decode xs ds
 458
 459 test10 :: IO ()
 460 test10 = printf "%n = %c, that much is %b\n" [toDyn (3::Int),toDyn 'a', toDyn False]
 461 end{code}