Implement poly-kinded Typeable
authorJose Pedro Magalhaes <jpm@cs.ox.ac.uk>
Thu, 7 Feb 2013 13:51:19 +0000 (13:51 +0000)
committerJose Pedro Magalhaes <jpm@cs.ox.ac.uk>
Tue, 12 Feb 2013 08:41:58 +0000 (08:41 +0000)
This patch makes the Data.Typeable.Typeable class work with arguments of any
kind. In particular, this removes the Typeable1..7 class hierarchy, greatly
simplyfing the whole Typeable story. Also added is the AutoDeriveTypeable
language extension, which will automatically derive Typeable for all types and
classes declared in that module. Since there is now no good reason to give
handwritten instances of the Typeable class, those are ignored (for backwards
compatibility), and a warning is emitted.

The old, kind-* Typeable class is now called OldTypeable, and lives in the
Data.OldTypeable module. It is deprecated, and should be removed in some future
version of GHC.

Data/Data.hs
Data/OldTypeable.hs [new file with mode: 0644]
Data/OldTypeable.hs-boot [new file with mode: 0644]
Data/OldTypeable/Internal.hs [new file with mode: 0644]
Data/OldTypeable/Internal.hs-boot [new file with mode: 0644]
Data/Typeable.hs
Data/Typeable/Internal.hs
Data/Typeable/Internal.hs-boot
base.cabal
include/OldTypeable.h [new file with mode: 0644]
include/Typeable.h

index d961086..195dc5c 100644 (file)
@@ -269,7 +269,7 @@ class Typeable a => Data a where
   --
   -- The default definition is @'const' 'Nothing'@, which is appropriate
   -- for non-unary type constructors.
-  dataCast1 :: Typeable1 t
+  dataCast1 :: Typeable t
             => (forall d. Data d => c (t d))
             -> Maybe (c a)
   dataCast1 _ = Nothing
@@ -280,7 +280,7 @@ class Typeable a => Data a where
   --
   -- The default definition is @'const' 'Nothing'@, which is appropriate
   -- for non-binary type constructors.
-  dataCast2 :: Typeable2 t
+  dataCast2 :: Typeable t
             => (forall d e. (Data d, Data e) => c (t d e))
             -> Maybe (c a)
   dataCast2 _ = Nothing
