Commit 3d53407f authored by jpm@cs.ox.ac.uk's avatar jpm@cs.ox.ac.uk

Implement poly-kinded Typeable

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.
parent 4a807620
......@@ -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
......
{-# 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
{-# 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
{-# 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)