{-# 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 : portable
--
--- $Id: Dynamic.hs,v 1.4 2001/12/21 15:07:21 simonmar Exp $
---
-- The Dynamic interface provides basic support for dynamic types.
--
-- Operations for injecting values of arbitrary type into
-- 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
- , 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 ",,")
import Data.Maybe
import Data.Either
+import Data.Int
+import Data.Word
+import Foreign.Ptr
+import Foreign.StablePtr
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.Num
import GHC.Float
import GHC.IOBase
-import GHC.Dynamic
+import GHC.List( lookup, foldl )
+#endif
+
+#ifdef __HUGS__
+import Hugs.Prelude
+import Hugs.IO
+import Hugs.IORef
+import Hugs.IOExts
#endif
#ifdef __GLASGOW_HASKELL__
unsafeCoerce = unsafeCoerce#
#endif
+#ifdef __NHC__
+import NonStdUnsafeCoerce (unsafeCoerce)
+import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
+#else
#include "Dynamic.h"
+#endif
+
+-------------------------------------------------------------
+--
+-- 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').
--- The dynamic type is represented by Dynamic, carrying
--- the dynamic value along with its type representation:
+ '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
+
+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)
+
+-------------------------------------------------------------
+--
+-- Type representations
+--
+-------------------------------------------------------------
+
+-- | A concrete representation of a (monomorphic) type. 'TypeRep'
+-- supports reasonably efficient equality.
+#ifndef __HUGS__
+data TypeRep = TypeRep !Key TyCon [TypeRep]
+
+-- Compare keys for equality
+instance Eq TypeRep where
+ (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
+
+-- | An abstract representation of a type constructor. 'TyCon' objects can
+-- be built using 'mkTyCon'.
+data TyCon = TyCon !Key String
+
+instance Eq TyCon where
+ (TyCon t1 _) == (TyCon t2 _) = t1 == t2
+#endif
instance Show TypeRep where
- showsPrec p (App tycon tys) =
+ showsPrec p (TypeRep _ tycon tys) =
case tys of
[] -> showsPrec p tycon
- [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
- xs
- | isTupleTyCon tycon -> showTuple tycon xs
- | otherwise ->
+ [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
- showsPrec p (Fun f a) =
- showParen (p > 8) $
- showsPrec 9 f . showString " -> " . showsPrec 8 a
-
--- 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,
-
-class Typeable a where
- typeOf :: a -> TypeRep
-
--- NOTE: The argument to the overloaded `typeOf' is only
--- used to carry type information, and Typeable instances
--- should *never* *ever* look at its value.
+instance Show TyCon where
+ showsPrec _ (TyCon _ s) = showString s
isTupleTyCon :: TyCon -> Bool
isTupleTyCon (TyCon _ (',':_)) = True
isTupleTyCon _ = False
-instance Show TyCon where
- showsPrec _ (TyCon _ s) = showString s
-
-- If we enforce the restriction that there is only one
-- @TyCon@ for a type & it is shared among all its uses,
-- we can map them onto Ints very simply. The benefit is,
-- 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)
-
-{-# NOINLINE uni #-}
-uni :: IORef Int
-uni = unsafePerformIO ( newIORef 0 )
+-- | 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
-- Some (Show.TypeRep) helpers:
go _ _ = showChar ')'
-mkAppTy :: TyCon -> [TypeRep] -> TypeRep
-mkAppTy tyc args = App tyc args
+-- | 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 = Fun f a
+mkFunTy f a = mkAppTy funTc [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
+-- | 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
-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)
-applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
-applyTy (Fun t1 t2) t3
- | t1 == t3 = Just t2
-applyTy _ _ = Nothing
+-------------------------------------------------------------
+--
+-- The Typeable class and some instances
+--
+-------------------------------------------------------------
--- Prelude types
+-- | 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 "()"
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 ",,,,"
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")
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
+--
+---------------------------------------------
+
+newtype Key = Key Int deriving( Eq )
+
+appKeys :: Key -> [Key] -> Key
+appKeys k ks = foldl appKey k ks
+
+appKey :: Key -> Key -> Key
+appKey (Key k1) (Key k2)
+ = unsafePerformIO $ do
+ (v, cache) <- readIORef memo
+ case lookup (k1,k2) cache of
+ Just k -> return (Key k)
+ Nothing -> do writeIORef memo (v+1, ((k1,k2),v) : cache)
+ return (Key v)
+
+memo :: IORef (Int, [((Int,Int),Int)])
+memo = unsafePerformIO (newIORef (1000, []))
+ -- 1000, yuk!
+
+mkTyConKey :: String -> Key
+mkTyConKey str = unsafePerformIO $ do
+ v <- readIORef uni
+ writeIORef uni (v+1)
+ return (str `seq` Key v)
+
+{-# NOINLINE uni #-}
+uni :: IORef Int
+uni = unsafePerformIO ( newIORef 0 )
projects / ghc-base.git / blobdiff