X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FTypeable.hs;h=ce602e4999f8d4071f61f84645fcec891fb1ef89;hb=HEAD;hp=ee9e89a9a2f7f17bbd997397138bb0b83fbc1fba;hpb=8d585f7c5ad8c4b46f9ca58931e1379abbd359af;p=ghc-base.git

diff --git a/Data/Typeable.hs b/Data/Typeable.hs
index ee9e89a..ce602e4 100644
--- a/Data/Typeable.hs
+++ b/Data/Typeable.hs
@@ -1,4 +1,14 @@
-{-# OPTIONS_GHC -XNoImplicitPrelude -XOverlappingInstances -funbox-strict-fields #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , OverlappingInstances
+           , ScopedTypeVariables
+           , ForeignFunctionInterface
+           , FlexibleInstances
+  #-}
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
+#endif
 
 -- The -XOverlappingInstances flag allows the user to over-ride
 -- the instances for Typeable given here.  In particular, we provide an instance
@@ -21,7 +31,7 @@
 -- 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.
 --
@@ -93,14 +103,16 @@ import GHC.Base
 import GHC.Show         (Show(..), ShowS,
                          shows, showString, showChar, showParen)
 import GHC.Err          (undefined)
-import GHC.Num          (Integer, fromInteger, (+))
+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       ( IOArray, IO, MVar, Handle, block )
+import GHC.IOArray
+import GHC.MVar
 import GHC.ST           ( ST )
 import GHC.STRef        ( STRef )
 import GHC.Ptr          ( Ptr, FunPtr )
@@ -300,6 +312,22 @@ showTuple args = showChar '('
 --
 -------------------------------------------------------------
 
+{- 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
@@ -313,78 +341,148 @@ 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,
@@ -482,13 +580,30 @@ gcast2 x = r
 
 INSTANCE_TYPEABLE0((),unitTc,"()")
 INSTANCE_TYPEABLE1([],listTc,"[]")
+#if defined(__GLASGOW_HASKELL__)
+listTc :: TyCon
+listTc = typeRepTyCon (typeOf [()])
+#endif
 INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
 INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
+#if defined(__GLASGOW_HASKELL__)
+{-
+TODO: Deriving this instance fails with:
+libraries/base/Data/Typeable.hs:589:1:
+    Can't make a derived instance of `Typeable2 (->)':
+      The last argument of the instance must be a data or newtype application
+    In the stand-alone deriving instance for `Typeable2 (->)'
+-}
+instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }
+funTc :: TyCon
+funTc = mkTyCon "->"
+#else
 INSTANCE_TYPEABLE2((->),funTc,"->")
+#endif
 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
 
@@ -508,34 +623,17 @@ INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
 #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")
 
@@ -555,7 +653,9 @@ INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
 #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")
@@ -571,7 +671,17 @@ INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
 INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
 
 #ifdef __GLASGOW_HASKELL__
-INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
+{-
+TODO: This can't be derived currently:
+libraries/base/Data/Typeable.hs:674:1:
+    Can't make a derived instance of `Typeable RealWorld':
+      The last argument of the instance must be a data or newtype application
+    In the stand-alone deriving instance for `Typeable RealWorld'
+-}
+realWorldTc :: TyCon; \
+realWorldTc = mkTyCon "GHC.Base.RealWorld"; \
+instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
+
 #endif
 
 ---------------------------------------------
@@ -608,7 +718,7 @@ cache = unsafePerformIO $ do
                                         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