[project @ 1998-12-02 13:17:09 by simonm]

[ghc-hetmet.git] / ghc / lib / exts / Dynamic.lhs

diff --git a/ghc/lib/exts/Dynamic.lhs b/ghc/lib/exts/Dynamic.lhs
index 4844e3d..92a1725 100644 (file)
--- a/ghc/lib/exts/Dynamic.lhs
+++ b/ghc/lib/exts/Dynamic.lhs
@@ -57,25 +57,7 @@ module Dynamic
 
 {- BEGIN_FOR_GHC
 import GlaExts
-   END_FOR_GHC -}
-
--- the following type imports are only needed in order to define
--- Typeable instances locally.
-import IO    ( Handle )
-import Array ( Array )
-import Complex ( Complex )
-import Foreign ( ForeignObj, StablePtr )
-{- BEGIN_FOR_GHC
-import PrelConc ( MVar )
-   END_FOR_GHC -}
-{- BEGIN_FOR_HUGS -}
-import   -- fool mkdependHS
-       Concurrent ( MVar )
-{- END_FOR_HUGS -}
-import Word  ( Word8, Word16, Word32, Word64 )
-import Int   ( Int8, Int16, Int32 )
-{- BEGIN_FOR_GHC
-import Int   ( Int64 )
+import PrelDynamic
    END_FOR_GHC -}
 
 import IOExts 
@@ -84,7 +66,10 @@ import IOExts
         )
 
 {- BEGIN_FOR_HUGS -}
