Commit 7369d259 authored by mgmeier's avatar mgmeier Committed by Herbert Valerio Riedel
Browse files

Remove obsolete Data.OldTypeable (#9639)

This finally removes the `Data.OldTypeable` module (which
has been deprecated in 7.8), from `base`, compiler and testsuite.

The deprecated `Typeable{1..7}` aliases in `Data.Typeable` are not
removed yet in order to give existing code a bit more time to adapt.

Reviewed By: hvr, dreixel

Differential Revision: https://phabricator.haskell.org/D311
parent 612f3d12
......@@ -185,7 +185,6 @@ sharing a unique will be used.
basicKnownKeyNames :: [Name]
basicKnownKeyNames
= genericTyConNames
++ oldTypeableClassNames
++ [ -- Type constructors (synonyms especially)
ioTyConName, ioDataConName,
runMainIOName,
......@@ -390,7 +389,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
tYPEABLE, tYPEABLE_INTERNAL, oLDTYPEABLE, oLDTYPEABLE_INTERNAL, gENERICS,
tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module
......@@ -431,8 +430,6 @@ sYSTEM_IO = mkBaseModule (fsLit "System.IO")
dYNAMIC = mkBaseModule (fsLit "Data.Dynamic")
tYPEABLE = mkBaseModule (fsLit "Data.Typeable")
tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal")
oLDTYPEABLE = mkBaseModule (fsLit "Data.OldTypeable")
oLDTYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.OldTypeable.Internal")
gENERICS = mkBaseModule (fsLit "Data.Data")
dOTNET = mkBaseModule (fsLit "GHC.Dotnet")
rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec")
......@@ -661,14 +658,10 @@ showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString")
showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace")
showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen")
typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR,
oldTypeOf_RDR, oldMkTyCon_RDR, oldMkTyConApp_RDR :: RdrName
typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName
typeRep_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeRep#")
mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon")
mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp")
oldTypeOf_RDR = varQual_RDR oLDTYPEABLE_INTERNAL (fsLit "typeOf")
oldMkTyCon_RDR = varQual_RDR oLDTYPEABLE_INTERNAL (fsLit "mkTyCon")
oldMkTyConApp_RDR = varQual_RDR oLDTYPEABLE_INTERNAL (fsLit "mkTyConApp")
undefined_RDR :: RdrName
undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
......@@ -1016,24 +1009,9 @@ ixClassName :: Name
ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
-- Class Typeable
typeableClassName,
oldTypeableClassName, oldTypeable1ClassName, oldTypeable2ClassName,
oldTypeable3ClassName, oldTypeable4ClassName, oldTypeable5ClassName,
oldTypeable6ClassName, oldTypeable7ClassName :: Name
typeableClassName :: Name
typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey
oldTypeableClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable") oldTypeableClassKey
oldTypeable1ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable1") oldTypeable1ClassKey
oldTypeable2ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable2") oldTypeable2ClassKey
oldTypeable3ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable3") oldTypeable3ClassKey
oldTypeable4ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable4") oldTypeable4ClassKey
oldTypeable5ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable5") oldTypeable5ClassKey
oldTypeable6ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable6") oldTypeable6ClassKey
oldTypeable7ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable7") oldTypeable7ClassKey
oldTypeableClassNames :: [Name]
oldTypeableClassNames = [ oldTypeableClassName, oldTypeable1ClassName, oldTypeable2ClassName
, oldTypeable3ClassName, oldTypeable4ClassName, oldTypeable5ClassName
, oldTypeable6ClassName, oldTypeable7ClassName ]
-- Class Data
dataClassName :: Name
......@@ -1302,18 +1280,6 @@ ghciIoClassKey = mkPreludeClassUnique 44
ipClassNameKey :: Unique
ipClassNameKey = mkPreludeClassUnique 45
oldTypeableClassKey, oldTypeable1ClassKey, oldTypeable2ClassKey,
oldTypeable3ClassKey, oldTypeable4ClassKey, oldTypeable5ClassKey,
oldTypeable6ClassKey, oldTypeable7ClassKey :: Unique
oldTypeableClassKey = mkPreludeClassUnique 46
oldTypeable1ClassKey = mkPreludeClassUnique 47
oldTypeable2ClassKey = mkPreludeClassUnique 48
oldTypeable3ClassKey = mkPreludeClassUnique 49
oldTypeable4ClassKey = mkPreludeClassUnique 50
oldTypeable5ClassKey = mkPreludeClassUnique 51
oldTypeable6ClassKey = mkPreludeClassUnique 52
oldTypeable7ClassKey = mkPreludeClassUnique 53
\end{code}
%************************************************************************
......
......@@ -57,7 +57,6 @@ import VarSet
import PrelNames
import SrcLoc
import Util
import ListSetOps
import Outputable
import FastString
import Bag
......@@ -881,13 +880,6 @@ mkEqnHelp :: Maybe OverlapMode
-- Assumes that this declaration is well-kinded
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
| className cls `elem` oldTypeableClassNames
= do { dflags <- getDynFlags
; case checkOldTypeableConditions (dflags, tycon, tc_args) of
NotValid err -> bale_out err
IsValid -> mkOldTypeableEqn tvs cls tycon tc_args mtheta }
| otherwise
= do { -- Find the instance of a data family
-- Note [Looking up family instances for deriving]
fam_envs <- tcGetFamInstEnvs
......@@ -1050,41 +1042,6 @@ mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
inst_tys = [mkTyConApp tycon tc_args]
----------------------
mkOldTypeableEqn :: [TyVar] -> Class
-> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
-- The "old" (pre GHC 7.8 polykinded Typeable) deriving Typeable
-- used a horrid family of classes: Typeable, Typeable1, Typeable2, ... Typeable7
mkOldTypeableEqn tvs cls tycon tc_args mtheta
-- The Typeable class is special in several ways
-- data T a b = ... deriving( Typeable )
-- gives
-- instance Typeable2 T where ...
-- Notice that:
-- 1. There are no constraints in the instance
-- 2. There are no type variables either
-- 3. The actual class we want to generate isn't necessarily
-- Typeable; it depends on the arity of the type
| isNothing mtheta -- deriving on a data type decl
= do { checkTc (cls `hasKey` oldTypeableClassKey)
(ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
; real_cls <- tcLookupClass (oldTypeableClassNames `getNth` tyConArity tycon)
-- See Note [Getting base classes]
; mkOldTypeableEqn tvs real_cls tycon [] (Just []) }
| otherwise -- standalone deriving
= do { checkTc (null tc_args)
(ptext (sLit "Derived Typeable instance must be of form (Typeable")
<> int (tyConArity tycon) <+> ppr tycon <> rparen)
; dfun_name <- new_dfun_name cls tycon
; loc <- getSrcSpanM
; return (GivenTheta $
DS { ds_loc = loc, ds_name = dfun_name, ds_tvs = []
, ds_cls = cls, ds_tys = [mkTyConApp tycon []]
, ds_tc = tycon, ds_tc_args = []
, ds_theta = mtheta `orElse` []
, ds_overlap = Nothing -- Or, Just NoOverlap?
, ds_newtype = False }) }
mkPolyKindedTypeableEqn :: Class -> TyCon -> TcM [EarlyDerivSpec]
-- We can arrive here from a 'deriving' clause
......@@ -1242,9 +1199,6 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
classArgsErr :: Class -> [Type] -> SDoc
classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
checkOldTypeableConditions :: Condition
checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK
nonStdErr :: Class -> SDoc
nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
......@@ -1386,21 +1340,6 @@ cond_isProduct (_, rep_tc, _)
why = quotes (pprSourceTyCon rep_tc) <+>
ptext (sLit "must have precisely one constructor")
cond_oldTypeableOK :: Condition
-- OK for kind-monomorphic Typeable class
-- Currently: (a) args all of kind *
-- (b) 7 or fewer args
cond_oldTypeableOK (_, tc, _)
| tyConArity tc > 7 = NotValid too_many
| not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc))
= NotValid bad_kind
| otherwise = IsValid
where
too_many = quotes (pprSourceTyCon tc) <+>
ptext (sLit "must have 7 or fewer arguments")
bad_kind = quotes (pprSourceTyCon tc) <+>
ptext (sLit "must only have arguments of kind `*'")
functorLikeClassKeys :: [Unique]
functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
......@@ -1485,11 +1424,7 @@ non_coercible_class :: Class -> Bool
non_coercible_class cls
= classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
, genClassKey, gen1ClassKey, typeableClassKey
, traversableClassKey ]
++ oldTypeableClassKeys)
oldTypeableClassKeys :: [Unique]
oldTypeableClassKeys = map getUnique oldTypeableClassNames
, traversableClassKey ])
new_dfun_name :: Class -> TyCon -> TcM Name
new_dfun_name clas tycon -- Just a simple wrapper
......
......@@ -102,9 +102,6 @@ data DerivStuff -- Please add this auxiliary stuff
genDerivedBinds :: DynFlags -> FixityEnv -> Class -> SrcSpan -> TyCon
-> (LHsBinds RdrName, BagDerivStuff)
genDerivedBinds dflags fix_env clas loc tycon
| className clas `elem` oldTypeableClassNames
= gen_old_Typeable_binds dflags loc tycon
| Just gen_fn <- assocMaybe gen_list (getUnique clas)
= gen_fn loc tycon
......@@ -1215,68 +1212,6 @@ getPrecedence get_fixity nm
\end{code}
%************************************************************************
%* *
\subsection{Typeable (old)}
%* *
%************************************************************************
From the data type
data T a b = ....
we generate
instance Typeable2 T where
typeOf2 _ = mkTyConApp (mkTyCon <hash-high> <hash-low>
<pkg> <module> "T") []
We are passed the Typeable2 class as well as T
\begin{code}
gen_old_Typeable_binds :: DynFlags -> SrcSpan -> TyCon
-> (LHsBinds RdrName, BagDerivStuff)
gen_old_Typeable_binds dflags loc tycon
= ( unitBag $
mk_easy_FunBind loc
(old_mk_typeOf_RDR tycon) -- Name of appropriate type0f function
[nlWildPat]
(nlHsApps oldMkTyConApp_RDR [tycon_rep, nlList []])
, emptyBag )
where
tycon_name = tyConName tycon
modl = nameModule tycon_name
pkg = modulePackageKey modl
modl_fs = moduleNameFS (moduleName modl)
pkg_fs = packageKeyFS pkg
name_fs = occNameFS (nameOccName tycon_name)
tycon_rep = nlHsApps oldMkTyCon_RDR
(map nlHsLit [int64 high,
int64 low,
HsString pkg_fs,
HsString modl_fs,
HsString name_fs])
hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, name_fs]
Fingerprint high low = fingerprintString hashThis
int64
| wORD_SIZE dflags == 4 = HsWord64Prim . fromIntegral
| otherwise = HsWordPrim . fromIntegral
old_mk_typeOf_RDR :: TyCon -> RdrName
-- Use the arity of the TyCon to make the right typeOfn function
old_mk_typeOf_RDR tycon = varQual_RDR oLDTYPEABLE_INTERNAL (mkFastString ("typeOf" ++ suffix))
where
arity = tyConArity tycon
suffix | arity == 0 = ""
| otherwise = show arity
\end{code}
%************************************************************************
%* *
\subsection{Typeable (new)}
......
......@@ -46,7 +46,7 @@ import VarSet
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps )
import PrelNames ( tYPEABLE_INTERNAL, typeableClassName,
oldTypeableClassNames, genericClassNames )
genericClassNames )
import Bag
import BasicTypes
import DynFlags
......@@ -410,13 +410,11 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- performed. Derived instances are OK.
; dflags <- getDynFlags
; when (safeLanguageOn dflags) $ forM_ local_infos $ \x -> case x of
_ | typInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (typInstErr x)
_ | genInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (genInstErr x)
_ -> return ()
-- As above but for Safe Inference mode.
; when (safeInferOn dflags) $ forM_ local_infos $ \x -> case x of
_ | typInstCheck x -> recordUnsafeInfer
_ | genInstCheck x -> recordUnsafeInfer
_ | overlapCheck x -> recordUnsafeInfer
_ -> return ()
......@@ -439,12 +437,6 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
then (i:typeableInsts, otherInsts)
else (typeableInsts, i:otherInsts)
typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames
typInstErr i = hang (ptext (sLit $ "Typeable instances can only be "
++ "derived in Safe Haskell.") $+$
ptext (sLit "Replace the following instance:"))
2 (pprInstanceHdr (iSpec i))
overlapCheck ty = overlapMode (is_flag $ iSpec ty) `elem`
[Overlappable, Overlapping, Overlaps]
genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
, NoImplicitPrelude
, OverlappingInstances
, ScopedTypeVariables
, 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.
--
-- /Since: 4.7.0.0/
-----------------------------------------------------------------------------
module Data.OldTypeable {-# DEPRECATED "Use Data.Typeable instead" #-} -- deprecated in 7.8
(
-- * 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
import GHC.Base
import GHC.Fingerprint.Type
import GHC.Fingerprint
#include "OldTypeable.h"
{-# DEPRECATED typeRepKey "TypeRep itself is now an instance of Ord" #-} -- deprecated in 7.2
-- | (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" #-} -- deprecated in 7.2
-- | 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 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.
--
-- /Since: 4.7.0.0/
-----------------------------------------------------------------------------
{-# LANGUAGE CPP
, NoImplicitPrelude
, OverlappingInstances
, ScopedTypeVariables
, FlexibleInstances
, MagicHash
, DeriveDataTypeable
, StandaloneDeriving #-}
module Data.OldTypeable.Internal {-# DEPRECATED "Use Data.Typeable.Internal instead" #-} ( -- deprecated in 7.8
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,
listTc, funTc
) where
import GHC.Base
import GHC.Word
import GHC.Show
import Data.OldList
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 GHC.Fingerprint
-- | 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.