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