-primitive unsafeCoerce "primUnsafeCoerce" :: a -> b
+import 
+       PreludeBuiltin
+
+unsafeCoerce = primUnsafeCoerce
 {- END_FOR_HUGS -}
 
 {- BEGIN_FOR_GHC
@@ -97,11 +82,6 @@ The dynamic type is represented by Dynamic, carrying
 the dynamic value along with its type representation:
 
 \begin{code}
-data Dynamic = Dynamic TypeRep Obj
-
-data Obj = Obj  
- -- dummy type to hold the dynamically typed value.
-
 -- the instance just prints the type representation.
 instance Show Dynamic where
    showsPrec _ (Dynamic t _) = 
@@ -131,14 +111,6 @@ fromDynamic (Dynamic t v) =
 (Abstract) universal datatype:
 
 \begin{code}
-data TypeRep
- = App TyCon   [TypeRep]
- | Fun TypeRep TypeRep
-   deriving ( Eq )
-
--- type constructors are 
-data TyCon = TyCon Int String
-
 instance Show TypeRep where
   showsPrec p (App tycon tys) =
     case tys of
@@ -171,9 +143,6 @@ isTupleTyCon :: TyCon -> Bool
 isTupleTyCon (TyCon _ (',':_)) = True
 isTupleTyCon _                = False
 
-instance Eq TyCon where
-  (TyCon t1 _) == (TyCon t2 _) = t1 == t2
-
 instance Show TyCon where
   showsPrec d (TyCon _ s) = showString s
 
@@ -309,24 +278,6 @@ instance Typeable Dynamic where
 instance Typeable Ordering where
   typeOf _ = mkAppTy orderingTc []
 
-instance (Typeable ix, Typeable a) => Typeable (Array ix a) where
-  typeOf a = mkAppTy arrayTc [typeOf (ix a), typeOf (elt a)]
-   where
-    ix :: Array ix a -> ix
-    ix = undefined
-
-    elt :: Array ix a -> a
-    elt = undefined
-
-instance (Typeable a) => Typeable (Complex a) where
-  typeOf c = mkAppTy complexTc [typeOf (v c)]
-   where
-    v :: Complex a -> a
-    v = undefined
-
-instance Typeable Handle where
-  typeOf _ = mkAppTy handleTc []
-
 instance (Typeable a, Typeable b) => Typeable (a,b) where
   typeOf tu = mkAppTy tup2Tc [typeOf (fst tu), typeOf (snd tu)]
     where
@@ -400,81 +351,6 @@ instance ( Typeable a
 
       tup5Tc = mkTyCon ",,,,"
 
--- Hugs/GHC extension lib types:
-instance Typeable Addr where
-   typeOf _ = mkAppTy addrTc []
-
-instance Typeable a => Typeable (StablePtr a) where
-   typeOf s = mkAppTy stablePtrTc [typeOf (t s)]
-    where
-      t  :: StablePtr a -> a
-      t = undefined
-
-instance Typeable a => Typeable (MVar a) where
-   typeOf m = mkAppTy mvarTc [typeOf (t m)]
-    where
-      t  :: MVar a -> a
-      t = undefined
-
-instance (Typeable s, Typeable a) => Typeable (ST s a) where
-   typeOf st = mkAppTy stTc [typeOf (s st), typeOf (a st)]
-    where
-      s  :: ST s a -> s
-      s = undefined
-
-      a  :: ST s a -> a
-      a = undefined
-
-instance Typeable ForeignObj where
-   typeOf _ = mkAppTy foreignObjTc []
-
-instance Typeable Int8 where
-   typeOf _ = mkAppTy int8Tc []
-
-instance Typeable Int16 where
-   typeOf _ = mkAppTy int16Tc []
-
-instance Typeable Int32 where
-   typeOf _ = mkAppTy int32Tc []
-
-{- BEGIN_FOR_GHC
-instance Typeable Int64 where
-   typeOf _ = mkAppTy int64Tc []
-   END_FOR_GHC -}
-
-instance Typeable Word8 where
-   typeOf _ = mkAppTy word8Tc []
-
-instance Typeable Word16 where
-   typeOf _ = mkAppTy word16Tc []
-
-instance Typeable Word32 where
-   typeOf _ = mkAppTy word32Tc []
-
-instance Typeable Word64 where
-   typeOf _ = mkAppTy word64Tc []
-
-{- BEGIN_FOR_GHC
-instance Typeable Word where
-   typeOf _ = mkAppTy wordTc []
-
-instance Typeable a => Typeable (ByteArray a) where
-   typeOf b = mkAppTy byteArrayTc [typeOf (t b)]
-    where
-     t :: ByteArray t -> t
-     t = undefined
-
-instance (Typeable s, Typeable a) => Typeable (MutableByteArray s a) where
-   typeOf mb = mkAppTy byteArrayTc [typeOf (s mb), typeOf (a mb)]
-    where
-     s :: MutableByteArray s a -> s
-     s = undefined
-
-     a :: MutableByteArray s a -> a
-     a = undefined
-
-   END_FOR_GHC -}
-
 \end{code}
 
 @TyCon@s are provided for the following:
@@ -524,3 +400,33 @@ wordTc       = mkTyCon "Word"
 
 \end{code}
 
+\begin{code}
+test1 = toDyn (1::Int)
+test2 = toDyn ((+) :: Int -> Int -> Int)
+test3 = dynApp test2 test1
+test4 = dynApp test3 test1
+
+test5, test6,test7 :: Int
+test5 = fromDyn test4 0
+test6 = fromDyn test1 0
+test7 = fromDyn test2 0
+
+test8 = toDyn (mkAppTy listTc)
+test9 :: Float
+test9 = fromDyn test8 0
+
+printf :: String -> [Dynamic] -> IO ()
+printf str args = putStr (decode str args)
+ where
+  decode [] [] = []
+  decode ('%':'n':cs) (d:ds) =
+    (\ v -> show v++decode cs ds) (fromDyn  d (0::Int))
+  decode ('%':'c':cs) (d:ds) =
+    (\ v -> show v++decode cs ds) (fromDyn  d ('\0'))
+  decode ('%':'b':cs) (d:ds) =
+    (\ v -> show v++decode cs ds) (fromDyn  d (False::Bool))
+  decode (x:xs) ds = x:decode xs ds
+
+test10 :: IO ()
+test10 = printf "%n = %c, that much is %b\n" [toDyn (3::Int),toDyn 'a', toDyn False]
+\end{code}