-{-# OPTIONS_GHC -XNoImplicitPrelude -XOverlappingInstances -funbox-strict-fields #-}
+{-# LANGUAGE CPP
+ , NoImplicitPrelude
+ , OverlappingInstances
+ , ScopedTypeVariables
+ , ForeignFunctionInterface
+ , FlexibleInstances
+ #-}
+{-# OPTIONS_GHC -funbox-strict-fields #-}
-- The -XOverlappingInstances flag allows the user to over-ride
-- the instances for Typeable given here. In particular, we provide an instance
-- 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
+-- implementation of dynamics. The module "Data.Data" uses Typeable
-- and type-safe cast (but not dynamics) to support the \"Scrap your
-- boilerplate\" style of generic programming.
--
#ifdef __GLASGOW_HASKELL__
import GHC.Base
-import GHC.Show
-import GHC.Err
-import GHC.Num
-import GHC.Float
+import GHC.Show (Show(..), ShowS,
+ shows, showString, showChar, showParen)
+import GHC.Err (undefined)
+import GHC.Num (Integer, (+))
import GHC.Real ( rem, Ratio )
-import GHC.IOBase (IORef,newIORef,unsafePerformIO)
+import GHC.IORef (IORef,newIORef)
+import GHC.IO (unsafePerformIO,mask_)
-- These imports are so we can define Typeable instances
-- It'd be better to give Typeable instances in the modules themselves
-- but they all have to be compiled before Typeable
-import GHC.IOBase ( IO, MVar, Handle, block )
+import GHC.IOArray
+import GHC.MVar
import GHC.ST ( ST )
import GHC.STRef ( STRef )
import GHC.Ptr ( Ptr, FunPtr )
#ifdef __HUGS__
import Hugs.Prelude ( Key(..), TypeRep(..), TyCon(..), Ratio,
- Exception, ArithException, IOException,
- ArrayException, AsyncException, Handle,
- Ptr, FunPtr, ForeignPtr, StablePtr )
+ Handle, Ptr, FunPtr, ForeignPtr, StablePtr )
import Hugs.IORef ( IORef, newIORef, readIORef, writeIORef )
import Hugs.IOExts ( unsafePerformIO )
-- For the Typeable instance
import Hugs.Array ( Array )
+import Hugs.IOArray
import Hugs.ConcBase ( MVar )
#endif
#ifdef __NHC__
-import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
+import NHC.IOExtras (IOArray,IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
import IO (Handle)
import Ratio (Ratio)
-- For the Typeable instance
--
-------------------------------------------------------------
+{- Note [Memoising typeOf]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+IMPORTANT: we don't want to recalculate the type-rep once per
+call to the dummy argument. This is what went wrong in Trac #3245
+So we help GHC by manually keeping the 'rep' *outside* the value
+lambda, thus
+
+ typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
+ typeOfDefault = \_ -> rep
+ where
+ rep = typeOf1 (undefined :: t a) `mkAppTy`
+ typeOf (undefined :: a)
+
+Notice the crucial use of scoped type variables here!
+-}
+
-- | The class 'Typeable' allows a concrete representation of a type to
-- be calculated.
class Typeable a where
class Typeable1 t where
typeOf1 :: t a -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable' instance from any 'Typeable1' instance.
+typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
+typeOfDefault = \_ -> rep
+ where
+ rep = typeOf1 (undefined :: t a) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
-- | Variant for binary type constructors
class Typeable2 t where
typeOf2 :: t a b -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
+typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep
+typeOf1Default = \_ -> rep
+ where
+ rep = typeOf2 (undefined :: t a b) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
-- | Variant for 3-ary type constructors
class Typeable3 t where
typeOf3 :: t a b c -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
+typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep
+typeOf2Default = \_ -> rep
+ where
+ rep = typeOf3 (undefined :: t a b c) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
-- | Variant for 4-ary type constructors
class Typeable4 t where
typeOf4 :: t a b c d -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
+typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep
+typeOf3Default = \_ -> rep
+ where
+ rep = typeOf4 (undefined :: t a b c d) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
-
+ argType = undefined
+#endif
+
-- | Variant for 5-ary type constructors
class Typeable5 t where
typeOf5 :: t a b c d e -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
+typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
+typeOf4Default = \_ -> rep
+ where
+ rep = typeOf5 (undefined :: t a b c d e) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
-- | Variant for 6-ary type constructors
class Typeable6 t where
typeOf6 :: t a b c d e f -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
+typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
+typeOf5Default = \_ -> rep
+ where
+ rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
-- | Variant for 7-ary type constructors
class Typeable7 t where
typeOf7 :: t a b c d e f g -> TypeRep
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
+typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
+typeOf6Default = \_ -> rep
+ where
+ rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy`
+ typeOf (undefined :: a)
+ -- Note [Memoising typeOf]
+#else
-- | 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
+ argType = undefined
+#endif
#ifdef __GLASGOW_HASKELL__
-- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
--- Types defined in GHC.IOBase
+-- Types defined in GHC.MVar
INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
#endif
--- Types defined in GHC.Arr
INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
+INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
#ifdef __GLASGOW_HASKELL__
-- Hugs has these too, but their Typeable<n> instances are defined
#ifndef __NHC__
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_TYPEABLE4((,,,),tup4Tc,"(,,,)")
+INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")
+INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")
+INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")
#endif /* __NHC__ */
INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
+#ifndef __GLASGOW_HASKELL__
+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
+#endif
INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
#endif
INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
+#ifndef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
+#endif
INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
tc_tbl = empty_tc_tbl,
ap_tbl = empty_ap_tbl }
#ifdef __GLASGOW_HASKELL__
- block $ do
+ mask_ $ do
stable_ref <- newStablePtr ret
let ref = castStablePtrToPtr stable_ref
ref2 <- getOrSetTypeableStore ref
projects / ghc-base.git / blobdiff