diff --git a/Data/OldTypeable.hs b/Data/OldTypeable.hs
new file mode 100644 (file)
index 0000000..9c75623
--- /dev/null
@@ -0,0 +1,207 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , OverlappingInstances
+           , ScopedTypeVariables
+           , ForeignFunctionInterface
+           , FlexibleInstances
+  #-}
+{-# OPTIONS_GHC -funbox-strict-fields -fno-warn-warnings-deprecations #-}
+
+-- The -XOverlappingInstances flag allows the user to over-ride
+-- the instances for Typeable given here.  In particular, we provide an instance
+--      instance ... => Typeable (s a) 
+-- But a user might want to say
+--      instance ... => Typeable (MyType a b)
+
+-----------------------------------------------------------------------------
+-- |
+-- 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
+--
+-- This module defines the old, kind-monomorphic 'Typeable' class. It is now
+-- deprecated; users are recommended to use the kind-polymorphic
+-- "Data.Typeable" module instead.
+--
+-----------------------------------------------------------------------------
+
+module Data.OldTypeable {-# DEPRECATED "Use Data.Typeable instead" #-}
+  (
+
+        -- * 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
+        showsTypeRep,
+
+        TyCon,          -- abstract, instance of: Eq, Show, Typeable
+        tyConString,    -- :: TyCon   -> String
+        tyConPackage,   -- :: TyCon   -> String
+        tyConModule,    -- :: TyCon   -> String
+        tyConName,      -- :: TyCon   -> String
+
+        -- * Construction of type representations
+        mkTyCon,        -- :: String  -> TyCon
+        mkTyCon3,       -- :: String  -> String -> 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]
+        typeRepKey,     -- :: TypeRep -> IO TypeRepKey
+        TypeRepKey,     -- abstract, instance of Eq, Ord
+
+        -- * 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 Data.OldTypeable.Internal hiding (mkTyCon)
+
+import Unsafe.Coerce
+import Data.Maybe
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.Err          (undefined)
+
+import GHC.Fingerprint.Type
+import {-# SOURCE #-} GHC.Fingerprint
+   -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
+   -- Better to break the loop here, because we want non-SOURCE imports
+   -- of Data.Typeable as much as possible so we can optimise the derived
+   -- instances.
+
+#endif
+
+#ifdef __HUGS__
+import Hugs.Prelude     ( Key(..), TypeRep(..), TyCon(..), Ratio,
+                          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 (IOArray,IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
+import IO (Handle)
+import Ratio (Ratio)
+        -- For the Typeable instance
+import NHC.FFI  ( Ptr,FunPtr,StablePtr,ForeignPtr )
+import Array    ( Array )
+#endif
+
+#include "OldTypeable.h"
+
+{-# DEPRECATED typeRepKey "TypeRep itself is now an instance of Ord" #-}
+-- | (DEPRECATED) Returns a unique key associated with a 'TypeRep'.
+-- This function is deprecated because 'TypeRep' itself is now an
+-- instance of 'Ord', so mappings can be made directly with 'TypeRep'
+-- as the key.
+--
+typeRepKey :: TypeRep -> IO TypeRepKey
+typeRepKey (TypeRep f _ _) = return (TypeRepKey f)
+
+        -- 
+        -- 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.
+
+newtype TypeRepKey = TypeRepKey Fingerprint
+  deriving (Eq,Ord)
+
+----------------- Construction ---------------------
+
+{-# DEPRECATED mkTyCon "either derive Typeable, or use mkTyCon3 instead" #-}
+-- | Backwards-compatible API
+mkTyCon :: String       -- ^ unique string
+        -> TyCon        -- ^ A unique 'TyCon' object
+mkTyCon name = TyCon (fingerprintString name) "" "" name
+
+-------------------------------------------------------------
+--
+--              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
+
diff --git a/Data/OldTypeable.hs-boot b/Data/OldTypeable.hs-boot
new file mode 100644 (file)
index 0000000..6c1f795
--- /dev/null
@@ -0,0 +1,10 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Data.OldTypeable (Typeable, mkTyConApp, cast) where
+
+import Data.Maybe
+import {-# SOURCE #-} Data.Typeable.Internal
+
+cast :: (Typeable a, Typeable b) => a -> Maybe b
+
diff --git a/Data/OldTypeable/Internal.hs b/Data/OldTypeable/Internal.hs
new file mode 100644 (file)
index 0000000..817dc4c
--- /dev/null
@@ -0,0 +1,573 @@
+{-# LANGUAGE Unsafe #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Typeable.Internal
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2011
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- The representations of the types TyCon and TypeRep, and the
+-- function mkTyCon which is used by derived instances of Typeable to
+-- construct a TyCon.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , OverlappingInstances
+           , ScopedTypeVariables
+           , FlexibleInstances
+           , MagicHash #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
+#endif
+
+module Data.OldTypeable.Internal {-# DEPRECATED "Use Data.Typeable.Internal instead" #-} (
+    TypeRep(..),
+    TyCon(..),
+    mkTyCon,
+    mkTyCon3,
+    mkTyConApp,
+    mkAppTy,
+    typeRepTyCon,
+    typeOfDefault,
+    typeOf1Default,
+    typeOf2Default,
+    typeOf3Default,
+    typeOf4Default,
+    typeOf5Default,
+    typeOf6Default,
+    Typeable(..),
+    Typeable1(..),
+    Typeable2(..),
+    Typeable3(..),
+    Typeable4(..),
+    Typeable5(..),
+    Typeable6(..),
+    Typeable7(..),
+    mkFunTy,
+    splitTyConApp,
+    funResultTy,
+    typeRepArgs,
+    showsTypeRep,
+    tyConString,
+#if defined(__GLASGOW_HASKELL__)
+    listTc, funTc
+#endif
+  ) where
+
+import GHC.Base
+import GHC.Word
+import GHC.Show
+import GHC.Err          (undefined)
+import Data.Maybe
+import Data.List
+import GHC.Num
+import GHC.Real
+import GHC.IORef
+import GHC.IOArray
+import GHC.MVar
+import GHC.ST           ( ST )
+import GHC.STRef        ( STRef )
+import GHC.Ptr          ( Ptr, FunPtr )
+import GHC.Stable
+import GHC.Arr          ( Array, STArray )
+import Data.Int
+
+import GHC.Fingerprint.Type
+import {-# SOURCE #-} GHC.Fingerprint
+   -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
+   -- Better to break the loop here, because we want non-SOURCE imports
+   -- of Data.Typeable as much as possible so we can optimise the derived
+   -- instances.
+
+-- | A concrete representation of a (monomorphic) type.  'TypeRep'
+-- supports reasonably efficient equality.
+data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [TypeRep]
+
+-- Compare keys for equality
+instance Eq TypeRep where
+  (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
+
+instance Ord 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 {
+   tyConHash    :: {-# UNPACK #-} !Fingerprint,
+   tyConPackage :: String,
+   tyConModule  :: String,
+   tyConName    :: String
+ }
+
+instance Eq TyCon where
+  (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
+
+instance Ord TyCon where
+  (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2
+
+----------------- Construction --------------------
+
+#include "MachDeps.h"
+
+-- mkTyCon is an internal function to make it easier for GHC to
+-- generate derived instances.  GHC precomputes the MD5 hash for the
+-- TyCon and passes it as two separate 64-bit values to mkTyCon.  The
+-- TyCon for a derived Typeable instance will end up being statically
+-- allocated.
+
+#if WORD_SIZE_IN_BITS < 64
+mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
+#else
+mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon
+#endif
+mkTyCon high# low# pkg modl name
+  = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
+
+-- | Applies a type constructor to a sequence of types
+mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep
+mkTyConApp tc@(TyCon tc_k _ _ _) []
+  = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances
+                       -- end up here, and it helps generate smaller
+                       -- code for derived Typeable.
+mkTyConApp tc@(TyCon tc_k _ _ _) args
+  = TypeRep (fingerprintFingerprints (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 _ tc trs) arg_tr = mkTyConApp tc (trs ++ [arg_tr])
+   -- Notice that we call mkTyConApp to construct the fingerprint from tc and
+   -- the arg fingerprints.  Simply combining the current fingerprint with
+   -- the new one won't give the same answer, but of course we want to 
+   -- ensure that a TypeRep of the same shape has the same fingerprint!
+   -- See Trac #5962
+
+-- | Builds a 'TyCon' object representing a type constructor.  An
+-- implementation of "Data.Typeable" should ensure that the following holds:
+--
+-- >  A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
+--
+
+--
+mkTyCon3 :: String       -- ^ package name
+         -> String       -- ^ module name
+         -> String       -- ^ the name of the type constructor
+         -> TyCon        -- ^ A unique 'TyCon' object
+mkTyCon3 pkg modl name =
+  TyCon (fingerprintString (unwords [pkg, modl, name])) pkg modl name
+
+----------------- 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
+{-# DEPRECATED tyConString "renamed to tyConName; tyConModule and tyConPackage are also available." #-}
+tyConString :: TyCon   -> String
+tyConString = tyConName
+
+-------------------------------------------------------------
+--
+--      The Typeable class and friends
+--
+-------------------------------------------------------------
+
+{- 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
+  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
+
+#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
+#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
+#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
+#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
+#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
+#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
+#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
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+-- 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
+
+#endif /* __GLASGOW_HASKELL__ */
+
+----------------- 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 xs
+         | otherwise         ->
+            showParen (p > 9) $
+            showsPrec p tycon . 
+            showChar ' '      . 
+            showArgs tys
+
+showsTypeRep :: TypeRep -> ShowS
+showsTypeRep = shows
+
+instance Show TyCon where
+  showsPrec _ t = showString (tyConName t)
+
+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 :: [TypeRep] -> ShowS
+showTuple args = showChar '('
+               . (foldr (.) id $ intersperse (showChar ',') 
+                               $ map (showsPrec 10) args)
+               . showChar ')'
+
+#if defined(__GLASGOW_HASKELL__)
+listTc :: TyCon
+listTc = typeRepTyCon (typeOf [()])
+
+funTc :: TyCon
+funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->"
+#endif
+
+-------------------------------------------------------------
+--
+--      Instances of the Typeable classes for Prelude types
+--
+-------------------------------------------------------------
+
+#include "OldTypeable.h"
+
+INSTANCE_TYPEABLE0((),unitTc,"()")
+INSTANCE_TYPEABLE1([],listTc,"[]")
+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 [] }
+#else
+INSTANCE_TYPEABLE2((->),funTc,"->")
+#endif
+INSTANCE_TYPEABLE1(IO,ioTc,"IO")
+
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+-- Types defined in GHC.MVar
+INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
+#endif
+
+INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
+INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
+
+#ifdef __GLASGOW_HASKELL__
+-- Hugs has these too, but their Typeable<n> instances are defined
+-- elsewhere to keep this module within Haskell 98.
+-- This is important because every invocation of runhugs or ffihugs
+-- uses this module via Data.Dynamic.
+INSTANCE_TYPEABLE2(ST,stTc,"ST")
+INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
+INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
+#endif
+
+#ifndef __NHC__
+INSTANCE_TYPEABLE2((,),pairTc,"(,)")
+INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")
+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")
+
+-------------------------------------------------------
+--
+-- 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")
+#ifndef __NHC__
+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")
+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")
+
+#ifdef __GLASGOW_HASKELL__
+{-
+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 = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \
+instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
+
+#endif
diff --git a/Data/OldTypeable/Internal.hs-boot b/Data/OldTypeable/Internal.hs-boot
new file mode 100644 (file)
index 0000000..4c1d636
--- /dev/null
@@ -0,0 +1,28 @@
+{-# LANGUAGE Unsafe #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
+
+module Data.OldTypeable.Internal (
+    Typeable(typeOf),
+    TypeRep,
+    TyCon,
+    mkTyCon,
+    mkTyConApp
+  ) where
+
+import GHC.Base
+
+data TypeRep
+data TyCon
+
+#include "MachDeps.h"
+
+#if WORD_SIZE_IN_BITS < 64
+mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
+#else
+mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon
+#endif
+
+mkTyConApp   :: TyCon -> [TypeRep] -> TypeRep
+
+class Typeable a where
+  typeOf :: a -> TypeRep
index d43ad50..66c6695 100644 (file)
@@ -5,6 +5,7 @@
            , ScopedTypeVariables
            , ForeignFunctionInterface
            , FlexibleInstances
+           , PolyKinds
   #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 
 
 module Data.Typeable
   (
-
         -- * The Typeable class
-        Typeable( typeOf ),
+        Typeable( typeRep ),
+
+        -- * For backwards compatibility
+        typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
 
         -- * Type-safe cast
         cast,
         gcast,                  -- a generalisation of cast
 
+        -- * Generalized casts for higher-order kinds
+        gcast1,                 -- :: ... => c (t a) -> Maybe (c (t' a))
+        gcast2,                 -- :: ... => c (t a b) -> Maybe (c (t' a b))
+
         -- * Type representations
         TypeRep,        -- abstract, instance of: Eq, Show, Typeable
         showsTypeRep,
@@ -56,43 +63,17 @@ module Data.Typeable
         tyConName,
 
         -- * Construction of type representations
-        mkTyCon,
-        mkTyCon3,
-        mkTyConApp,
-        mkAppTy,
-        mkFunTy,
+        -- mkTyCon,        -- :: String  -> TyCon
+        mkTyCon3,       -- :: String  -> String -> String -> TyCon
+        mkTyConApp,     -- :: TyCon   -> [TypeRep] -> TypeRep
+        mkAppTy,        -- :: TypeRep -> TypeRep   -> TypeRep
+        mkFunTy,        -- :: TypeRep -> TypeRep   -> TypeRep
 
         -- * Observation of type representations
-        splitTyConApp,
-        funResultTy,
-        typeRepTyCon,
-        typeRepArgs,
-        typeRepKey,
-        TypeRepKey,     -- abstract, instance of Eq, Ord
-
-        -- * The other Typeable classes
-        -- | /Note:/ The general instances are provided for GHC only.
-        Typeable1( typeOf1 ),
-        Typeable2( typeOf2 ),
-        Typeable3( typeOf3 ),
-        Typeable4( typeOf4 ),
-        Typeable5( typeOf5 ),
-        Typeable6( typeOf6 ),
-        Typeable7( typeOf7 ),
-        gcast1,
-        gcast2,
-
-        -- * Default instances
-        -- | /Note:/ These are not needed by GHC, for which these instances
-        -- are generated by general instance declarations.
-        typeOfDefault,
-        typeOf1Default,
-        typeOf2Default,
-        typeOf3Default,
-        typeOf4Default,
-        typeOf5Default,
-        typeOf6Default
-
+        splitTyConApp,  -- :: TypeRep -> (TyCon, [TypeRep])
+        funResultTy,    -- :: TypeRep -> TypeRep   -> Maybe TypeRep
+        typeRepTyCon,   -- :: TypeRep -> TyCon
+        typeRepArgs,    -- :: TypeRep -> [TypeRep]
   ) where
 
 import Data.Typeable.Internal hiding (mkTyCon)
@@ -100,71 +81,9 @@ import Data.Typeable.Internal hiding (mkTyCon)
 import Unsafe.Coerce
 import Data.Maybe
 
-#ifdef __GLASGOW_HASKELL__
 import GHC.Base
 import GHC.Err          (undefined)
 
-import {-# SOURCE #-} GHC.Fingerprint
-   -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
-   -- Better to break the loop here, because we want non-SOURCE imports
-   -- of Data.Typeable as much as possible so we can optimise the derived
-   -- instances.
-
-#endif
-
-#ifdef __HUGS__
-import Hugs.Prelude     ( Key(..), TypeRep(..), TyCon(..), Ratio,
-                          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 (IOArray,IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
-import IO (Handle)
-import Ratio (Ratio)
-        -- For the Typeable instance
-import NHC.FFI  ( Ptr,FunPtr,StablePtr,ForeignPtr )
-import Array    ( Array )
-#endif
-
-#include "Typeable.h"
-
-{-# DEPRECATED typeRepKey "TypeRep itself is now an instance of Ord" #-}
--- | (DEPRECATED) Returns a unique key associated with a 'TypeRep'.
--- This function is deprecated because 'TypeRep' itself is now an
--- instance of 'Ord', so mappings can be made directly with 'TypeRep'
--- as the key.
---
-typeRepKey :: TypeRep -> IO TypeRepKey
-typeRepKey (TypeRep f _ _) = return (TypeRepKey f)
-
-        -- 
-        -- 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.
-
-newtype TypeRepKey = TypeRepKey Fingerprint
-  deriving (Eq,Ord)
-
------------------ Construction ---------------------
-
-{-# DEPRECATED mkTyCon "either derive Typeable, or use mkTyCon3 instead" #-}
--- | Backwards-compatible API
-mkTyCon :: String       -- ^ unique string
-        -> TyCon        -- ^ A unique 'TyCon' object
-mkTyCon name = TyCon (fingerprintString name) "" "" name
-
 -------------------------------------------------------------
 --
 --              Type-safe cast
@@ -172,40 +91,31 @@ mkTyCon name = TyCon (fingerprintString name) "" "" name
 -------------------------------------------------------------
 
 -- | 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
+cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b
+cast x = if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy b)
+           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 :: (Typeable (a :: *), Typeable b) => c a -> Maybe (c b)
 gcast x = r
  where
-  r = if typeOf (getArg x) == typeOf (getArg (fromJust r))
+  r = if typeRep (getArg x) == typeRep (getArg (fromJust r))
         then Just $ unsafeCoerce x
         else Nothing
-  getArg :: c x -> x 
+  getArg :: c x -> Proxy 
   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
+gcast1 :: forall c t t' a. (Typeable (t :: * -> *), Typeable t')
+       => c (t a) -> Maybe (c (t' a)) 
+gcast1 x = if typeRep (Proxy :: Proxy t) == typeRep (Proxy :: Proxy t')
+             then Just $ unsafeCoerce x
+             else Nothing
 
 -- | 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
-
+gcast2 :: forall c t t' a b. (Typeable (t :: * -> * -> *), Typeable t')
+       => c (t a b) -> Maybe (c (t' a b)) 
+gcast2 x = if typeRep (Proxy :: Proxy t) == typeRep (Proxy :: Proxy t')
+             then Just $ unsafeCoerce x
+             else Nothing
index 36bf55e..99ad0b6 100644 (file)
@@ -1,4 +1,5 @@
-{-# LANGUAGE Unsafe #-}
+{-# OPTIONS_GHC -fno-warn-typeable-instances #-}
+{-# LANGUAGE Unsafe    #-}
 
 -----------------------------------------------------------------------------
 -- |
            , OverlappingInstances
            , ScopedTypeVariables
            , FlexibleInstances
-           , MagicHash #-}
+           , MagicHash
+           , KindSignatures
+           , PolyKinds #-}
 #ifdef __GLASGOW_HASKELL__
 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
 #endif
 
 module Data.Typeable.Internal (
+    Proxy (..),
     TypeRep(..),
     Fingerprint(..),
+    typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
     TyCon(..),
     mkTyCon,
     mkTyCon3,
     mkTyConApp,
     mkAppTy,
     typeRepTyCon,
-    typeOfDefault,
-    typeOf1Default,
-    typeOf2Default,
-    typeOf3Default,
-    typeOf4Default,
-    typeOf5Default,
-    typeOf6Default,
     Typeable(..),
-    Typeable1(..),
-    Typeable2(..),
-    Typeable3(..),
-    Typeable4(..),
-    Typeable5(..),
-    Typeable6(..),
-    Typeable7(..),
     mkFunTy,
     splitTyConApp,
     funResultTy,
     typeRepArgs,
     showsTypeRep,
     tyConString,
-#if defined(__GLASGOW_HASKELL__)
     listTc, funTc
-#endif
   ) where
 
 import GHC.Base
 import GHC.Word
 import GHC.Show
-import GHC.Err          (undefined)
 import Data.Maybe
 import Data.List
 import GHC.Num
@@ -200,221 +188,50 @@ tyConString = tyConName
 --
 -------------------------------------------------------------
 
-{- 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
-  typeOf :: a -> TypeRep
+  typeRep :: proxy 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.
+  -- of that type.
 
--- | Variant for unary type constructors
-class Typeable1 t where
-  typeOf1 :: t a -> TypeRep
+-- | A concrete, poly-kinded proxy type
+data Proxy t = Proxy
 
-#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
-#endif
+-- Keeping backwards-compatibility
+typeOf :: forall a. Typeable a => a -> TypeRep
+typeOf _ = typeRep (Proxy :: Proxy a)
 
--- | Variant for binary type constructors
-class Typeable2 t where
-  typeOf2 :: t a b -> TypeRep
+typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep
+typeOf1 _ = typeRep (Proxy :: Proxy t)
 
-#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
-#endif
+typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep
+typeOf2 _ = typeRep (Proxy :: Proxy t)
 
--- | Variant for 3-ary type constructors
-class Typeable3 t where
-  typeOf3 :: t a b c -> TypeRep
+typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t
+        => t a b c -> TypeRep
+typeOf3 _ = typeRep (Proxy :: Proxy t)
 
-#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
-#endif
+typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t
+        => t a b c d -> TypeRep
+typeOf4 _ = typeRep (Proxy :: Proxy t)
 
--- | Variant for 4-ary type constructors
-class Typeable4 t where
-  typeOf4 :: t a b c d -> TypeRep
+typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t
+        => t a b c d e -> TypeRep
+typeOf5 _ = typeRep (Proxy :: Proxy t)
 
-#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
-#endif
-   
--- | Variant for 5-ary type constructors
-class Typeable5 t where
-  typeOf5 :: t a b c d e -> TypeRep
+typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *).
+                Typeable t => t a b c d e f -> TypeRep
+typeOf6 _ = typeRep (Proxy :: Proxy t)
 
-#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
-#endif
-
--- | Variant for 6-ary type constructors
-class Typeable6 t where
-  typeOf6 :: t a b c d e f -> TypeRep
+typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *)
+                (g :: *). Typeable t => t a b c d e f g -> TypeRep
+typeOf7 _ = typeRep (Proxy :: Proxy t)
 
-#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
-#endif
+-- | Kind-polymorphic Typeable instance for type application
+instance (Typeable s, Typeable a) => Typeable (s a) where
+  typeRep _ = typeRep (Proxy :: Proxy s) `mkAppTy` typeRep (Proxy :: Proxy a)
 
--- | 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
-#endif
-
-#ifdef __GLASGOW_HASKELL__
--- 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
-
-#endif /* __GLASGOW_HASKELL__ */
 
 ----------------- Showing TypeReps --------------------
 
@@ -457,13 +274,11 @@ showTuple args = showChar '('
                                $ map (showsPrec 10) args)
                . showChar ')'
 
-#if defined(__GLASGOW_HASKELL__)
 listTc :: TyCon
 listTc = typeRepTyCon (typeOf [()])
 
 funTc :: TyCon
 funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->"
-#endif
 
 -------------------------------------------------------------
 --
@@ -485,7 +300,7 @@ libraries/base/Data/Typeable.hs:589:1:
       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 [] }
+instance Typeable (->) where { typeRep _ = mkTyConApp funTc [] }
 #else
 INSTANCE_TYPEABLE2((->),funTc,"->")
 #endif
@@ -569,6 +384,6 @@ libraries/base/Data/Typeable.hs:674:1:
 -}
 realWorldTc :: TyCon; \
 realWorldTc = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \
-instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
+instance Typeable RealWorld where { typeRep _ = mkTyConApp realWorldTc [] }
 
 #endif
index c83c77e..b9579bc 100644 (file)
@@ -1,8 +1,9 @@
 {-# LANGUAGE Unsafe #-}
-{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, PolyKinds #-}
 
 module Data.Typeable.Internal (
-    Typeable(typeOf),
+    Proxy(..),
+    Typeable(typeRep),
     TypeRep,
     TyCon,
     mkTyCon,
@@ -24,5 +25,7 @@ mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon
 
 mkTyConApp   :: TyCon -> [TypeRep] -> TypeRep
 
+data Proxy t = Proxy
+
 class Typeable a where
-  typeOf :: a -> TypeRep
+  typeRep :: proxy a -> TypeRep
index f6b21f9..41f0514 100644 (file)
@@ -163,6 +163,8 @@ Library {
         Data.Tuple,
         Data.Typeable,
         Data.Typeable.Internal,
+        Data.OldTypeable,
+        Data.OldTypeable.Internal,
         Data.Unique,
         Data.Version,
         Data.Word,
@@ -228,7 +230,7 @@ Library {
         cbits/sysconf.c
     include-dirs: include
     includes:    HsBase.h
-    install-includes:    HsBase.h HsBaseConfig.h EventConfig.h WCsubst.h consUtils.h Typeable.h
+    install-includes:    HsBase.h HsBaseConfig.h EventConfig.h WCsubst.h consUtils.h Typeable.h OldTypeable.h
     if os(windows) {
         extra-libraries: wsock32, user32, shell32
     }
diff --git a/include/OldTypeable.h b/include/OldTypeable.h
new file mode 100644 (file)
index 0000000..38fe90f
--- /dev/null
@@ -0,0 +1,123 @@
+{- --------------------------------------------------------------------------
+// Macros to help make Typeable instances.
+//
+// INSTANCE_TYPEABLEn(tc,tcname,"tc") defines
+//
+//     instance Typeable/n/ tc
+//     instance Typeable a => Typeable/n-1/ (tc a)
+//     instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b)
+//     ...
+//     instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an)
+// --------------------------------------------------------------------------
+-}
+
+#ifndef TYPEABLE_H
+#define TYPEABLE_H
+
+#ifdef __GLASGOW_HASKELL__
+
+--  // For GHC, we can use DeriveDataTypeable + StandaloneDeriving to
+--  // generate the instances.
+
+#define INSTANCE_TYPEABLE0(tycon,tcname,str) deriving instance Typeable tycon
+#define INSTANCE_TYPEABLE1(tycon,tcname,str) deriving instance Typeable1 tycon
+#define INSTANCE_TYPEABLE2(tycon,tcname,str) deriving instance Typeable2 tycon
+#define INSTANCE_TYPEABLE3(tycon,tcname,str) deriving instance Typeable3 tycon
+#define INSTANCE_TYPEABLE4(tycon,tcname,str) deriving instance Typeable4 tycon
+#define INSTANCE_TYPEABLE5(tycon,tcname,str) deriving instance Typeable5 tycon
+#define INSTANCE_TYPEABLE6(tycon,tcname,str) deriving instance Typeable6 tycon
+#define INSTANCE_TYPEABLE7(tycon,tcname,str) deriving instance Typeable7 tycon
+
+#else /* !__GLASGOW_HASKELL__ */
+
+#define INSTANCE_TYPEABLE0(tycon,tcname,str) \
+tcname :: TyCon; \
+tcname = mkTyCon str; \
+instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] }
+
+#define INSTANCE_TYPEABLE1(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \
+instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault }
+
+#define INSTANCE_TYPEABLE2(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \
+instance Typeable a => Typeable1 (tycon a) where { \
+  typeOf1 = typeOf1Default }; \
+instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \
+  typeOf = typeOfDefault }
+
+#define INSTANCE_TYPEABLE3(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \
+instance Typeable a => Typeable2 (tycon a) where { \
+  typeOf2 = typeOf2Default }; \
+instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \
+  typeOf1 = typeOf1Default }; \
+instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \
+  typeOf = typeOfDefault }
+
+#define INSTANCE_TYPEABLE4(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable4 tycon where { typeOf4 _ = mkTyConApp tcname [] }; \
+instance Typeable a => Typeable3 (tycon a) where { \
+  typeOf3 = typeOf3Default }; \
+instance (Typeable a, Typeable b) => Typeable2 (tycon a b) where { \
+  typeOf2 = typeOf2Default }; \
+instance (Typeable a, Typeable b, Typeable c) => Typeable1 (tycon a b c) where { \
+  typeOf1 = typeOf1Default }; \
+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable (tycon a b c d) where { \
+  typeOf = typeOfDefault }
+
+#define INSTANCE_TYPEABLE5(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable5 tycon where { typeOf5 _ = mkTyConApp tcname [] }; \
+instance Typeable a => Typeable4 (tycon a) where { \
+  typeOf4 = typeOf4Default }; \
+instance (Typeable a, Typeable b) => Typeable3 (tycon a b) where { \
+  typeOf3 = typeOf3Default }; \
+instance (Typeable a, Typeable b, Typeable c) => Typeable2 (tycon a b c) where { \
+  typeOf2 = typeOf2Default }; \
+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable1 (tycon a b c d) where { \
+  typeOf1 = typeOf1Default }; \
+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => Typeable (tycon a b c d e) where { \
+  typeOf = typeOfDefault }
+
+#define INSTANCE_TYPEABLE6(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable6 tycon where { typeOf6 _ = mkTyConApp tcname [] }; \
+instance Typeable a => Typeable5 (tycon a) where { \
+  typeOf5 = typeOf5Default }; \
+instance (Typeable a, Typeable b) => Typeable4 (tycon a b) where { \
+  typeOf4 = typeOf4Default }; \
+instance (Typeable a, Typeable b, Typeable c) => Typeable3 (tycon a b c) where { \
+  typeOf3 = typeOf3Default }; \
+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable2 (tycon a b c d) where { \
+  typeOf2 = typeOf2Default }; \
+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => Typeable1 (tycon a b c d e) where { \
+  typeOf1 = typeOf1Default }; \
+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) => Typeable (tycon a b c d e f) where { \
+  typeOf = typeOfDefault }
+
+#define INSTANCE_TYPEABLE7(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable7 tycon where { typeOf7 _ = mkTyConApp tcname [] }; \
+instance Typeable a => Typeable6 (tycon a) where { \
+  typeOf6 = typeOf6Default }; \
+instance (Typeable a, Typeable b) => Typeable5 (tycon a b) where { \
+  typeOf5 = typeOf5Default }; \
+instance (Typeable a, Typeable b, Typeable c) => Typeable4 (tycon a b c) where { \
+  typeOf4 = typeOf4Default }; \
+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable3 (tycon a b c d) where { \
+  typeOf3 = typeOf3Default }; \
+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => Typeable2 (tycon a b c d e) where { \
+  typeOf2 = typeOf2Default }; \
+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) => Typeable1 (tycon a b c d e f) where { \
+  typeOf1 = typeOf1Default }; \
+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g) => Typeable (tycon a b c d e f g) where { \
+  typeOf = typeOfDefault }
+
+#endif /* !__GLASGOW_HASKELL__ */
+
+#endif
index 38fe90f..f8ea998 100644 (file)
 --  // generate the instances.
 
 #define INSTANCE_TYPEABLE0(tycon,tcname,str) deriving instance Typeable tycon
-#define INSTANCE_TYPEABLE1(tycon,tcname,str) deriving instance Typeable1 tycon
-#define INSTANCE_TYPEABLE2(tycon,tcname,str) deriving instance Typeable2 tycon
-#define INSTANCE_TYPEABLE3(tycon,tcname,str) deriving instance Typeable3 tycon
-#define INSTANCE_TYPEABLE4(tycon,tcname,str) deriving instance Typeable4 tycon
-#define INSTANCE_TYPEABLE5(tycon,tcname,str) deriving instance Typeable5 tycon
-#define INSTANCE_TYPEABLE6(tycon,tcname,str) deriving instance Typeable6 tycon
-#define INSTANCE_TYPEABLE7(tycon,tcname,str) deriving instance Typeable7 tycon
+#define INSTANCE_TYPEABLE1(tycon,tcname,str) deriving instance Typeable tycon
+#define INSTANCE_TYPEABLE2(tycon,tcname,str) deriving instance Typeable tycon
+#define INSTANCE_TYPEABLE3(tycon,tcname,str) deriving instance Typeable tycon
+#define INSTANCE_TYPEABLE4(tycon,tcname,str) deriving instance Typeable tycon
+#define INSTANCE_TYPEABLE5(tycon,tcname,str) deriving instance Typeable tycon
+#define INSTANCE_TYPEABLE6(tycon,tcname,str) deriving instance Typeable tycon
+#define INSTANCE_TYPEABLE7(tycon,tcname,str) deriving instance Typeable tycon
 
 #else /* !__GLASGOW_HASKELL__ */