%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 19961998
%
TcTyClsDecls: Typecheck type and class declarations
\begin{code}
module TcTyClsDecls (
tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
) where
#include "HsVersions.h"
import HsSyn
import HscTypes
import BuildTyCl
import TcUnify
import TcRnMonad
import TcEnv
import TcTyDecls
import TcClassDcl
import TcHsType
import TcMType
import TcType
import TysWiredIn ( unitTy )
import Type
import Generics
import Class
import TyCon
import DataCon
import Id
import MkId ( mkDefaultMethodId )
import MkCore ( rEC_SEL_ERROR_ID )
import IdInfo
import Var
import VarSet
import Name
import Outputable
import Maybes
import Unify
import Util
import SrcLoc
import ListSetOps
import Digraph
import DynFlags
import FastString
import Unique ( mkBuiltinUnique )
import BasicTypes
import Bag
import Control.Monad
import Data.List
\end{code}
%************************************************************************
%* *
\subsection{Type checking for type and class declarations}
%* *
%************************************************************************
Dealing with a group
~~~~~~~~~~~~~~~~~~~~
Consider a mutuallyrecursive group, binding
a type constructor T and a class C.
Step 1: getInitialKind
Construct a KindEnv by binding T and C to a kind variable
Step 2: kcTyClDecl
In that environment, do a kind check
Step 3: Zonk the kinds
Step 4: buildTyConOrClass
Construct an environment binding T to a TyCon and C to a Class.
a) Their kinds comes from zonking the relevant kind variable
b) Their arity (for synonyms) comes direct from the decl
c) The funcional dependencies come from the decl
d) The rest comes a knottied binding of T and C, returned from Step 4
e) The variances of the tycons in the group is calculated from
the knottied stuff
Step 5: tcTyClDecl1
In this environment, walk over the decls, constructing the TyCons and Classes.
This uses in a strict way items (a)(c) above, which is why they must
be constructed in Step 4. Feed the results back to Step 4.
For this step, pass the isrecursive flag as the wimpout flag
to tcTyClDecl1.
Step 6: Extend environment
We extend the type environment with bindings not only for the TyCons and Classes,
but also for their "implicit Ids" like data constructors and class selectors
Step 7: checkValidTyCl
For a recursive group only, check all the decls again, just
to check all the side conditions on validity. We could not
do this before because we were in a mutually recursive knot.
Identification of recursive TyCons
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The knottying parameters: @rec_details_list@ is an alist mapping @Name@s to
@TyThing@s.
Identifying a TyCon as recursive serves two purposes
1. Avoid infinite types. Nonrecursive newtypes are treated as
"transparent", like type synonyms, after the type checker. If we did
this for all newtypes, we'd get infinite types. So we figure out for
each newtype whether it is "recursive", and add a coercion if so. In
effect, we are trying to "cut the loops" by identifying a loopbreaker.
2. Avoid infinite unboxing. This is nothing to do with newtypes.
Suppose we have
data T = MkT Int T
f (MkT x t) = f t
Well, this function diverges, but we don't want the strictness analyser
to diverge. But the strictness analyser will diverge because it looks
deeper and deeper into the structure of T. (I believe there are
examples where the function does something sane, and the strictness
analyser still diverges, but I can't see one now.)
Now, concerning (1), the FC2 branch currently adds a coercion for ALL
newtypes. I did this as an experiment, to try to expose cases in which
the coercions got in the way of optimisations. If it turns out that we
can indeed always use a coercion, then we don't risk recursive types,
and don't need to figure out what the loop breakers are.
For newtype *families* though, we will always have a coercion, so they
are always loop breakers! So you can easily adjust the current
algorithm by simply treating all newtype families as loop breakers (and
indeed type families). I think.
\begin{code}
tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
-> TcM (TcGblEnv,
HsValBinds Name,
[Id])
tcTyAndClassDecls boot_details allDecls
= checkNoErrs $
do {
; let decls = filter (not . isFamInstDecl . unLoc) allDecls
; checkCycleErrs decls
; mod <- getModule
; traceTc "tcTyAndCl" (ppr mod)
; (syn_tycons, alg_tyclss) <- fixM (\ ~(_rec_syn_tycons, rec_alg_tyclss) ->
do { let {
; (syn_decls, alg_decls) = partition (isSynDecl . unLoc)
decls
; alg_at_decls = concatMap addATs alg_decls
}
; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss
; tcExtendRecEnv gbl_things $ do
{ (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
; let {
; calc_rec = calcRecFlags boot_details rec_alg_tyclss
; tc_decl = addLocM (tcTyClDecl calc_rec) }
; syn_tycons <- tcSynDecls kc_syn_decls
; tcExtendGlobalEnv syn_tycons $ do
{ alg_tyclss <- mapM tc_decl kc_alg_decls
; return (syn_tycons, concat alg_tyclss)
}}})
; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
{ traceTc "ready for validity check" empty
; mapM_ (addLocM checkValidTyCl) decls
; traceTc "done" empty
; let { implicit_things = concatMap implicitTyThings alg_tyclss
; rec_sel_binds = mkRecSelBinds alg_tyclss
; dm_ids = mkDefaultMethodIds alg_tyclss }
; traceTc "Adding types and classes" $ vcat
[ ppr alg_tyclss
, text "and" <+> ppr implicit_things ]
; env <- tcExtendGlobalEnv implicit_things getGblEnv
; return (env, rec_sel_binds, dm_ids) }
}
where
addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
addATs decl = [decl]
mkGlobalThings :: [LTyClDecl Name]
-> [TyThing]
-> [(Name,TyThing)]
mkGlobalThings decls things
= map mk_thing (decls `zipLazy` things)
where
mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
= (name, AClass cl)
mk_thing (L _ decl, ~(ATyCon tc))
= (tcdName decl, ATyCon tc)
\end{code}
%************************************************************************
%* *
Type checking family instances
%* *
%************************************************************************
Family instances are somewhat of a hybrid. They are processed together with
class instance heads, but can contain data constructors and hence they share a
lot of kinding and type checking code with ordinary algebraic data types (and
GADTs).
\begin{code}
tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
tcFamInstDecl top_lvl (L loc decl)
=
setSrcSpan loc $
tcAddDeclCtxt decl $
do {
; type_families <- xoptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot
; checkTc type_families $ badFamInstDecl (tcdLName decl)
; checkTc (not is_boot) $ badBootFamInstDeclErr
; tc <- tcFamInstDecl1 decl
; checkValidTyCon tc
; when (isTopLevel top_lvl && isAssocFamily tc)
(addErr $ assocInClassErr (tcdName decl))
; return (ATyCon tc) }
isAssocFamily :: TyCon -> Bool
isAssocFamily tycon
= case tyConFamInst_maybe tycon of
Nothing -> panic "isAssocFamily: no family?!?"
Just (fam, _) -> isTyConAssoc fam
assocInClassErr :: Name -> SDoc
assocInClassErr name
= ptext (sLit "Associated type") <+> quotes (ppr name) <+>
ptext (sLit "must be inside a class instance")
tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
= kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
do {
checkTc (isFamilyTyCon family) (notFamily family)
; checkTc (isSynTyCon family) (wrongKindOfFamily family)
;
; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
; let famArity = tyConArity family
; checkTc (length k_typats == famArity) $
wrongNumberOfParmsErr famArity
; tcTyVarBndrs k_tvs $ \t_tvs -> do {
; t_typats <- mapM tcHsKindedType k_typats
; t_rhs <- tcHsKindedType k_rhs
; checkValidTypeInst t_typats t_rhs
; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
(typeKind t_rhs)
NoParentTyCon (Just (family, t_typats))
}}
tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
tcdCons = cons})
= kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
do {
checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
;
; k_decl <- kcDataDecl decl k_tvs
; let k_ctxt = tcdCtxt k_decl
k_cons = tcdCons k_decl
; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
; tcTyVarBndrs k_tvs $ \t_tvs -> do {
; unbox_strict <- doptM Opt_UnboxStrictFields
; t_typats <- mapM tcHsKindedType k_typats
; stupid_theta <- tcHsKindedContext k_ctxt
; mapM_ checkTyFamFreeness t_typats
; gadt_ok <- xoptM Opt_GADTs
; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
; checkTc (new_or_data == DataType || isSingleton k_cons) $
newtypeConError tc_name (length k_cons)
; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
; let ex_ok = True
; fixM (\ rep_tycon -> do
{ let orig_res_ty = mkTyConApp fam_tycon t_typats
; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
(t_tvs, orig_res_ty) k_cons
; tc_rhs <-
case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
})
}}
where
h98_syntax = case cons of
L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
_ -> True
tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
kcIdxTyPats :: TyClDecl Name
-> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
-> TcM a
kcIdxTyPats decl thing_inside
= kcHsTyVars (tcdTyVars decl) $ \tvs ->
do { let tc_name = tcdLName decl
; fam_tycon <- tcLookupLocatedTyCon tc_name
; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
; hs_typats = fromJust $ tcdTyPats decl }
; checkTc (length kinds >= length hs_typats) $
tooManyParmsErr (tcdLName decl)
; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
; typats <- zipWithM kcCheckLHsType hs_typats
[ EK kind (EkArg (ppr tc_name) n)
| (kind,n) <- kinds `zip` [1..]]
; thing_inside tvs typats resultKind fam_tycon
}
\end{code}
%************************************************************************
%* *
Kind checking
%* *
%************************************************************************
We need to kind check all types in the mutually recursive group
before we know the kind of the type variables. For example:
class C a where
op :: D b => a -> b -> b
class D c where
bop :: (Monad c) => ...
Here, the kind of the locallypolymorphic type variable "b"
depends on *all the uses of class D*. For example, the use of
Monad c in bop's type signature means that D must have kind Type->Type.
However type synonyms work differently. They can have kinds which don't
just involve (->) and *:
type R = Int#
type S a = Array# a
type T a b = (# a,b #)
So we must infer their kinds from their righthand sides *first* and then
use them, whereas for the mutually recursive data types D we bring into
scope kind bindings D -> k, where k is a kind variable, and do inference.
Type families
~~~~~~~~~~~~~
This treatment of type synonyms only applies to Haskell 98style synonyms.
General type functions can be recursive, and hence, appear in `alg_decls'.
The kind of a type family is solely determinded by its kind signature;
hence, only kind signatures participate in the construction of the initial
kind environment (as constructed by `getInitialKind'). In fact, we ignore
instances of families altogether in the following. However, we need to
include the kinds of associated families into the construction of the
initial kind environment. (This is handled by `allDecls').
\begin{code}
kcTyClDecls :: [LTyClDecl Name] -> [Located (TyClDecl Name)]
-> TcM ([LTyClDecl Name], [Located (TyClDecl Name)])
kcTyClDecls syn_decls alg_decls
= do {
let initialKindDecls = concat [allDecls decl | L _ decl <- alg_decls]
; alg_kinds <- mapM getInitialKind initialKindDecls
; tcExtendKindEnv alg_kinds $ do
{ (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls)
; tcExtendKindEnv syn_kinds $ do
{ kc_alg_decls <- mapM (wrapLocM kcTyClDecl)
(filter (not . isFamInstDecl . unLoc) alg_decls)
; return (kc_syn_decls, kc_alg_decls) }}}
where
allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at
| L _ at <- ats
, isFamilyDecl at]
allDecls decl | isFamInstDecl decl = []
| otherwise = [decl]
getInitialKind :: TyClDecl Name -> TcM (Name, TcKind)
getInitialKind decl
= do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
; res_kind <- mk_res_kind decl
; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
where
mk_arg_kind (UserTyVar _ _) = newKindVar
mk_arg_kind (KindedTyVar _ kind) = return kind
mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind
mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind
mk_res_kind _ = return liftedTypeKind
kcSynDecls :: [SCC (LTyClDecl Name)]
-> TcM ([LTyClDecl Name],
[(Name,TcKind)])
kcSynDecls []
= return ([], [])
kcSynDecls (group : groups)
= do { (decl, nk) <- kcSynDecl group
; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups)
; return (decl:decls, nk:nks) }
kcSynDecl :: SCC (LTyClDecl Name)
-> TcM (LTyClDecl Name,
(Name,TcKind))
kcSynDecl (AcyclicSCC (L loc decl))
= tcAddDeclCtxt decl $
kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
<+> brackets (ppr k_tvs))
; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
(unLoc (tcdLName decl), tc_kind)) })
kcSynDecl (CyclicSCC decls)
= do { recSynErr decls; failM }
kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
kcTyClDecl decl@(TyData {})
= ASSERT( not . isFamInstDecl $ decl )
kcTyClDeclBody decl $
kcDataDecl decl
kcTyClDecl decl@(TyFamily {})
= kcFamilyDecl [] decl
kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
= kcTyClDeclBody decl $ \ tvs' ->
do { ctxt' <- kcHsContext ctxt
; ats' <- mapM (wrapLocM (kcFamilyDecl tvs')) ats
; sigs' <- mapM (wrapLocM kc_sig) sigs
; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs',
tcdATs = ats'}) }
where
kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
; return (TypeSig nm op_ty') }
kc_sig other_sig = return other_sig
kcTyClDecl decl@(ForeignType {})
= return decl
kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym"
kcTyClDeclBody :: TyClDecl Name
-> ([LHsTyVarBndr Name] -> TcM a)
-> TcM a
kcTyClDeclBody decl thing_inside
= tcAddDeclCtxt decl $
do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
; let tc_kind = case tc_ty_thing of
AThing k -> k
_ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
(kinds, _) = splitKindFunTys tc_kind
hs_tvs = tcdTyVars decl
kinded_tvs = ASSERT( length kinds >= length hs_tvs )
zipWith add_kind hs_tvs kinds
; tcExtendKindEnvTvs kinded_tvs thing_inside }
where
add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k)
add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name)
kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
tvs
= do { ctxt' <- kcHsContext ctxt
; cons' <- mapM (wrapLocM kc_con_decl) cons
; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
where
kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
, con_cxt = ex_ctxt, con_details = details, con_res = res })
= addErrCtxt (dataConCtxt name) $
kcHsTyVars ex_tvs $ \ex_tvs' -> do
do { ex_ctxt' <- kcHsContext ex_ctxt
; details' <- kc_con_details details
; res' <- case res of
ResTyH98 -> return ResTyH98
ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
, con_details = details', con_res = res' }) }
kc_con_details (PrefixCon btys)
= do { btys' <- mapM kc_larg_ty btys
; return (PrefixCon btys') }
kc_con_details (InfixCon bty1 bty2)
= do { bty1' <- kc_larg_ty bty1
; bty2' <- kc_larg_ty bty2
; return (InfixCon bty1' bty2') }
kc_con_details (RecCon fields)
= do { fields' <- mapM kc_field fields
; return (RecCon fields') }
kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
; return (ConDeclField fld bty' d) }
kc_larg_ty bty = case new_or_data of
DataType -> kcHsSigType bty
NewType -> kcHsLiftedSigType bty
kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d)
kcFamilyDecl :: [LHsTyVarBndr Name]
-> TyClDecl Name -> TcM (TyClDecl Name)
kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
= kcTyClDeclBody decl $ \tvs' ->
do { mapM_ unifyClassParmKinds tvs'
; return (decl {tcdTyVars = tvs',
tcdKind = kind `mplus` Just liftedTypeKind})
}
where
unifyClassParmKinds (L _ tv)
| (n,k) <- hsTyVarNameKind tv
, Just classParmKind <- lookup n classTyKinds
= unifyKind k classParmKind
| otherwise = return ()
classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
kcFamilyDecl _ (TySynonym {})
= panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
\end{code}
%************************************************************************
%* *
\subsection{Type checking}
%* *
%************************************************************************
\begin{code}
tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing]
tcSynDecls [] = return []
tcSynDecls (decl : decls)
= do { syn_tc <- addLocM tcSynDecl decl
; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls)
; return (syn_tc : syn_tcs) }
tcSynDecl :: TyClDecl Name -> TcM TyThing
tcSynDecl
(TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc "tcd1" (ppr tc_name)
; rhs_ty' <- tcHsKindedType rhs_ty
; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
(typeKind rhs_ty') NoParentTyCon Nothing
; return (ATyCon tycon)
}
tcSynDecl d = pprPanic "tcSynDecl" (ppr d)
tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
tcTyClDecl calc_isrec decl
= tcAddDeclCtxt decl (tcTyClDecl1 NoParentTyCon calc_isrec decl)
tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
tcTyClDecl1 parent _calc_isrec
(TyFamily {tcdFlavour = TypeFamily,
tcdLName = L _ tc_name, tcdTyVars = tvs,
tcdKind = Just kind})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc "type family:" (ppr tc_name)
; idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
; return [ATyCon tycon]
}
tcTyClDecl1 parent _calc_isrec
(TyFamily {tcdFlavour = DataFamily,
tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc "data family:" (ppr tc_name)
; extra_tvs <- tcDataKindSig mb_kind
; let final_tvs = tvs' ++ extra_tvs
; idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
DataFamilyTyCon Recursive False True
parent Nothing
; return [ATyCon tycon]
}
tcTyClDecl1 parent calc_isrec
(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta <- tcHsKindedContext ctxt
; want_generic <- xoptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
; empty_data_decls <- xoptM Opt_EmptyDataDecls
; kind_signatures <- xoptM Opt_KindSignatures
; existential_ok <- xoptM Opt_ExistentialQuantification
; gadt_ok <- xoptM Opt_GADTs
; is_boot <- tcIsHsBoot
; let ex_ok = existential_ok || gadt_ok
; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name)
; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
; checkTc (new_or_data == DataType || isSingleton cons)
(newtypeConError tc_name (length cons))
; checkTc (not (null cons) || empty_data_decls || is_boot)
(emptyConDeclsErr tc_name)
; tycon <- fixM (\ tycon -> do
{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
; data_cons <- tcConDecls unbox_strict ex_ok
tycon (final_tvs, res_ty) cons
; tc_rhs <-
if null cons && is_boot
then return AbstractTyCon
else case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
(want_generic && canDoGenerics data_cons) (not h98_syntax)
parent Nothing
})
; return [ATyCon tycon]
}
where
is_rec = calc_isrec tc_name
h98_syntax = consUseH98Syntax cons
tcTyClDecl1 _parent calc_isrec
(ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
tcdCtxt = ctxt, tcdMeths = meths,
tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
= tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; fds' <- mapM (addLocM tc_fundep) fundeps
; sig_stuff <- tcClassSigs class_name sigs meths
; clas <- fixM $ \ clas -> do
{ let
tycon_name = tyConName (classTyCon clas)
tc_isrec = calc_isrec tycon_name
; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
; buildClass False
class_name tvs' ctxt' fds' (concat atss')
sig_stuff tc_isrec }
; return (AClass clas : map ATyCon (classATs clas))
}
where
tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ;
; tvs2' <- mapM tcLookupTyVar tvs2 ;
; return (tvs1', tvs2') }
tcTyClDecl1 _ _
(ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
= return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
-> [LConDecl Name] -> TcM [DataCon]
tcConDecls unbox ex_ok rep_tycon res_tmpl cons
= mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons
tcConDecl :: Bool
-> Bool
-> TyCon
-> ([TyVar], Type)
-> ConDecl Name
-> TcM DataCon
tcConDecl unbox_strict existential_ok rep_tycon res_tmpl
(ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt
, con_details = details, con_res = res_ty })
= addErrCtxt (dataConCtxt name) $
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; checkTc (existential_ok || (null tvs && null (unLoc ctxt)))
(badExistential name)
; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
; let
tc_datacon is_infix field_lbls btys
= do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys
; buildDataCon (unLoc name) is_infix
stricts field_lbls
univ_tvs ex_tvs eq_preds ctxt' arg_tys
res_ty' rep_tycon }
; case details of
PrefixCon btys -> tc_datacon False [] btys
InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
RecCon fields -> tc_datacon False field_names btys
where
field_names = map (unLoc . cd_fld_name) fields
btys = map cd_fld_type fields
}
tcResultType :: ([TyVar], Type)
-> [TyVar]
-> ResType Name
-> TcM ([TyVar],
[TyVar],
[(TyVar,Type)],
Type)
tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98
= return (tmpl_tvs, dc_tvs, [], res_ty)
tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
= do { res_ty' <- tcHsKindedType res_ty
; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty'
(univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs
choose tmpl (univs, eqs)
| Just ty <- lookupTyVar subst tmpl
= case tcGetTyVar_maybe ty of
Just tv | not (tv `elem` univs)
-> (tv:univs, eqs)
_other -> (tmpl:univs, (tmpl,ty):eqs)
| otherwise = pprPanic "tcResultType" (ppr res_ty)
ex_tvs = dc_tvs `minusList` univ_tvs
; return (univ_tvs, ex_tvs, eq_spec, res_ty') }
where
(_, tidy_tmpl_tvs) = mapAccumL tidy_one init_occ_env tmpl_tvs
init_occ_env = initTidyOccEnv (map getOccName dc_tvs)
tidy_one env tv = (env', setTyVarName tv (tidyNameOcc name occ'))
where
name = tyVarName tv
(env', occ') = tidyOccName env (getOccName name)
consUseH98Syntax :: [LConDecl a] -> Bool
consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
consUseH98Syntax _ = True
tcConArg :: Bool
-> LHsType Name
-> TcM (TcType, HsBang)
tcConArg unbox_strict bty
= do { arg_ty <- tcHsBangType bty
; let bang = getBangStrictness bty
; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
; return (arg_ty, strict_mark) }
chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
chooseBoxingStrategy unbox_strict_fields arg_ty bang
= case bang of
HsNoBang -> HsNoBang
HsUnpack -> can_unbox HsUnpackFailed arg_ty
HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty
| otherwise -> HsStrict
HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
where
can_unbox :: HsBang -> TcType -> HsBang
can_unbox fail_bang arg_ty
= case splitTyConApp_maybe arg_ty of
Nothing -> fail_bang
Just (arg_tycon, tycon_args)
| isAbstractTyCon arg_tycon -> HsStrict
| not (isRecursiveTyCon arg_tycon)
, isProductTyCon arg_tycon
-> if isNewTyCon arg_tycon
then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
else HsUnpack
| otherwise -> fail_bang
\end{code}
Note [Don't complain about UNPACK on abstract TyCons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are going to complain about UnpackFailed, but if we say
data T = MkT !Wobble
and Wobble is a newtype imported from a module that was compiled
without optimisation, we don't want to complain. Because it might
be fine when optimsation is on. I think this happens when Haddock
is working over (say) GHC souce files.
Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
Be careful not to try to unbox this!
data T = MkT !T Int
But it's the *argument* type that matters. This is fine:
data S = MkS S !Int
because Int is nonrecursive.
%************************************************************************
%* *
Validity checking
%* *
%************************************************************************
Validity checking is done once the mutuallyrecursive knot has been
tied, so we can look at things freely.
\begin{code}
checkCycleErrs :: [LTyClDecl Name] -> TcM ()
checkCycleErrs tyclss
| null cls_cycles
= return ()
| otherwise
= do { mapM_ recClsErr cls_cycles
; failM }
where
cls_cycles = calcClassCycles tyclss
checkValidTyCl :: TyClDecl Name -> TcM ()
checkValidTyCl decl
= tcAddDeclCtxt decl $
do { thing <- tcLookupLocatedGlobal (tcdLName decl)
; traceTc "Validity of" (ppr thing)
; case thing of
ATyCon tc -> checkValidTyCon tc
AClass cl -> checkValidClass cl
_ -> panic "checkValidTyCl"
; traceTc "Done validity of" (ppr thing)
}
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon tc
| isSynTyCon tc
= case synTyConRhs tc of
SynFamilyTyCon {} -> return ()
SynonymTyCon ty -> checkValidType syn_ctxt ty
| otherwise
= do
checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
mapM_ (checkValidDataCon tc) data_cons
mapM_ check_fields groups
where
syn_ctxt = TySynCtxt name
name = tyConName tc
data_cons = tyConDataCons tc
groups = equivClasses cmp_fld (concatMap get_fields data_cons)
cmp_fld (f1,_) (f2,_) = f1 `compare` f2
get_fields con = dataConFieldLabels con `zip` repeat con
check_fields ((label, con1) : other_fields)
= recoverM (return ()) $ mapM_ checkOne other_fields
where
(tvs1, _, _, res1) = dataConSig con1
ts1 = mkVarSet tvs1
fty1 = dataConFieldType con1 label
checkOne (_, con2)
= do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2
; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 }
where
(tvs2, _, _, res2) = dataConSig con2
ts2 = mkVarSet tvs2
fty2 = dataConFieldType con2 label
check_fields [] = panic "checkValidTyCon/check_fields []"
checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet
-> Type -> Type -> Type -> Type -> TcM ()
checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
= do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
where
mb_subst1 = tcMatchTy tvs1 res1 res2
mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
checkValidDataCon :: TyCon -> DataCon -> TcM ()
checkValidDataCon tc con
= setSrcSpan (srcLocSpan (getSrcLoc con)) $
addErrCtxt (dataConCtxt con) $
do { traceTc "Validity of data con" (ppr con)
; let tc_tvs = tyConTyVars tc
res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
actual_res_ty = dataConOrigResTy con
; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
res_ty_tmpl
actual_res_ty))
(badDataConTyCon con res_ty_tmpl actual_res_ty)
; checkValidMonoType (dataConOrigResTy con)
; checkValidType ctxt (dataConUserType con)
; when (isNewTyCon tc) (checkNewDataCon con)
; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
}
where
ctxt = ConArgCtxt (dataConName con)
check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
check_bang _ = return ()
cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
, speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
checkNewDataCon :: DataCon -> TcM ()
checkNewDataCon con
= do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
; checkTc (null eq_spec) (newtypePredError con)
; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
; checkTc (not (any isBanged (dataConStrictMarks con)))
(newtypeStrictError con)
}
where
(_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con
checkValidClass :: Class -> TcM ()
checkValidClass cls
= do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods
; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses
; fundep_classes <- xoptM Opt_FunctionalDependencies
; checkTc (notNull tyvars) (nullaryClassErr cls)
; checkTc (multi_param_type_classes || unary) (classArityErr cls)
; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
; checkValidTheta (ClassSCCtxt (className cls)) theta
; mapM_ (check_op constrained_class_methods) op_stuff
; checkTc (unary || no_generics) (genericMultiParamErr cls)
}
where
(tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
unary = isSingleton tyvars
no_generics = null [() | (_, GenDefMeth) <- op_stuff]
check_op constrained_class_methods (sel_id, dm)
= addErrCtxt (classOpCtxt sel_id tau) $ do
{ checkValidTheta SigmaCtxt (tail theta)
; traceTc "class op type" (ppr op_ty <+> ppr tau)
; checkValidType (FunSigCtxt op_name) tau
; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
(noClassTyVarErr cls sel_id)
; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
(badGenericMethodType op_name op_ty)
}
where
op_name = idName sel_id
op_ty = idType sel_id
(_,theta1,tau1) = tcSplitSigmaTy op_ty
(_,theta2,tau2) = tcSplitSigmaTy tau1
(theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2)
| otherwise = (theta1, mkPhiTy (tail theta1) tau1)
\end{code}
%************************************************************************
%* *
Building record selectors
%* *
%************************************************************************
\begin{code}
mkDefaultMethodIds :: [TyThing] -> [Id]
mkDefaultMethodIds things
= [ mkDefaultMethodId sel_id dm_name
| AClass cls <- things
, (sel_id, DefMeth dm_name) <- classOpItems cls ]
\end{code}
Note [Default method Ids and Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (Trac #4169):
class Numeric a where
fromIntegerNum :: a
fromIntegerNum = ...
ast :: Q [Dec]
ast = [d| instance Numeric Int |]
When we typecheck 'ast' we have done the first pass over the class decl
(in tcTyClDecls), but we have not yet typechecked the defaultmethod
declarations (becuase they can mention value declarations). So we
must bring the default method Ids into scope first (so they can be seen
when typechecking the [d| .. |] quote, and typecheck them later.
\begin{code}
mkRecSelBinds :: [TyThing] -> HsValBinds Name
mkRecSelBinds ty_things
= ValBindsOut [(NonRecursive, b) | b <- binds] sigs
where
(sigs, binds) = unzip rec_sels
rec_sels = map mkRecSelBind [ (tc,fld)
| ATyCon tc <- ty_things
, fld <- tyConFields tc ]
mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
mkRecSelBind (tycon, sel_name)
= (L loc (IdSig sel_id), unitBag (L loc sel_bind))
where
loc = getSrcSpan tycon
sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
all_cons = tyConDataCons tycon
cons_w_field = [ con | con <- all_cons
, sel_name `elem` dataConFieldLabels con ]
con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
field_ty = dataConFieldType con1 sel_name
data_ty = dataConOrigResTy con1
data_tvs = tyVarsOfType data_ty
is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
(field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
sel_ty | is_naughty = unitTy
| otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $
mkPhiTy (dataConStupidTheta con1) $
mkPhiTy field_theta $
mkFunTy data_ty field_tau
sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs]
| otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
(L loc (HsVar field_var))
mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
rec_field = HsRecField { hsRecFieldId = sel_lname
, hsRecFieldArg = nlVarPat field_var
, hsRecPun = False }
sel_lname = L loc sel_name
field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
deflt | not (any is_unused all_cons) = []
| otherwise = [mkSimpleMatch [nlWildPat]
(nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
(nlHsLit msg_lit))]
is_unused con = not (con `elem` cons_w_field
|| dataConCannotMatch inst_tys con)
inst_tys = tyConAppArgs data_ty
unit_rhs = mkLHsTupleExpr []
msg_lit = HsStringPrim $ mkFastString $
occNameString (getOccName sel_name)
tyConFields :: TyCon -> [FieldLabel]
tyConFields tc
| isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
| otherwise = []
\end{code}
Note [Polymorphic selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When a record has a polymorphic field, we pull the foralls out to the front.
data T = MkT { f :: forall a. [a] -> a }
Then f :: forall a. T -> [a] -> a
NOT f :: T -> forall a. [a] -> a
This is horrid. It's only needed in deeply obscure cases, which I hate.
The only case I know is test tc163, which is worth looking at. It's far
from clear that this test should succeed at all!
Note [Naughty record selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A "naughty" field is one for which we can't define a record
selector, because an existential type variable would escape. For example:
data T = forall a. MkT { x,y::a }
We obviously can't define
x (MkT v _) = v
Nevertheless we *do* put a RecSelId into the type environment
so that if the user tries to use 'x' as a selector we can bleat
helpfully, rather than saying unhelpfully that 'x' is not in scope.
Hence the sel_naughty flag, to identify record selectors that don't really exist.
In general, a field is "naughty" if its type mentions a type variable that
isn't in the result type of the constructor. Note that this *allows*
GADT record selectors (Note [GADT record selectors]) whose types may look
like sel :: T [a] -> a
For naughty selectors we make a dummy binding
sel = ()
for naughty selectors, so that the later typecheck will add them to the
environment, and they'll be exported. The function is never called, because
the tyepchecker spots the sel_naughty field.
Note [GADT record selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For GADTs, we require that all constructors with a common field 'f' have the same
result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
E.g.
data T where
T1 { f :: Maybe a } :: T [a]
T2 { f :: Maybe a, y :: b } :: T [a]
and now the selector takes that result type as its argument:
f :: forall a. T [a] -> Maybe a
Details: the "real" types of T1,T2 are:
T1 :: forall r a. (r~[a]) => a -> T r
T2 :: forall r a b. (r~[a]) => a -> b -> T r
So the selector loooks like this:
f :: forall a. T [a] -> Maybe a
f (a:*) (t:T [a])
= case t of
T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g))
T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
Note the forall'd tyvars of the selector are just the free tyvars
of the result type; there may be other tyvars in the constructor's
type (e.g. 'b' in T2).
Note the need for casts in the result!
Note [Selector running example]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's OK to combine GADTs and type families. Here's a running example:
data instance T [a] where
T1 { fld :: b } :: T [Maybe b]
The representation type looks like this
data :R7T a where
T1 { fld :: b } :: :R7T (Maybe b)
and there's coercion from the family type to the representation type
:CoR7T a :: T [a] ~ :R7T a
The selector we want for fld looks like this:
fld :: forall b. T [Maybe b] -> b
fld = /\b. \(d::T [Maybe b]).
case d `cast` :CoR7T (Maybe b) of
T1 (x::b) -> x
The scrutinee of the case has type :R7T (Maybe b), which can be
gotten by appying the eq_spec to the univ_tvs of the data con.
%************************************************************************
%* *
Error messages
%* *
%************************************************************************
\begin{code}
resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
resultTypeMisMatch field_name con1 con2
= vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma],
nest 2 $ ptext (sLit "but have different result types")]
fieldTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
fieldTypeMisMatch field_name con1 con2
= sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
ptext (sLit "give different types for field"), quotes (ppr field_name)]
dataConCtxt :: Outputable a => a -> SDoc
dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)
classOpCtxt :: Var -> Type -> SDoc
classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"),
nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
nullaryClassErr :: Class -> SDoc
nullaryClassErr cls
= ptext (sLit "No parameters for class") <+> quotes (ppr cls)
classArityErr :: Class -> SDoc
classArityErr cls
= vcat [ptext (sLit "Too many parameters for class") <+> quotes (ppr cls),
parens (ptext (sLit "Use -XMultiParamTypeClasses to allow multi-parameter classes"))]
classFunDepsErr :: Class -> SDoc
classFunDepsErr cls
= vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls),
parens (ptext (sLit "Use -XFunctionalDependencies to allow fundeps"))]
noClassTyVarErr :: Class -> Var -> SDoc
noClassTyVarErr clas op
= sep [ptext (sLit "The class method") <+> quotes (ppr op),
ptext (sLit "mentions none of the type variables of the class") <+>
ppr clas <+> hsep (map ppr (classTyVars clas))]
genericMultiParamErr :: Class -> SDoc
genericMultiParamErr clas
= ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+>
ptext (sLit "cannot have generic methods")
badGenericMethodType :: Name -> Kind -> SDoc
badGenericMethodType op op_ty
= hang (ptext (sLit "Generic method type is too complex"))
2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
recSynErr :: [LTyClDecl Name] -> TcRn ()
recSynErr syn_decls
= setSrcSpan (getLoc (head sorted_decls)) $
addErr (sep [ptext (sLit "Cycle in type synonym declarations:"),
nest 2 (vcat (map ppr_decl sorted_decls))])
where
sorted_decls = sortLocated syn_decls
ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
recClsErr :: [Located (TyClDecl Name)] -> TcRn ()
recClsErr cls_decls
= setSrcSpan (getLoc (head sorted_decls)) $
addErr (sep [ptext (sLit "Cycle in class declarations (via superclasses):"),
nest 2 (vcat (map ppr_decl sorted_decls))])
where
sorted_decls = sortLocated cls_decls
ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
sortLocated :: [Located a] -> [Located a]
sortLocated things = sortLe le things
where
le (L l1 _) (L l2 _) = l1 <= l2
badDataConTyCon :: DataCon -> Type -> Type -> SDoc
badDataConTyCon data_con res_ty_tmpl actual_res_ty
= hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+>
ptext (sLit "returns type") <+> quotes (ppr actual_res_ty))
2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl))
badGadtDecl :: Name -> SDoc
badGadtDecl tc_name
= vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XGADTs to allow GADTs")) ]
badExistential :: Located Name -> SDoc
badExistential con_name
= hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+>
ptext (sLit "has existential type variables, or a context"))
2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this"))
badStupidTheta :: Name -> SDoc
badStupidTheta tc_name
= ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)
newtypeConError :: Name -> Int -> SDoc
newtypeConError tycon n
= sep [ptext (sLit "A newtype must have exactly one constructor,"),
nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ]
newtypeExError :: DataCon -> SDoc
newtypeExError con
= sep [ptext (sLit "A newtype constructor cannot have an existential context,"),
nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
newtypeStrictError :: DataCon -> SDoc
newtypeStrictError con
= sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"),
nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
newtypePredError :: DataCon -> SDoc
newtypePredError con
= sep [ptext (sLit "A newtype constructor must have a return type of form T a1 ... an"),
nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does not")]
newtypeFieldErr :: DataCon -> Int -> SDoc
newtypeFieldErr con_name n_flds
= sep [ptext (sLit "The constructor of a newtype must have exactly one field"),
nest 2 $ ptext (sLit "but") <+> quotes (ppr con_name) <+> ptext (sLit "has") <+> speakN n_flds]
badSigTyDecl :: Name -> SDoc
badSigTyDecl tc_name
= vcat [ ptext (sLit "Illegal kind signature") <+>
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
badFamInstDecl :: Outputable a => a -> SDoc
badFamInstDecl tc_name
= vcat [ ptext (sLit "Illegal family instance for") <+>
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
tooManyParmsErr :: Located Name -> SDoc
tooManyParmsErr tc_name
= ptext (sLit "Family instance has too many parameters:") <+>
quotes (ppr tc_name)
tooFewParmsErr :: Arity -> SDoc
tooFewParmsErr arity
= ptext (sLit "Family instance has too few parameters; expected") <+>
ppr arity
wrongNumberOfParmsErr :: Arity -> SDoc
wrongNumberOfParmsErr exp_arity
= ptext (sLit "Number of parameters must match family declaration; expected")
<+> ppr exp_arity
badBootFamInstDeclErr :: SDoc
badBootFamInstDeclErr
= ptext (sLit "Illegal family instance in hs-boot file")
notFamily :: TyCon -> SDoc
notFamily tycon
= vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
, nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
wrongKindOfFamily :: TyCon -> SDoc
wrongKindOfFamily family
= ptext (sLit "Wrong category of family instance; declaration was for a")
<+> kindOfFamily
where
kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
| isAlgTyCon family = ptext (sLit "data type")
| otherwise = pprPanic "wrongKindOfFamily" (ppr family)
emptyConDeclsErr :: Name -> SDoc
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")]
\end{code}