X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FDynamic.hs;h=cbc98a08b86873784af2136b1907b5679dadeb5e;hb=4648117d1b277f0322463388d6465543cc759f93;hp=42313fd07c5082f6bb45fb7ccff2180466d412b4;hpb=7f1f4e7a695c402ddd3a1dc2cc7114e649a78ebc;p=ghc-base.git

diff --git a/Data/Dynamic.hs b/Data/Dynamic.hs
index 42313fd..cbc98a0 100644
--- a/Data/Dynamic.hs
+++ b/Data/Dynamic.hs
@@ -1,15 +1,13 @@
 {-# OPTIONS -fno-implicit-prelude #-}
 -----------------------------------------------------------------------------
--- 
+-- |
 -- Module      :  Data.Dynamic
 -- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- 
 -- Maintainer  :  libraries@haskell.org
 -- Stability   :  experimental
--- Portability :  non-portable
---
--- $Id: Dynamic.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+-- Portability :  portable
 --
 -- The Dynamic interface provides basic support for dynamic types.
 -- 
@@ -18,38 +16,38 @@
 -- with operations for converting dynamic values into a concrete
 -- (monomorphic) type.
 -- 
--- The Dynamic implementation provided is closely based on code
--- contained in Hugs library of the same name.
--- 
 -----------------------------------------------------------------------------
 
 module Data.Dynamic
-	(
-	-- dynamic type
-	  Dynamic	-- abstract, instance of: Show, Typeable
-	, toDyn		-- :: Typeable a => a -> Dynamic
-	, fromDyn	-- :: Typeable a => Dynamic -> a -> a
-	, fromDynamic	-- :: Typeable a => Dynamic -> Maybe a
+  (
+	-- * The @Dynamic@ type
+	Dynamic,	-- abstract, instance of: Show, Typeable
+
+	-- * Converting to and from @Dynamic@
+	toDyn,		-- :: Typeable a => a -> Dynamic
+	fromDyn,	-- :: Typeable a => Dynamic -> a -> a
+	fromDynamic,	-- :: Typeable a => Dynamic -> Maybe a
 	
-	-- type representation
+	-- * Applying functions of dynamic type
+	dynApply,
+	dynApp,
 
-	, Typeable(
-	     typeOf)	-- :: a -> TypeRep
+	-- * Concrete Type Representations
+	
+	-- | This section is useful if you need to define your own
+	-- instances of 'Typeable'.
 
-	  -- Dynamic defines Typeable instances for the following
-	-- Prelude types: [a], (), (a,b), (a,b,c), (a,b,c,d),
-	-- (a,b,c,d,e), (a->b), (Array a b), Bool, Char,
-	-- (Complex a), Double, (Either a b), Float, Handle,
-	-- Int, Integer, (IO a), (Maybe a), Ordering
+	Typeable( typeOf ),	-- :: a -> TypeRep
+	cast,			-- :: (Typeable a, Typeable b) => a -> Maybe b
 
-	, TypeRep	-- abstract, instance of: Eq, Show, Typeable
-	, TyCon		-- abstract, instance of: Eq, Show, Typeable
+	-- ** Building concrete type representations
+	TypeRep,	-- abstract, instance of: Eq, Show, Typeable
+	TyCon,		-- abstract, instance of: Eq, Show, Typeable
 
-	-- type representation constructors/operators:
-	, mkTyCon	-- :: String  -> TyCon
-	, mkAppTy	-- :: TyCon   -> [TypeRep] -> TypeRep
-	, mkFunTy	-- :: TypeRep -> TypeRep   -> TypeRep
-	, applyTy	-- :: TypeRep -> TypeRep   -> Maybe TypeRep
+	mkTyCon,	-- :: String  -> TyCon
+	mkAppTy,	-- :: TyCon   -> [TypeRep] -> TypeRep
+	mkFunTy,	-- :: TypeRep -> TypeRep   -> TypeRep
+	applyTy,	-- :: TypeRep -> TypeRep   -> Maybe TypeRep
 
 	-- 
 	-- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
@@ -64,89 +62,196 @@ module Data.Dynamic
 	) where
 
 
+import qualified Data.HashTable as HT
+import Data.Maybe
+import Data.Either
+import Data.Int
+import Data.Word
+import Data.List( foldl )
+
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
-import GHC.Maybe
 import GHC.Show
 import GHC.Err
 import GHC.Num
 import GHC.Float
+import GHC.Real( rem )
 import GHC.IOBase
-import GHC.Dynamic
+import GHC.Ptr		-- So we can give Typeable instance for Ptr
+import GHC.Stable	-- So we can give Typeable instance for StablePtr
 #endif
 
-#ifdef __GLASGOW_HASKELL__
-import GHC.Prim			( unsafeCoerce# )
+#ifdef __HUGS__
+import Hugs.Prelude
+import Hugs.IO
+import Hugs.IORef
+import Hugs.IOExts
+#endif
 
+#ifdef __GLASGOW_HASKELL__
 unsafeCoerce :: a -> b
 unsafeCoerce = unsafeCoerce#
 #endif
 
+#ifdef __NHC__
+import NonStdUnsafeCoerce (unsafeCoerce)
+import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
+#else
 #include "Dynamic.h"
+#endif
 
--- The dynamic type is represented by Dynamic, carrying
--- the dynamic value along with its type representation:
+-------------------------------------------------------------
+--
+--		The type Dynamic
+--
+-------------------------------------------------------------
+
+{-|
+  A value of type 'Dynamic' is an object encapsulated together with its type.
+
+  A 'Dynamic' may only represent a monomorphic value; an attempt to
+  create a value of type 'Dynamic' from a polymorphically-typed
+  expression will result in an ambiguity error (see 'toDyn').
+
+  'Show'ing a value of type 'Dynamic' returns a pretty-printed representation
+  of the object\'s type; useful for debugging.
+-}
+#ifndef __HUGS__
+data Dynamic = Dynamic TypeRep Obj
+#endif
 
--- the instance just prints the type representation.
 instance Show Dynamic where
+   -- the instance just prints the type representation.
    showsPrec _ (Dynamic t _) = 
           showString "<<" . 
 	  showsPrec 0 t   . 
 	  showString ">>"
 
--- Operations for going to and from Dynamic:
+#ifdef __GLASGOW_HASKELL__
+type Obj = forall a . a
+ -- Dummy type to hold the dynamically typed value.
+ --
+ -- In GHC's new eval/apply execution model this type must
+ -- be polymorphic.  It can't be a constructor, because then
+ -- GHC will use the constructor convention when evaluating it,
+ -- and this will go wrong if the object is really a function.  On
+ -- the other hand, if we use a polymorphic type, GHC will use
+ -- a fallback convention for evaluating it that works for all types.
+ -- (using a function type here would also work).
+#elif !defined(__HUGS__)
+data Obj = Obj
+#endif
 
+-- | Converts an arbitrary value into an object of type 'Dynamic'.  
+--
+-- The type of the object must be an instance of 'Typeable', which
+-- ensures that only monomorphically-typed objects may be converted to
+-- 'Dynamic'.  To convert a polymorphic object into 'Dynamic', give it
+-- a monomorphic type signature.  For example:
+--
+-- >    toDyn (id :: Int -> Int)
+--
 toDyn :: Typeable a => a -> Dynamic
 toDyn v = Dynamic (typeOf v) (unsafeCoerce v)
 
-fromDyn :: Typeable a => Dynamic -> a -> a
+-- | Converts a 'Dynamic' object back into an ordinary Haskell value of
+-- the correct type.  See also 'fromDynamic'.
+fromDyn :: Typeable a
+ 	=> Dynamic 	-- ^ the dynamically-typed object
+	-> a		-- ^ a default value 
+	-> a		-- ^ returns: the value of the first argument, if
+			-- it has the correct type, otherwise the value of
+			-- the second argument.
 fromDyn (Dynamic t v) def
   | typeOf def == t = unsafeCoerce v
   | otherwise       = def
 
-fromDynamic :: Typeable a => Dynamic -> Maybe a
+-- | Converts a 'Dynamic' object back into an ordinary Haskell value of
+-- the correct type.  See also 'fromDyn'.
+fromDynamic
+	:: Typeable a
+	=> Dynamic	-- ^ the dynamically-typed object
+	-> Maybe a	-- ^ returns: @'Just' a@, if the dyanmically-typed
+			-- object has the correct type (and @a@ is its value), 
+			-- or 'Nothing' otherwise.
 fromDynamic (Dynamic t v) =
   case unsafeCoerce v of 
     r | t == typeOf r -> Just r
       | otherwise     -> Nothing
 
--- (Abstract) universal datatype:
+-- (f::(a->b)) `dynApply` (x::a) = (f a)::b
+dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
+dynApply (Dynamic t1 f) (Dynamic t2 x) =
+  case applyTy t1 t2 of
+    Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
+    Nothing -> Nothing
 
-instance Show TypeRep where
-  showsPrec p (App tycon tys) =
-    case tys of
-      [] -> showsPrec p tycon
-      [x] | tycon == listTc    -> showChar '[' . shows x . showChar ']'
-      xs  
-        | isTupleTyCon tycon -> showTuple tycon xs
-	| otherwise	     ->
-	    showParen (p > 9) $
-   	    showsPrec p tycon . 
-	    showChar ' '      . 
-	    showArgs tys
+dynApp :: Dynamic -> Dynamic -> Dynamic
+dynApp f x = case dynApply f x of 
+             Just r -> r
+             Nothing -> error ("Type error in dynamic application.\n" ++
+                               "Can't apply function " ++ show f ++
+                               " to argument " ++ show x)
 
-  showsPrec p (Fun f a) =
-     showParen (p > 8) $
-     showsPrec 9 f . showString " -> " . showsPrec 8 a
+#ifndef __HUGS__
+-------------------------------------------------------------
+--
+--		Type representations
+--
+-------------------------------------------------------------
 
--- To make it possible to convert values with user-defined types
--- into type Dynamic, we need a systematic way of getting
--- the type representation of an arbitrary type. A type
--- class provides just the ticket,
+-- | A concrete representation of a (monomorphic) type.  'TypeRep'
+-- supports reasonably efficient equality.
+data TypeRep = TypeRep !Key TyCon [TypeRep] 
 
-class Typeable a where
-  typeOf :: a -> TypeRep
+-- Compare keys for equality
+instance Eq TypeRep where
+  (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
 
--- NOTE: The argument to the overloaded `typeOf' is only
--- used to carry type information, and Typeable instances
--- should *never* *ever* look at its value.
+-- | An abstract representation of a type constructor.  'TyCon' objects can
+-- be built using 'mkTyCon'.
+data TyCon = TyCon !Key String
 
-isTupleTyCon :: TyCon -> Bool
-isTupleTyCon (TyCon _ (',':_)) = True
-isTupleTyCon _		       = False
+instance Eq TyCon where
+  (TyCon t1 _) == (TyCon t2 _) = t1 == t2
+#endif
 
-instance Show TyCon where
-  showsPrec _ (TyCon _ s) = showString s
+----------------- Type-safe cast ------------------
+
+-- | The type-safe cast operation
+cast :: (Typeable a, Typeable b) => a -> Maybe b
+cast x = r
+       where
+	 r = if typeOf x == typeOf (fromJust r) then
+			Just (unsafeCoerce x)
+	     else
+			Nothing
+
+----------------- Construction --------------------
+
+-- | Applies a type constructor to a sequence of types
+mkAppTy  :: TyCon -> [TypeRep] -> TypeRep
+mkAppTy tc@(TyCon tc_k _) args 
+  = TypeRep (appKeys tc_k arg_ks) tc args
+  where
+    arg_ks = [k | TypeRep k _ _ <- args]
+
+funTc :: TyCon
+funTc = mkTyCon "->"
+
+-- | A special case of 'mkAppTy', which applies the function 
+-- type constructor to a pair of types.
+mkFunTy  :: TypeRep -> TypeRep -> TypeRep
+mkFunTy f a = mkAppTy funTc [f,a]
+
+-- | Applies a type to a function type.  Returns: @'Just' u@ if the
+-- first argument represents a function of type @t -> u@ and the
+-- second argument represents a function of type @t@.  Otherwise,
+-- returns 'Nothing'.
+applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
+applyTy (TypeRep _ tc [t1,t2]) t3
+  | tc == funTc && t1 == t3	= Just t2
+applyTy _ _     		= Nothing
 
 -- If we enforce the restriction that there is only one
 -- @TyCon@ for a type & it is shared among all its uses,
@@ -160,15 +265,45 @@ instance Show TyCon where
 -- If this constraint does turn out to be a sore thumb, changing
 -- the Eq instance for TyCons is trivial.
 
-mkTyCon :: String -> TyCon
-mkTyCon str = unsafePerformIO $ do
-   v <- readIORef uni
-   writeIORef uni (v+1)
-   return (TyCon v str)
+-- | Builds a 'TyCon' object representing a type constructor.  An
+-- implementation of "Data.Dynamic" should ensure that the following holds:
+--
+-- >  mkTyCon "a" == mkTyCon "a"
+--
+-- NOTE: GHC\'s implementation is quite hacky, and the above equation
+-- does not necessarily hold.  For defining your own instances of
+-- 'Typeable', try to ensure that only one call to 'mkTyCon' exists
+-- for each type constructor (put it at the top level, and annotate the
+-- corresponding definition with a @NOINLINE@ pragma).
+mkTyCon :: String	-- ^ the name of the type constructor (should be unique
+			-- in the program, so it might be wise to use the
+			-- fully qualified name).
+	-> TyCon	-- ^ A unique 'TyCon' object
+mkTyCon str = TyCon (mkTyConKey str) str
+
 
-{-# NOINLINE uni #-}
-uni :: IORef Int
-uni = unsafePerformIO ( newIORef 0 )
+----------------- Showing TypeReps --------------------
+
+instance Show TypeRep where
+  showsPrec p (TypeRep _ tycon tys) =
+    case tys of
+      [] -> showsPrec p tycon
+      [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'
+      [a,r] | tycon == funTc  -> showParen (p > 8) $
+			         showsPrec 9 a . showString " -> " . showsPrec 8 r
+      xs | isTupleTyCon tycon -> showTuple tycon xs
+	 | otherwise	     ->
+	    showParen (p > 9) $
+   	    showsPrec p tycon . 
+	    showChar ' '      . 
+	    showArgs tys
+
+instance Show TyCon where
+  showsPrec _ (TyCon _ s) = showString s
+
+isTupleTyCon :: TyCon -> Bool
+isTupleTyCon (TyCon _ (',':_)) = True
+isTupleTyCon _		       = False
 
 -- Some (Show.TypeRep) helpers:
 
@@ -186,40 +321,32 @@ showTuple (TyCon _ str) args = showChar '(' . go str args
   go _ _   = showChar ')'
 
 
-mkAppTy  :: TyCon   -> [TypeRep] -> TypeRep
-mkAppTy tyc args = App tyc args
-
-mkFunTy  :: TypeRep -> TypeRep   -> TypeRep
-mkFunTy f a = Fun f a
 
--- Auxillary functions
-
--- (f::(a->b)) `dynApply` (x::a) = (f a)::b
-dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
-dynApply (Dynamic t1 f) (Dynamic t2 x) =
-  case applyTy t1 t2 of
-    Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
-    Nothing -> Nothing
-
-dynApp :: Dynamic -> Dynamic -> Dynamic
-dynApp f x = case dynApply f x of 
-             Just r -> r
-             Nothing -> error ("Type error in dynamic application.\n" ++
-                               "Can't apply function " ++ show f ++
-                               " to argument " ++ show x)
+-------------------------------------------------------------
+--
+--	The Typeable class and some instances
+--
+-------------------------------------------------------------
 
-applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
-applyTy (Fun t1 t2) t3
-  | t1 == t3    = Just t2
-applyTy _ _     = Nothing
+-- | The class 'Typeable' allows a concrete representation of a type to
+-- be calculated.
+class Typeable a where
+  typeOf :: a -> TypeRep
+  -- ^ Takes a value of type @a@ and returns a concrete representation
+  -- of that type.  The /value/ of the argument should be ignored by
+  -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
+  -- the argument.
 
 -- Prelude types
-
 listTc :: TyCon
 listTc = mkTyCon "[]"
 
 instance Typeable a => Typeable [a] where
-  typeOf ls = mkAppTy listTc [typeOf ((undefined:: [a] -> a) ls)]
+  typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)]
+	-- In GHC we can say
+	--	typeOf (undefined :: a)
+	-- using scoped type variables, but we use the 
+	-- more verbose form here, for compatibility with Hugs
 
 unitTc :: TyCon
 unitTc = mkTyCon "()"
@@ -253,7 +380,6 @@ instance ( Typeable a
 			      typeOf ((undefined :: (a,b,c,d) -> b) tu),
 			      typeOf ((undefined :: (a,b,c,d) -> c) tu),
 			      typeOf ((undefined :: (a,b,c,d) -> d) tu)]
-
 tup5Tc :: TyCon
 tup5Tc = mkTyCon ",,,,"
 
@@ -272,6 +398,7 @@ instance (Typeable a, Typeable b) => Typeable (a -> b) where
   typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
 		     (typeOf ((undefined :: (a -> b) -> b) f))
 
+#ifndef __NHC__
 INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
 INSTANCE_TYPEABLE0(Char,charTc,"Char")
 INSTANCE_TYPEABLE0(Float,floatTc,"Float")
@@ -282,7 +409,90 @@ INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
 INSTANCE_TYPEABLE1(IO,ioTc,"IO")
 INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
 INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
+INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
+INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
 
-INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
+INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
+INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
+INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
+INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
+
+INSTANCE_TYPEABLE0(Word8,word8Tc, "Word8" )
+INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
+INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
+INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
+
+INSTANCE_TYPEABLE0(TyCon,tyconTc,    "TyCon")
 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
 INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic")
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
+#endif
+
+---------------------------------------------
+--
+--		Internals 
+--
+---------------------------------------------
+
+#ifndef __HUGS__
+newtype Key = Key Int deriving( Eq )
+#endif
+
+data KeyPr = KeyPr !Key !Key deriving( Eq )
+
+hashKP :: KeyPr -> Int32
+hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
+
+data Cache = Cache { next_key :: !(IORef Key),
+		     tc_tbl   :: !(HT.HashTable String Key),
+		     ap_tbl   :: !(HT.HashTable KeyPr Key) }
+
+{-# NOINLINE cache #-}
+cache :: Cache
+cache = unsafePerformIO $ do
+		empty_tc_tbl <- HT.new (==) HT.hashString
+		empty_ap_tbl <- HT.new (==) hashKP
+		key_loc      <- newIORef (Key 1) 
+		return (Cache { next_key = key_loc,
+				tc_tbl = empty_tc_tbl, 
+				ap_tbl = empty_ap_tbl })
+
+newKey :: IORef Key -> IO Key
+newKey kloc = do { k@(Key i) <- readIORef kloc ;
+		   writeIORef kloc (Key (i+1)) ;
+		   return k }
+
+mkTyConKey :: String -> Key
+mkTyConKey str 
+  = unsafePerformIO $ do
+	let Cache {next_key = kloc, tc_tbl = tbl} = cache
+	mb_k <- HT.lookup tbl str
+	case mb_k of
+	  Just k  -> return k
+	  Nothing -> do { k <- newKey kloc ;
+			  HT.insert tbl str k ;
+			  return k }
+
+appKey :: Key -> Key -> Key
+appKey k1 k2
+  = unsafePerformIO $ do
+	let Cache {next_key = kloc, ap_tbl = tbl} = cache
+	mb_k <- HT.lookup tbl kpr
+	case mb_k of
+	  Just k  -> return k
+	  Nothing -> do { k <- newKey kloc ;
+			  HT.insert tbl kpr k ;
+			  return k }
+  where
+    kpr = KeyPr k1 k2
+
+appKeys :: Key -> [Key] -> Key
+appKeys k ks = foldl appKey k ks
+
+
+
+
+