Remove AltData, yay.
This commit is contained in:
Lemmih
parent
afc53152e9
commit
7856e250aa
@ -1,162 +0,0 @@
|
||||
{-# OPTIONS -fglasgow-exts #-}
|
||||
--
|
||||
-- |
|
||||
-- Module : Data.Dynamic
|
||||
-- Copyright : (c) The University of Glasgow 2001
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
--
|
||||
-- The Dynamic interface provides basic support for dynamic types.
|
||||
--
|
||||
-- Operations for injecting values of arbitrary type into
|
||||
-- a dynamically typed value, Dynamic, are provided, together
|
||||
-- with operations for converting dynamic values into a concrete
|
||||
-- (monomorphic) type.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module AltData.Dynamic (
|
||||
|
||||
-- Module Data.Typeable re-exported for convenience
|
||||
module AltData.Typeable,
|
||||
|
||||
-- * 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
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 603
|
||||
-- * Applying functions of dynamic type
|
||||
dynApply,
|
||||
dynApp,
|
||||
dynTypeRep
|
||||
|
||||
#endif
|
||||
) where
|
||||
|
||||
import AltData.Typeable
|
||||
import Data.Maybe
|
||||
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
import GHC.Base
|
||||
import GHC.Show
|
||||
#if __GLASGOW_HASKELL__ >= 603
|
||||
import GHC.Err
|
||||
#endif
|
||||
|
||||
unsafeCoerce :: a -> b
|
||||
unsafeCoerce = unsafeCoerce#
|
||||
|
||||
-------------------------------------------------------------
|
||||
--
|
||||
-- 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.
|
||||
-}
|
||||
data Dynamic = Dynamic TypeRep Obj
|
||||
|
||||
instance Typeable Dynamic where
|
||||
#if __GLASGOW_HASKELL__ >= 603
|
||||
typeOf _ = mkTyConApp (mkTyCon "AltData.Dynamic") []
|
||||
#else
|
||||
typeOf _ = mkAppTy (mkTyCon "AltData.Dynamic") []
|
||||
#endif
|
||||
|
||||
instance Show Dynamic where
|
||||
-- the instance just prints the type representation.
|
||||
showsPrec _ (Dynamic t _) =
|
||||
showString "<<" .
|
||||
showsPrec 0 t .
|
||||
showString ">>"
|
||||
|
||||
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).
|
||||
|
||||
-- | 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)
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | 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 dynamically-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 -> unsafePerformIO (putStrLn $
|
||||
"Couldn't match `" ++show(typeOf r) ++
|
||||
"' against `" ++show t ++"'"++
|
||||
"\n\tExpected type: " ++show(typeOf r) ++
|
||||
"\n\tInferred type: " ++show t
|
||||
) `seq` Nothing
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 603
|
||||
|
||||
-- (f::(a->b)) `dynApply` (x::a) = (f a)::b
|
||||
dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
|
||||
dynApply (Dynamic t1 f) (Dynamic t2 x) =
|
||||
case funResultTy 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)
|
||||
|
||||
dynTypeRep :: Dynamic -> TypeRep
|
||||
dynTypeRep (Dynamic tr _) = tr
|
||||
|
||||
#endif
|
||||
@ -1,960 +0,0 @@
|
||||
{-# OPTIONS -fglasgow-exts #-}
|
||||
--
|
||||
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
|
||||
--
|
||||
-- This library is free software; you can redistribute it and/or
|
||||
-- modify it under the terms of the GNU Lesser General Public
|
||||
-- License as published by the Free Software Foundation; either
|
||||
-- version 2.1 of the License, or (at your option) any later version.
|
||||
--
|
||||
-- This library is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
-- Lesser General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Lesser General Public
|
||||
-- License along with this library; if not, write to the Free Software
|
||||
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
|
||||
-- USA
|
||||
--
|
||||
|
||||
-- Based on:
|
||||
--
|
||||
-- |
|
||||
-- Module : Data.Typeable
|
||||
-- Copyright : (c) The University of Glasgow, CWI 2001--2004
|
||||
-- License : BSD-style (see the file libraries/base/LICENSE)
|
||||
--
|
||||
-- Maintainer : libraries@haskell.org
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
--
|
||||
-- The Typeable class reifies types to some extent by associating type
|
||||
-- representations to types. These type representations can be compared,
|
||||
-- and one can in turn define a type-safe cast operation. To this end,
|
||||
-- an unsafe cast is guarded by a test for type (representation)
|
||||
-- equivalence. The module Data.Dynamic uses Typeable for an
|
||||
-- implementation of dynamics. The module Data.Generics uses Typeable
|
||||
-- and type-safe cast (but not dynamics) to support the \"Scrap your
|
||||
-- boilerplate\" style of generic programming.
|
||||
--
|
||||
|
||||
module AltData.Typeable
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 603
|
||||
(
|
||||
|
||||
-- * The Typeable class
|
||||
Typeable( typeOf ), -- :: a -> TypeRep
|
||||
|
||||
-- * Type-safe cast
|
||||
cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
|
||||
gcast, -- a generalisation of cast
|
||||
|
||||
-- * Type representations
|
||||
TypeRep, -- abstract, instance of: Eq, Show, Typeable
|
||||
TyCon, -- abstract, instance of: Eq, Show, Typeable
|
||||
|
||||
-- * Construction of type representations
|
||||
mkTyCon, -- :: String -> TyCon
|
||||
mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep
|
||||
mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep
|
||||
mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
|
||||
|
||||
-- * Observation of type representations
|
||||
splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep])
|
||||
funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
|
||||
typeRepTyCon, -- :: TypeRep -> TyCon
|
||||
typeRepArgs, -- :: TypeRep -> [TypeRep]
|
||||
tyConString, -- :: TyCon -> String
|
||||
|
||||
-- * The other Typeable classes
|
||||
-- | /Note:/ The general instances are provided for GHC only.
|
||||
Typeable1( typeOf1 ), -- :: t a -> TypeRep
|
||||
Typeable2( typeOf2 ), -- :: t a b -> TypeRep
|
||||
Typeable3( typeOf3 ), -- :: t a b c -> TypeRep
|
||||
Typeable4( typeOf4 ), -- :: t a b c d -> TypeRep
|
||||
Typeable5( typeOf5 ), -- :: t a b c d e -> TypeRep
|
||||
Typeable6( typeOf6 ), -- :: t a b c d e f -> TypeRep
|
||||
Typeable7( typeOf7 ), -- :: t a b c d e f g -> TypeRep
|
||||
gcast1, -- :: ... => c (t a) -> Maybe (c (t' a))
|
||||
gcast2, -- :: ... => c (t a b) -> Maybe (c (t' a b))
|
||||
|
||||
-- * Default instances
|
||||
-- | /Note:/ These are not needed by GHC, for which these instances
|
||||
-- are generated by general instance declarations.
|
||||
typeOfDefault, -- :: (Typeable1 t, Typeable a) => t a -> TypeRep
|
||||
typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep
|
||||
typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
|
||||
typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
|
||||
typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
|
||||
typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
|
||||
typeOf6Default -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
|
||||
|
||||
) where
|
||||
|
||||
import qualified Data.HashTable as HT
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
import Data.Int
|
||||
import Data.Word
|
||||
import Data.List( foldl )
|
||||
|
||||
import GHC.Base
|
||||
import GHC.Show
|
||||
import GHC.Err
|
||||
import GHC.Num
|
||||
import GHC.Float
|
||||
import GHC.Real( rem, Ratio )
|
||||
import GHC.IOBase
|
||||
import GHC.Ptr -- So we can give Typeable instance for Ptr
|
||||
import GHC.Stable -- So we can give Typeable instance for StablePtr
|
||||
|
||||
unsafeCoerce :: a -> b
|
||||
unsafeCoerce = unsafeCoerce#
|
||||
|
||||
#include "Typeable.h"
|
||||
|
||||
-------------------------------------------------------------
|
||||
--
|
||||
-- Type representations
|
||||
--
|
||||
-------------------------------------------------------------
|
||||
|
||||
-- | A concrete representation of a (monomorphic) type. 'TypeRep'
|
||||
-- supports reasonably efficient equality.
|
||||
--
|
||||
-- equality of keys doesn't work for dynamically loaded code, so we
|
||||
-- revert back to canonical type names.
|
||||
--
|
||||
-- could use packed strings here.
|
||||
--
|
||||
data TypeRep = TypeRep !Key TyCon [TypeRep]
|
||||
|
||||
-- Compare keys for equality
|
||||
instance Eq TypeRep where
|
||||
(TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2
|
||||
|
||||
-- | An abstract representation of a type constructor. 'TyCon' objects can
|
||||
-- be built using 'mkTyCon'.
|
||||
data TyCon = TyCon !Key String
|
||||
|
||||
instance Eq TyCon where
|
||||
(TyCon _ s1) == (TyCon _ s2) = s1 == s2
|
||||
|
||||
--
|
||||
-- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")
|
||||
-- [fTy,fTy,fTy])
|
||||
--
|
||||
-- returns "(Foo,Foo,Foo)"
|
||||
--
|
||||
-- The TypeRep Show instance promises to print tuple types
|
||||
-- correctly. Tuple type constructors are specified by a
|
||||
-- sequence of commas, e.g., (mkTyCon ",,,,") returns
|
||||
-- the 5-tuple tycon.
|
||||
|
||||
----------------- Construction --------------------
|
||||
|
||||
-- | Applies a type constructor to a sequence of types
|
||||
mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
|
||||
mkTyConApp tc@(TyCon tc_k _) args
|
||||
= TypeRep (appKeys tc_k arg_ks) tc args
|
||||
where
|
||||
arg_ks = [k | TypeRep k _ _ <- args]
|
||||
|
||||
-- | A special case of 'mkTyConApp', which applies the function
|
||||
-- type constructor to a pair of types.
|
||||
mkFunTy :: TypeRep -> TypeRep -> TypeRep
|
||||
mkFunTy f a = mkTyConApp funTc [f,a]
|
||||
|
||||
-- | Splits a type constructor application
|
||||
splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
|
||||
splitTyConApp (TypeRep _ tc trs) = (tc,trs)
|
||||
|
||||
-- | 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'.
|
||||
funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
|
||||
funResultTy trFun trArg
|
||||
= case splitTyConApp trFun of
|
||||
(tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
|
||||
_ -> Nothing
|
||||
|
||||
-- | Adds a TypeRep argument to a TypeRep.
|
||||
mkAppTy :: TypeRep -> TypeRep -> TypeRep
|
||||
mkAppTy (TypeRep tr_k tc trs) arg_tr
|
||||
= let (TypeRep arg_k _ _) = arg_tr
|
||||
in TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr])
|
||||
|
||||
-- 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,
|
||||
-- of course, that @TyCon@s can then be compared efficiently.
|
||||
|
||||
-- Provided the implementor of other @Typeable@ instances
|
||||
-- takes care of making all the @TyCon@s CAFs (toplevel constants),
|
||||
-- this will work.
|
||||
|
||||
-- If this constraint does turn out to be a sore thumb, changing
|
||||
-- the Eq instance for TyCons is trivial.
|
||||
|
||||
-- | Builds a 'TyCon' object representing a type constructor. An
|
||||
-- implementation of "Data.Typeable" should ensure that the following holds:
|
||||
--
|
||||
-- > mkTyCon "a" == mkTyCon "a"
|
||||
--
|
||||
|
||||
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
|
||||
|
||||
----------------- Observation ---------------------
|
||||
|
||||
-- | Observe the type constructor of a type representation
|
||||
typeRepTyCon :: TypeRep -> TyCon
|
||||
typeRepTyCon (TypeRep _ tc _) = tc
|
||||
|
||||
-- | Observe the argument types of a type representation
|
||||
typeRepArgs :: TypeRep -> [TypeRep]
|
||||
typeRepArgs (TypeRep _ _ args) = args
|
||||
|
||||
-- | Observe string encoding of a type representation
|
||||
tyConString :: TyCon -> String
|
||||
tyConString (TyCon _ str) = str
|
||||
|
||||
----------------- 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:
|
||||
|
||||
showArgs :: Show a => [a] -> ShowS
|
||||
showArgs [] = id
|
||||
showArgs [a] = showsPrec 10 a
|
||||
showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
|
||||
|
||||
showTuple :: TyCon -> [TypeRep] -> ShowS
|
||||
showTuple (TyCon _ str) args = showChar '(' . go str args
|
||||
where
|
||||
go [] [a] = showsPrec 10 a . showChar ')'
|
||||
go _ [] = showChar ')' -- a failure condition, really.
|
||||
go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
|
||||
go _ _ = showChar ')'
|
||||
|
||||
-------------------------------------------------------------
|
||||
--
|
||||
-- The Typeable class and friends
|
||||
--
|
||||
-------------------------------------------------------------
|
||||
|
||||
-- | 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.
|
||||
|
||||
-- | Variant for unary type constructors
|
||||
class Typeable1 t where
|
||||
typeOf1 :: t a -> TypeRep
|
||||
|
||||
-- | For defining a 'Typeable' instance from any 'Typeable1' instance.
|
||||
typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
|
||||
typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
|
||||
where
|
||||
argType :: t a -> a
|
||||
argType = undefined
|
||||
|
||||
-- | Variant for binary type constructors
|
||||
class Typeable2 t where
|
||||
typeOf2 :: t a b -> TypeRep
|
||||
|
||||
-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
|
||||
typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
|
||||
typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
|
||||
where
|
||||
argType :: t a b -> a
|
||||
argType = undefined
|
||||
|
||||
-- | Variant for 3-ary type constructors
|
||||
class Typeable3 t where
|
||||
typeOf3 :: t a b c -> TypeRep
|
||||
|
||||
-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
|
||||
typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
|
||||
typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
|
||||
where
|
||||
argType :: t a b c -> a
|
||||
argType = undefined
|
||||
|
||||
-- | Variant for 4-ary type constructors
|
||||
class Typeable4 t where
|
||||
typeOf4 :: t a b c d -> TypeRep
|
||||
|
||||
-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
|
||||
typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
|
||||
typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
|
||||
where
|
||||
argType :: t a b c d -> a
|
||||
argType = undefined
|
||||
|
||||
-- | Variant for 5-ary type constructors
|
||||
class Typeable5 t where
|
||||
typeOf5 :: t a b c d e -> TypeRep
|
||||
|
||||
-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
|
||||
typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
|
||||
typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
|
||||
where
|
||||
argType :: t a b c d e -> a
|
||||
argType = undefined
|
||||
|
||||
-- | Variant for 6-ary type constructors
|
||||
class Typeable6 t where
|
||||
typeOf6 :: t a b c d e f -> TypeRep
|
||||
|
||||
-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
|
||||
typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
|
||||
typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
|
||||
where
|
||||
argType :: t a b c d e f -> a
|
||||
argType = undefined
|
||||
|
||||
-- | Variant for 7-ary type constructors
|
||||
class Typeable7 t where
|
||||
typeOf7 :: t a b c d e f g -> TypeRep
|
||||
|
||||
-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
|
||||
typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
|
||||
typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
|
||||
where
|
||||
argType :: t a b c d e f g -> a
|
||||
argType = undefined
|
||||
|
||||
-- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
|
||||
-- define the instances for partial applications.
|
||||
-- Programmers using non-GHC implementations must do this manually
|
||||
-- for each type constructor.
|
||||
-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)
|
||||
|
||||
-- | One Typeable instance for all Typeable1 instances
|
||||
instance (Typeable1 s, Typeable a)
|
||||
=> Typeable (s a) where
|
||||
typeOf = typeOfDefault
|
||||
|
||||
-- | One Typeable1 instance for all Typeable2 instances
|
||||
instance (Typeable2 s, Typeable a)
|
||||
=> Typeable1 (s a) where
|
||||
typeOf1 = typeOf1Default
|
||||
|
||||
-- | One Typeable2 instance for all Typeable3 instances
|
||||
instance (Typeable3 s, Typeable a)
|
||||
=> Typeable2 (s a) where
|
||||
typeOf2 = typeOf2Default
|
||||
|
||||
-- | One Typeable3 instance for all Typeable4 instances
|
||||
instance (Typeable4 s, Typeable a)
|
||||
=> Typeable3 (s a) where
|
||||
typeOf3 = typeOf3Default
|
||||
|
||||
-- | One Typeable4 instance for all Typeable5 instances
|
||||
instance (Typeable5 s, Typeable a)
|
||||
=> Typeable4 (s a) where
|
||||
typeOf4 = typeOf4Default
|
||||
|
||||
-- | One Typeable5 instance for all Typeable6 instances
|
||||
instance (Typeable6 s, Typeable a)
|
||||
=> Typeable5 (s a) where
|
||||
typeOf5 = typeOf5Default
|
||||
|
||||
-- | One Typeable6 instance for all Typeable7 instances
|
||||
instance (Typeable7 s, Typeable a)
|
||||
=> Typeable6 (s a) where
|
||||
typeOf6 = typeOf6Default
|
||||
|
||||
-------------------------------------------------------------
|
||||
--
|
||||
-- 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
|
||||
|
||||
-- | A flexible variation parameterised in a type constructor
|
||||
gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b)
|
||||
gcast x = r
|
||||
where
|
||||
r = if typeOf (getArg x) == typeOf (getArg (fromJust r))
|
||||
then Just $ unsafeCoerce x
|
||||
else Nothing
|
||||
getArg :: c x -> x
|
||||
getArg = undefined
|
||||
|
||||
-- | Cast for * -> *
|
||||
gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a))
|
||||
gcast1 x = r
|
||||
where
|
||||
r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))
|
||||
then Just $ unsafeCoerce x
|
||||
else Nothing
|
||||
getArg :: c x -> x
|
||||
getArg = undefined
|
||||
|
||||
-- | Cast for * -> * -> *
|
||||
gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b))
|
||||
gcast2 x = r
|
||||
where
|
||||
r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))
|
||||
then Just $ unsafeCoerce x
|
||||
else Nothing
|
||||
getArg :: c x -> x
|
||||
getArg = undefined
|
||||
|
||||
-------------------------------------------------------------
|
||||
--
|
||||
-- Instances of the Typeable classes for Prelude types
|
||||
--
|
||||
-------------------------------------------------------------
|
||||
|
||||
INSTANCE_TYPEABLE1([],listTc,"[]")
|
||||
INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
|
||||
INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
|
||||
INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
|
||||
INSTANCE_TYPEABLE2((->),funTc,"->")
|
||||
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
|
||||
INSTANCE_TYPEABLE0((),unitTc,"()")
|
||||
|
||||
INSTANCE_TYPEABLE2((,),pairTc,",")
|
||||
INSTANCE_TYPEABLE3((,,),tup3Tc,",,")
|
||||
|
||||
tup4Tc :: TyCon
|
||||
tup4Tc = mkTyCon ",,,"
|
||||
|
||||
instance Typeable4 (,,,) where
|
||||
typeOf4 _ = mkTyConApp tup4Tc []
|
||||
|
||||
tup5Tc :: TyCon
|
||||
tup5Tc = mkTyCon ",,,,"
|
||||
|
||||
instance Typeable5 (,,,,) where
|
||||
typeOf5 _ = mkTyConApp tup5Tc []
|
||||
|
||||
tup6Tc :: TyCon
|
||||
tup6Tc = mkTyCon ",,,,,"
|
||||
|
||||
instance Typeable6 (,,,,,) where
|
||||
typeOf6 _ = mkTyConApp tup6Tc []
|
||||
|
||||
tup7Tc :: TyCon
|
||||
tup7Tc = mkTyCon ",,,,,"
|
||||
|
||||
instance Typeable7 (,,,,,,) where
|
||||
typeOf7 _ = mkTyConApp tup7Tc []
|
||||
|
||||
INSTANCE_TYPEABLE1(Ptr,ptrTc,"Foreign.Ptr.Ptr")
|
||||
INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"Foreign.StablePtr.StablePtr")
|
||||
INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.IORef")
|
||||
|
||||
-------------------------------------------------------
|
||||
--
|
||||
-- Generate Typeable instances for standard datatypes
|
||||
--
|
||||
-------------------------------------------------------
|
||||
|
||||
INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
|
||||
INSTANCE_TYPEABLE0(Char,charTc,"Char")
|
||||
INSTANCE_TYPEABLE0(Float,floatTc,"Float")
|
||||
INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
|
||||
INSTANCE_TYPEABLE0(Int,intTc,"Int")
|
||||
INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
|
||||
INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
|
||||
INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
|
||||
|
||||
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(Word,wordTc,"Word" )
|
||||
|
||||
#else /* GHC < 6.3 */
|
||||
|
||||
(
|
||||
-- * The Typeable class
|
||||
Typeable( typeOf ), -- :: a -> TypeRep
|
||||
|
||||
-- * Type-safe cast
|
||||
cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
|
||||
castss, -- a cast for kind "* -> *"
|
||||
castarr, -- another convenient variation
|
||||
|
||||
-- * Type representations
|
||||
TypeRep, -- abstract, instance of: Eq, Show, Typeable
|
||||
TyCon, -- abstract, instance of: Eq, Show, Typeable
|
||||
|
||||
-- * Construction of type representations
|
||||
mkTyCon, -- :: String -> TyCon
|
||||
mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep
|
||||
mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
|
||||
applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
|
||||
|
||||
-- * Observation of type representations
|
||||
typerepTyCon, -- :: TypeRep -> TyCon
|
||||
typerepArgs, -- :: TypeRep -> [TypeRep]
|
||||
tyconString -- :: TyCon -> String
|
||||
|
||||
|
||||
) where
|
||||
|
||||
import qualified Data.HashTable as HT
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
import Data.Int
|
||||
import Data.Word
|
||||
import Data.List( foldl )
|
||||
|
||||
import GHC.Base
|
||||
import GHC.Show
|
||||
import GHC.Err
|
||||
import GHC.Num
|
||||
import GHC.Float
|
||||
import GHC.Real( rem, Ratio )
|
||||
import GHC.IOBase
|
||||
import GHC.Ptr -- So we can give Typeable instance for Ptr
|
||||
import GHC.Stable -- So we can give Typeable instance for StablePtr
|
||||
|
||||
unsafeCoerce :: a -> b
|
||||
unsafeCoerce = unsafeCoerce#
|
||||
|
||||
#include "Typeable.h"
|
||||
|
||||
|
||||
-------------------------------------------------------------
|
||||
--
|
||||
-- Type representations
|
||||
--
|
||||
-------------------------------------------------------------
|
||||
|
||||
|
||||
-- | A concrete representation of a (monomorphic) type. 'TypeRep'
|
||||
-- supports reasonably efficient equality.
|
||||
data TypeRep = TypeRep !Key TyCon [TypeRep]
|
||||
|
||||
-- Compare keys for equality
|
||||
instance Eq TypeRep where
|
||||
(TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2
|
||||
|
||||
-- | An abstract representation of a type constructor. 'TyCon' objects can
|
||||
-- be built using 'mkTyCon'.
|
||||
data TyCon = TyCon !Key String
|
||||
|
||||
instance Eq TyCon where
|
||||
(TyCon _ s1) == (TyCon _ s2) = s1 == s2
|
||||
|
||||
--
|
||||
-- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
|
||||
-- [fTy,fTy,fTy])
|
||||
--
|
||||
-- returns "(Foo,Foo,Foo)"
|
||||
--
|
||||
-- The TypeRep Show instance promises to print tuple types
|
||||
-- correctly. Tuple type constructors are specified by a
|
||||
-- sequence of commas, e.g., (mkTyCon ",,,,") returns
|
||||
-- the 5-tuple tycon.
|
||||
|
||||
----------------- 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,
|
||||
-- we can map them onto Ints very simply. The benefit is,
|
||||
-- of course, that @TyCon@s can then be compared efficiently.
|
||||
|
||||
-- Provided the implementor of other @Typeable@ instances
|
||||
-- takes care of making all the @TyCon@s CAFs (toplevel constants),
|
||||
-- this will work.
|
||||
|
||||
-- If this constraint does turn out to be a sore thumb, changing
|
||||
-- the Eq instance for TyCons is trivial.
|
||||
|
||||
-- | Builds a 'TyCon' object representing a type constructor. An
|
||||
-- implementation of "Data.Typeable" should ensure that the following holds:
|
||||
--
|
||||
-- > mkTyCon "a" == mkTyCon "a"
|
||||
--
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
||||
----------------- Observation ---------------------
|
||||
|
||||
|
||||
-- | Observe the type constructor of a type representation
|
||||
typerepTyCon :: TypeRep -> TyCon
|
||||
typerepTyCon (TypeRep _ tc _) = tc
|
||||
|
||||
|
||||
-- | Observe the argument types of a type representation
|
||||
typerepArgs :: TypeRep -> [TypeRep]
|
||||
typerepArgs (TypeRep _ _ args) = args
|
||||
|
||||
|
||||
-- | Observe string encoding of a type representation
|
||||
tyconString :: TyCon -> String
|
||||
tyconString (TyCon _ str) = str
|
||||
|
||||
|
||||
----------------- 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:
|
||||
|
||||
showArgs :: Show a => [a] -> ShowS
|
||||
showArgs [] = id
|
||||
showArgs [a] = showsPrec 10 a
|
||||
showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
|
||||
|
||||
showTuple :: TyCon -> [TypeRep] -> ShowS
|
||||
showTuple (TyCon _ str) args = showChar '(' . go str args
|
||||
where
|
||||
go [] [a] = showsPrec 10 a . showChar ')'
|
||||
go _ [] = showChar ')' -- a failure condition, really.
|
||||
go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
|
||||
go _ _ = showChar ')'
|
||||
|
||||
|
||||
-------------------------------------------------------------
|
||||
--
|
||||
-- The Typeable class
|
||||
--
|
||||
-------------------------------------------------------------
|
||||
|
||||
-- | 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.
|
||||
|
||||
|
||||
-------------------------------------------------------------
|
||||
--
|
||||
-- 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
|
||||
|
||||
|
||||
-- | A convenient variation for kind "* -> *"
|
||||
castss :: (Typeable a, Typeable b) => t a -> Maybe (t b)
|
||||
castss x = r
|
||||
where
|
||||
r = if typeOf (get x) == typeOf (get (fromJust r))
|
||||
then Just $ unsafeCoerce x
|
||||
else Nothing
|
||||
get :: t c -> c
|
||||
get = undefined
|
||||
|
||||
|
||||
-- | Another variation
|
||||
castarr :: (Typeable a, Typeable b, Typeable c, Typeable d)
|
||||
=> (a -> t b) -> Maybe (c -> t d)
|
||||
castarr x = r
|
||||
where
|
||||
r = if typeOf (get x) == typeOf (get (fromJust r))
|
||||
then Just $ unsafeCoerce x
|
||||
else Nothing
|
||||
get :: (e -> t f) -> (e, f)
|
||||
get = undefined
|
||||
|
||||
{-
|
||||
|
||||
The variations castss and castarr are arguably not really needed.
|
||||
Let's discuss castss in some detail. To get rid of castss, we can
|
||||
require "Typeable (t a)" and "Typeable (t b)" rather than just
|
||||
"Typeable a" and "Typeable b". In that case, the ordinary cast would
|
||||
work. Eventually, all kinds of library instances should become
|
||||
Typeable. (There is another potential use of variations as those given
|
||||
above. It allows quantification on type constructors.
|
||||
|
||||
-}
|
||||
|
||||
|
||||
-------------------------------------------------------------
|
||||
--
|
||||
-- Instances of the Typeable class for Prelude types
|
||||
--
|
||||
-------------------------------------------------------------
|
||||
|
||||
listTc :: TyCon
|
||||
listTc = mkTyCon "[]"
|
||||
|
||||
instance Typeable a => Typeable [a] where
|
||||
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 "()"
|
||||
|
||||
instance Typeable () where
|
||||
typeOf _ = mkAppTy unitTc []
|
||||
|
||||
tup2Tc :: TyCon
|
||||
tup2Tc = mkTyCon ","
|
||||
|
||||
instance (Typeable a, Typeable b) => Typeable (a,b) where
|
||||
typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
|
||||
typeOf ((undefined :: (a,b) -> b) tu)]
|
||||
|
||||
tup3Tc :: TyCon
|
||||
tup3Tc = mkTyCon ",,"
|
||||
|
||||
instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
|
||||
typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
|
||||
typeOf ((undefined :: (a,b,c) -> b) tu),
|
||||
typeOf ((undefined :: (a,b,c) -> c) tu)]
|
||||
|
||||
tup4Tc :: TyCon
|
||||
tup4Tc = mkTyCon ",,,"
|
||||
|
||||
instance ( Typeable a
|
||||
, Typeable b
|
||||
, Typeable c
|
||||
, Typeable d) => Typeable (a,b,c,d) where
|
||||
typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
|
||||
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 ",,,,"
|
||||
|
||||
instance ( Typeable a
|
||||
, Typeable b
|
||||
, Typeable c
|
||||
, Typeable d
|
||||
, Typeable e) => Typeable (a,b,c,d,e) where
|
||||
typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
|
||||
typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
|
||||
typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
|
||||
typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
|
||||
typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
|
||||
|
||||
instance (Typeable a, Typeable b) => Typeable (a -> b) where
|
||||
typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
|
||||
(typeOf ((undefined :: (a -> b) -> b) f))
|
||||
|
||||
|
||||
|
||||
-------------------------------------------------------
|
||||
--
|
||||
-- Generate Typeable instances for standard datatypes
|
||||
--
|
||||
-------------------------------------------------------
|
||||
|
||||
INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
|
||||
INSTANCE_TYPEABLE0(Char,charTc,"Char")
|
||||
INSTANCE_TYPEABLE0(Float,floatTc,"Float")
|
||||
INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
|
||||
INSTANCE_TYPEABLE0(Int,intTc,"Int")
|
||||
INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
|
||||
INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
|
||||
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(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_TYPEABLE1(IORef,ioRefTc,"IORef")
|
||||
|
||||
#endif /* GHC < 6.3 */
|
||||
|
||||
|
||||
---------------------------------------------
|
||||
--
|
||||
-- Internals
|
||||
--
|
||||
---------------------------------------------
|
||||
|
||||
newtype Key = Key Int deriving( Eq )
|
||||
|
||||
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 _ = do i <- genSym; return (Key i)
|
||||
|
||||
|
||||
-- In GHC we use the RTS's genSym function to get a new unique,
|
||||
-- because in GHCi we might have two copies of the Data.Typeable
|
||||
-- library running (one in the compiler and one in the running
|
||||
-- program), and we need to make sure they don't share any keys.
|
||||
--
|
||||
-- This is really a hack. A better solution would be to centralise the
|
||||
-- whole mutable state used by this module, i.e. both hashtables. But
|
||||
-- the current solution solves the immediate problem, which is that
|
||||
-- dynamics generated in one world with one type were erroneously
|
||||
-- being recognised by the other world as having a different type.
|
||||
--
|
||||
-- dons: SimonM says we need to unify the hashes by storing them in a
|
||||
-- variable in the rts.
|
||||
--
|
||||
foreign import ccall unsafe "genSymZh"
|
||||
genSym :: IO Int
|
||||
|
||||
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
|
||||
@ -237,7 +237,7 @@ dynwrap :: String -> String -> [Import] -> String
|
||||
dynwrap expr nm mods =
|
||||
"module "++nm++ "( resource ) where\n" ++
|
||||
concatMap (\m-> "import "++m++"\n") mods ++
|
||||
"import AltData.Dynamic\n" ++
|
||||
"import Data.Dynamic\n" ++
|
||||
"resource = let { "++x++" = \n" ++
|
||||
"{-# LINE 1 \"<eval>\" #-}\n" ++ expr ++ ";} in toDyn "++x
|
||||
where
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user