Commit 72b0ba09 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 c51d2e53
\begin{code}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE CPP, KindSignatures #-}
module HsExpr where
import SrcLoc ( Located )
......@@ -8,22 +8,29 @@ import {-# SOURCE #-} HsPat ( LPat )
import Data.Data
-- IA0_NOTE: We need kind annotations because of kind polymorphism
data HsExpr (i :: *)
data HsCmd (i :: *)
data HsSplice (i :: *)
data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
#if __GLASGOW_HASKELL__ > 706
instance Typeable HsSplice
instance Typeable HsExpr
instance Typeable MatchGroup
instance Typeable GRHSs
#else
instance Typeable1 HsSplice
instance Data i => Data (HsSplice i)
instance Typeable1 HsExpr
instance Data i => Data (HsExpr i)
instance Typeable1 HsCmd
instance Data i => Data (HsCmd i)
instance Typeable2 MatchGroup
instance (Data i, Data body) => Data (MatchGroup i body)
instance Typeable2 GRHSs
#endif
instance Data i => Data (HsSplice i)
instance Data i => Data (HsExpr i)
instance Data i => Data (HsCmd i)
instance (Data i, Data body) => Data (MatchGroup i body)
instance (Data i, Data body) => Data (GRHSs i body)
instance OutputableBndr id => Outputable (HsExpr id)
......
\begin{code}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE CPP, KindSignatures #-}
module HsPat where
import SrcLoc( Located )
import Data.Data
-- IA0_NOTE: We need kind annotation because of kind polymorphism.
data Pat (i :: *)
type LPat i = Located (Pat i)
#if __GLASGOW_HASKELL__ > 706
instance Typeable Pat
#else
instance Typeable1 Pat
#endif
instance Data i => Data (Pat i)
\end{code}
......@@ -428,6 +428,7 @@ data WarningFlag =
| Opt_WarnUnsupportedCallingConventions
| Opt_WarnUnsupportedLlvmVersion
| Opt_WarnInlineRuleShadowing
| Opt_WarnTypeableInstances
deriving (Eq, Show, Enum)
data Language = Haskell98 | Haskell2010
......@@ -495,6 +496,7 @@ data ExtensionFlag
| Opt_StandaloneDeriving
| Opt_DeriveDataTypeable
| Opt_AutoDeriveTypeable -- Automatic derivation of Typeable
| Opt_DeriveFunctor
| Opt_DeriveTraversable
| Opt_DeriveFoldable
......@@ -2400,7 +2402,8 @@ fWarningFlags = [
( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ),
( "warn-unsupported-calling-conventions", Opt_WarnUnsupportedCallingConventions, nop ),
( "warn-inline-rule-shadowing", Opt_WarnInlineRuleShadowing, nop ),
( "warn-unsupported-llvm-version", Opt_WarnUnsupportedLlvmVersion, nop ) ]
( "warn-unsupported-llvm-version", Opt_WarnUnsupportedLlvmVersion, nop ),
( "warn-typeable-instances", Opt_WarnTypeableInstances, nop ) ]
-- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
negatableFlags :: [FlagSpec GeneralFlag]
......@@ -2631,6 +2634,7 @@ xFlags = [
( "UnboxedTuples", Opt_UnboxedTuples, nop ),
( "StandaloneDeriving", Opt_StandaloneDeriving, nop ),
( "DeriveDataTypeable", Opt_DeriveDataTypeable, nop ),
( "AutoDeriveTypeable", Opt_AutoDeriveTypeable, nop ),
( "DeriveFunctor", Opt_DeriveFunctor, nop ),
( "DeriveTraversable", Opt_DeriveTraversable, nop ),
( "DeriveFoldable", Opt_DeriveFoldable, nop ),
......@@ -2788,7 +2792,9 @@ standardWarnings
Opt_WarnUnsupportedCallingConventions,
Opt_WarnUnsupportedLlvmVersion,
Opt_WarnInlineRuleShadowing,
Opt_WarnDuplicateConstraints
Opt_WarnDuplicateConstraints,
Opt_WarnInlineRuleShadowing,
Opt_WarnTypeableInstances
]
minusWOpts :: [WarningFlag]
......
......@@ -155,7 +155,7 @@ sharing a unique will be used.
basicKnownKeyNames :: [Name]
basicKnownKeyNames
= genericTyConNames
++ typeableClassNames
++ oldTypeableClassNames
++ [ -- Type constructors (synonyms especially)
ioTyConName, ioDataConName,
runMainIOName,
......@@ -186,6 +186,7 @@ basicKnownKeyNames
applicativeClassName,
foldableClassName,
traversableClassName,
typeableClassName, -- derivable
-- Numeric stuff
negateName, minusName, geName, eqName,
......@@ -350,7 +351,8 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
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, gENERICS,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
tYPEABLE, tYPEABLE_INTERNAL, oLDTYPEABLE, oLDTYPEABLE_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
......@@ -391,6 +393,8 @@ 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")
......@@ -617,10 +621,14 @@ showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString")
showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace")
showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen")
typeOf_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName
typeOf_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeOf")
mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon")
mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp")
typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR,
oldTypeOf_RDR, oldMkTyCon_RDR, oldMkTyConApp_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")
......@@ -950,22 +958,24 @@ ixClassName :: Name
ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
-- Class Typeable
typeableClassName, typeable1ClassName, typeable2ClassName,
typeable3ClassName, typeable4ClassName, typeable5ClassName,
typeable6ClassName, typeable7ClassName :: Name
typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey
typeable1ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable1") typeable1ClassKey
typeable2ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable2") typeable2ClassKey
typeable3ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable3") typeable3ClassKey
typeable4ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable4") typeable4ClassKey
typeable5ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable5") typeable5ClassKey
typeable6ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable6") typeable6ClassKey
typeable7ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable7") typeable7ClassKey
typeableClassNames :: [Name]
typeableClassNames = [ typeableClassName, typeable1ClassName, typeable2ClassName
, typeable3ClassName, typeable4ClassName, typeable5ClassName
, typeable6ClassName, typeable7ClassName ]
typeableClassName,
oldTypeableClassName, oldTypeable1ClassName, oldTypeable2ClassName,
oldTypeable3ClassName, oldTypeable4ClassName, oldTypeable5ClassName,
oldTypeable6ClassName, oldTypeable7ClassName :: 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
......@@ -1231,6 +1241,18 @@ 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}
%************************************************************************
......
......@@ -312,7 +312,15 @@ tcDeriving tycl_decls inst_decls deriv_decls
-- And make the necessary "equations".
is_boot <- tcIsHsBoot
; traceTc "tcDeriving" (ppr is_boot)
; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
-- If -XAutoDeriveTypeable is on, add Typeable instances for each
-- datatype and class defined in this module
; isAutoDeriveTypeable <- xoptM Opt_AutoDeriveTypeable
; let deriv_decls' = deriv_decls ++ if isAutoDeriveTypeable
then deriveTypeable tycl_decls
else []
; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls'
-- for each type, determine the auxliary declarations that are common
-- to multiple derivations involving that type (e.g. Generic and
......@@ -367,6 +375,12 @@ tcDeriving tycl_decls inst_decls deriv_decls
hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
deriveTypeable :: [LTyClDecl Name] -> [LDerivDecl Name]
deriveTypeable tys =
[ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName))
(L l (HsTyVar (tcdName t))))))
| L l t <- tys ]
-- Prints the representable type family instance
pprRepTy :: FamInst Unbranched -> SDoc
pprRepTy fi@(FamInst { fi_branches = FirstBranch (FamInstBranch { fib_lhs = lhs
......@@ -567,6 +581,13 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
-- The "deriv_pred" is a LHsType to take account of the fact that for
-- newtype deriving we allow deriving (forall a. C [a]).
-- Typeable is special
; if className cls == typeableClassName
then mkEqnHelp DerivOrigin
(varSetElemsKvsFirst (mkVarSet tvs `extendVarSetList` deriv_tvs))
cls cls_tys (mkTyConApp tc tc_args) Nothing
else do {
-- Given data T a b c = ... deriving( C d ),
-- we want to drop type variables from T so that (C d (T a)) is well-kinded
; let cls_tyvars = classTyVars cls
......@@ -604,7 +625,7 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
(typeFamilyPapErr tc cls cls_tys inst_ty)
; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing }
; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } }
\end{code}
Note [Deriving, type families, and partial applications]
......@@ -657,7 +678,13 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
bale_out msg = failWithTc (derivingThingErr False cls cls_tys tc_app msg)
mk_alg_eqn tycon tc_args
| className cls `elem` typeableClassNames
| className cls `elem` oldTypeableClassNames
= do { dflags <- getDynFlags
; case checkOldTypeableConditions (dflags, tycon, tc_args) of
Just err -> bale_out err
Nothing -> mk_old_typeable_eqn orig tvs cls tycon tc_args mtheta }
| className cls == typeableClassName
= do { dflags <- getDynFlags
; case checkTypeableConditions (dflags, tycon, tc_args) of
Just err -> bale_out err
......@@ -743,10 +770,10 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
inst_tys = [mkTyConApp tycon tc_args]
----------------------
mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
-> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
mk_typeable_eqn orig tvs cls tycon tc_args mtheta
mk_old_typeable_eqn :: CtOrigin -> [TyVar] -> Class
-> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
mk_old_typeable_eqn orig tvs cls tycon tc_args mtheta
-- The Typeable class is special in several ways
-- data T a b = ... deriving( Typeable )
-- gives
......@@ -757,13 +784,13 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta
-- 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` typeableClassKey)
= do { checkTc (cls `hasKey` oldTypeableClassKey)
(ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
; real_cls <- tcLookupClass (typeableClassNames `getNth` tyConArity tycon)
; real_cls <- tcLookupClass (oldTypeableClassNames `getNth` tyConArity tycon)
-- See Note [Getting base classes]
; mk_typeable_eqn orig tvs real_cls tycon [] (Just []) }
; mk_old_typeable_eqn orig tvs real_cls tycon [] (Just []) }
| otherwise -- standaone deriving
| otherwise -- standalone deriving
= do { checkTc (null tc_args)
(ptext (sLit "Derived typeable instance must be of form (Typeable")
<> int (tyConArity tycon) <+> ppr tycon <> rparen)
......@@ -775,6 +802,27 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta
, ds_tc = tycon, ds_tc_args = []
, ds_theta = mtheta `orElse` [], ds_newtype = False }) }
mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
-> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
mk_typeable_eqn orig tvs cls tycon tc_args mtheta
-- The kind-polymorphic Typeable class is less special; namely, there is no
-- need to select the class with the right kind anymore, as we only have one.
| isNothing mtheta -- deriving on a data type decl
= mk_typeable_eqn orig tvs cls tycon [] (Just [])
| otherwise -- standalone deriving
= do { checkTc (null tc_args)
(ptext (sLit "Derived typeable instance must be of form (Typeable")
<+> ppr tycon <> rparen)
; dfun_name <- new_dfun_name cls tycon
; loc <- getSrcSpanM
; return (Right $
DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
, ds_cls = cls, ds_tys = tyConKind tycon : [mkTyConApp tycon []]
, ds_tc = tycon, ds_tc_args = []
, ds_theta = mtheta `orElse` [], ds_newtype = False }) }
----------------------
inferConstraints :: Class -> [TcType]
-> TyCon -> [TcType]
......@@ -900,8 +948,9 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
where
ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
checkTypeableConditions :: Condition
checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK
checkTypeableConditions, checkOldTypeableConditions :: Condition
checkTypeableConditions = checkFlag Opt_DeriveDataTypeable
checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK
nonStdErr :: Class -> SDoc
nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
......@@ -1030,11 +1079,11 @@ cond_isProduct (_, rep_tc, _)
why = quotes (pprSourceTyCon rep_tc) <+>
ptext (sLit "must have precisely one constructor")
cond_typeableOK :: Condition
-- OK for Typeable class
cond_oldTypeableOK :: Condition
-- OK for kind-monomorphic Typeable class
-- Currently: (a) args all of kind *
-- (b) 7 or fewer args
cond_typeableOK (_, tc, _)
cond_oldTypeableOK (_, tc, _)
| tyConArity tc > 7 = Just too_many
| not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc))
= Just bad_kind
......@@ -1120,10 +1169,11 @@ non_iso_class :: Class -> Bool
-- even with -XGeneralizedNewtypeDeriving
non_iso_class cls
= classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
, genClassKey, gen1ClassKey] ++ typeableClassKeys)
, genClassKey, gen1ClassKey, typeableClassKey]
++ oldTypeableClassKeys)
typeableClassKeys :: [Unique]
typeableClassKeys = map getUnique typeableClassNames
oldTypeableClassKeys :: [Unique]
oldTypeableClassKeys = map getUnique oldTypeableClassNames
new_dfun_name :: Class -> TyCon -> TcM Name
new_dfun_name clas tycon -- Just a simple wrapper
......@@ -1681,7 +1731,11 @@ genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
-> Maybe CommonAuxiliary
-> TcM (LHsBinds RdrName, BagDerivStuff)
genDerivStuff loc fix_env clas name tycon comaux_maybe
| className clas `elem` typeableClassNames
| className clas `elem` oldTypeableClassNames
= do dflags <- getDynFlags
return (gen_old_Typeable_binds dflags loc tycon, emptyBag)
| className clas == typeableClassName
= do dflags <- getDynFlags
return (gen_Typeable_binds dflags loc tycon, emptyBag)
......
......@@ -24,7 +24,7 @@ module TcGenDeriv (
gen_Read_binds,
gen_Show_binds,
gen_Data_binds,
gen_Typeable_binds,
gen_old_Typeable_binds, gen_Typeable_binds,
gen_Functor_binds,
FFoldType(..), functorLikeTraverse,
deepSubtypesContaining, foldDataConArgs,
......@@ -1178,7 +1178,7 @@ getPrecedence get_fixity nm
%************************************************************************
%* *
\subsection{Typeable}
\subsection{Typeable (old)}
%* *
%************************************************************************
......@@ -1195,13 +1195,13 @@ we generate
We are passed the Typeable2 class as well as T
\begin{code}
gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName
gen_Typeable_binds dflags loc tycon
gen_old_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName
gen_old_Typeable_binds dflags loc tycon
= unitBag $
mk_easy_FunBind loc
(mk_typeOf_RDR tycon) -- Name of appropriate type0f function
(old_mk_typeOf_RDR tycon) -- Name of appropriate type0f function
[nlWildPat]
(nlHsApps mkTyConApp_RDR [tycon_rep, nlList []])
(nlHsApps oldMkTyConApp_RDR [tycon_rep, nlList []])
where
tycon_name = tyConName tycon
modl = nameModule tycon_name
......@@ -1211,7 +1211,7 @@ gen_Typeable_binds dflags loc tycon
pkg_fs = packageIdFS pkg
name_fs = occNameFS (nameOccName tycon_name)
tycon_rep = nlHsApps mkTyCon_RDR
tycon_rep = nlHsApps oldMkTyCon_RDR
(map nlHsLit [int64 high,
int64 low,
HsString pkg_fs,
......@@ -1226,9 +1226,9 @@ gen_Typeable_binds dflags loc tycon
| otherwise = HsWordPrim . fromIntegral
mk_typeOf_RDR :: TyCon -> RdrName
old_mk_typeOf_RDR :: TyCon -> RdrName
-- Use the arity of the TyCon to make the right typeOfn function
mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_INTERNAL (mkFastString ("typeOf" ++ suffix))
old_mk_typeOf_RDR tycon = varQual_RDR oLDTYPEABLE_INTERNAL (mkFastString ("typeOf" ++ suffix))
where
arity = tyConArity tycon
suffix | arity == 0 = ""
......@@ -1236,6 +1236,54 @@ mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_INTERNAL (mkFastString ("typeOf" ++ s
\end{code}
%************************************************************************
%* *
\subsection{Typeable (new)}
%* *
%************************************************************************
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_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName
gen_Typeable_binds dflags loc tycon
= unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat]
(nlHsApps mkTyConApp_RDR [tycon_rep, nlList []])
where
tycon_name = tyConName tycon
modl = nameModule tycon_name
pkg = modulePackageId modl
modl_fs = moduleNameFS (moduleName modl)
pkg_fs = packageIdFS pkg
name_fs = occNameFS (nameOccName tycon_name)
tycon_rep = nlHsApps mkTyCon_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
\end{code}
%************************************************************************
%* *
......
......@@ -56,13 +56,14 @@ import VarSet ( mkVarSet, subVarSet, varSetElems )
import Pair
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var), CoreExpr )
import PrelNames ( typeableClassNames )
import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames )
import Bag
import BasicTypes
import DynFlags
import ErrUtils
import FastString
import HscTypes ( isHsBoot )
import Id
import MkId
import Name
......@@ -382,13 +383,17 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- round)
-- Do class and family instance declarations
; env <- getGblEnv
; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
; let (local_infos_s, fam_insts_s) = unzip stuff
local_infos = concat local_infos_s
fam_insts = concat fam_insts_s
; addClsInsts local_infos $
addFamInsts fam_insts $
fam_insts = concat fam_insts_s
local_infos' = concat local_infos_s
-- Handwritten instances of the poly-kinded Typeable class are
-- forbidden, so we handle those separately
(typeable_instances, local_infos) = splitTypeable env local_infos'
; addClsInsts local_infos $
addFamInsts fam_insts $
do { -- Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
-- decl, so it needs to know about all the instances possible
......@@ -406,11 +411,14 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
; return (gbl_env, emptyBag, emptyValBindsOut) }
else tcDeriving tycl_decls inst_decls deriv_decls
-- Remove any handwritten instance of poly-kinded Typeable and warn
; dflags <- getDynFlags
; when (wopt Opt_WarnTypeableInstances dflags) $
mapM_ (addWarnTc . instMsg) typeable_instances
-- Check that if the module is compiled with -XSafe, there are no
-- hand written instances of Typeable as then unsafe casts could be
-- hand written instances of old Typeable as then unsafe casts could be
-- performed. Derived instances are OK.
; dflags <- getDynFlags
; when (safeLanguageOn dflags) $
mapM_ (\x -> when (typInstCheck x)
(addErrAt (getSrcSpan $ iSpec x) typInstErr))
......@@ -424,10 +432,27 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
, deriv_binds)
}}
where
typInstCheck ty = is_cls_nm (iSpec ty) `elem` typeableClassNames
-- Separate the Typeable instances from the rest
splitTypeable _ [] = ([],[])
splitTypeable env (i:is) =
let (typeableInsts, otherInsts) = splitTypeable env is
in if -- We will filter out instances of Typeable
(typeableClassName == is_cls_nm (iSpec i))
-- but not those that come from Data.Typeable.Internal
&& tcg_mod env /= tYPEABLE_INTERNAL
-- nor those from an .hs-boot file (deriving can't be used there)
&& not (isHsBoot (tcg_src env))
then (i:typeableInsts, otherInsts)
else (typeableInsts, i:otherInsts)
typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames
typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
++ " Haskell! Can only derive them"
instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; ignoring "
++ "the following instance:"))
2 (pprInstance (iSpec i))
addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
addClsInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
......
......@@ -1060,6 +1060,12 @@
<entry>dynamic</entry>
<entry><option>-XNoDeriveDataTypeable</option></entry>
</row>
<row>
<entry><option>-XAutoDeriveTypeable</option></entry>
<entry>Automatically derive Typeable instances for every datatype and type class declaration.</entry>
<entry>dynamic</entry>
<entry><option>-XNoAutoDeriveTypeable</option></entry>
</row>
<row>
<entry><option>-XDeriveGeneric</option></entry>
<entry>Enable <link linkend="deriving-typeable">deriving for the Generic class</link>.</entry>
......@@ -1447,6 +1453,14 @@
<entry><option>-fno-warn-warnings-deprecations</option></entry>
</row>
<row>
<entry><option>-fwarn-typeable-instances</option></entry>
<entry>warn if there are any handwritten <literal>Typeable</literal>
instances (see <xref linkend="deriving-typeable"/>)</entry>
<entry>dynamic</entry>
<entry><option>-fno-warn-typeable-instances</option></entry>
</row>
</tbody>
</tgroup>
</informaltable>
......
......@@ -3379,19 +3379,19 @@ GHC extends this list with several more classes that may be automatically derive
<literal>Typeable</literal>, and <literal>Data</literal>, defined in the library
modules <literal>Data.Typeable</literal> and <literal>Data.Generics</literal> respectively.
</para>
<para>An instance of <literal>Typeable</literal> can only be derived if the
data type has seven or fewer type parameters, all of kind <literal>*</literal>.
The reason for this is that the <literal>Typeable</literal> class is derived using the scheme
described in
<ulink url="http://research.microsoft.com/%7Esimonpj/papers/hmap/gmap2.ps">
Scrap More Boilerplate: Reflection, Zips, and Generalised Casts
</ulink>.
(Section 7.4 of the paper describes the multiple <literal>Typeable</literal> classes that
are used, and only <literal>Typeable1</literal> up to
<literal>Typeable7</literal> are provided in the library.)
In other cases, there is nothing to stop the programmer writing a <literal>TypeableX</literal>
class, whose kind suits that of the data type constructor, and
then writing the data type instance by hand.
<para>Since GHC 7.8.1, <literal>Typeable</literal> is kind-polymorphic (see
<xref linkend="kind-polymorphism"/>) and can be derived for any datatype and
type class. Instances for datatypes can be derived by attaching a
<literal>deriving Typeable</literal> clause to the datatype declaration, or by
using standalone deriving (see <xref linkend="stand-alone-deriving"/>).
Instances for type classes can only be derived using standalone deriving.
Additionally, <option>-XAutoDeriveTypeable</option> will trigger the generation
of derived <literal>Typeable</literal> instances for every datatype and type
class declaration in the module it is used.
</para>
<para>
Also since GHC 7.8.1, handwritten (ie. not derived) instances of
<literal>Typeable</literal> are forbidden, and will be ignored with a warning.
</para>
</listitem>
......
......@@ -956,8 +956,9 @@ test.hs:(5,4)-(6,7):
<option>-fwarn-missing-methods</option>,
<option>-fwarn-lazy-unlifted-bindings</option>,
<option>-fwarn-wrong-do-bind</option>,
<option>-fwarn-unsupported-calling-conventions</option>, and
<option>-fwarn-dodgy-foreign-imports</option>. The following
<option>-fwarn-unsupported-calling-conventions</option>,
<option>-fwarn-dodgy-foreign-imports</option>, and
<option>-fwarn-typeable-instances</option>. The following
flags are
simple ways to select standard &ldquo;packages&rdquo; of warnings:
</para>
......@@ -1682,6 +1683,19 @@ f "2" = 2
</listitem>
</varlistentry>
<varlistentry>
<term><option>-fwarn-typeable-instances</option>:</term>
<listitem>
<indexterm><primary><option>-fwarn-typeable-instances</option></primary></indexterm>
<indexterm><primary>typeable instances, warning</primary></indexterm>
<para>Report handwritten (ie. not derived) instances of the
<literal>Typeable</literal> class. These are ignore by the compiler;
only derived instances of <literal>Typeable</literal> are allowed.
</para>
</listitem>
</varlistentry>
</variablelist>
<para>If you're feeling really paranoid, the
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment