module TcTyClsDecls (
tcTyAndClassDecls, tcAddImplicits,
kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
tcFamTyPats, tcTyFamInstEqn, famTyConShape,
tcAddTyFamInstCtxt, tcAddDataFamInstCtxt,
wrongKindOfFamily, dataConCtxt, badDataConTyCon
) where
#include "HsVersions.h"
import HsSyn
import HscTypes
import BuildTyCl
import TcRnMonad
import TcEnv
import TcValidity
import TcHsSyn
import TcSimplify( growThetaTyVars )
import TcBinds( tcRecSelBinds )
import TcTyDecls
import TcClassDcl
import TcHsType
import TcMType
import TcType
import TysWiredIn( unitTy )
import FamInst
import FamInstEnv( isDominatedBy, mkCoAxBranch, mkBranchedCoAxiom )
import Coercion( pprCoAxBranch, ltRole )
import Type
import TypeRep
import Kind
import Class
import CoAxiom
import TyCon
import DataCon
import Id
import MkCore ( rEC_SEL_ERROR_ID )
import IdInfo
import Var
import VarEnv
import VarSet
import Module
import Name
import NameSet
import NameEnv
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
tcTyAndClassDecls :: ModDetails
-> [TyClGroup Name]
-> TcM TcGblEnv
tcTyAndClassDecls boot_details tyclds_s
= checkNoErrs $
fold_env tyclds_s
where
fold_env :: [TyClGroup Name] -> TcM TcGblEnv
fold_env [] = getGblEnv
fold_env (tyclds:tyclds_s)
= do { tcg_env <- tcTyClGroup boot_details tyclds
; setGblEnv tcg_env $ fold_env tyclds_s }
tcTyClGroup :: ModDetails -> TyClGroup Name -> TcM TcGblEnv
tcTyClGroup boot_details tyclds
= do {
names_w_poly_kinds <- kcTyClGroup tyclds
; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds)
; let role_annots = extractRoleAnnots tyclds
decls = group_tyclds tyclds
; tyclss <- fixM $ \ rec_tyclss -> do
{ is_boot <- tcIsHsBootOrSig
; let rec_flags = calcRecFlags boot_details is_boot
role_annots rec_tyclss
; tcExtendRecEnv (zipRecTyClss names_w_poly_kinds rec_tyclss) $
tcExtendKindEnv names_w_poly_kinds $
concatMapM (tcTyClDecl rec_flags) decls }
; tcExtendGlobalEnv tyclss $ do
{ traceTc "Starting validity check" (ppr tyclss)
; checkNoErrs $
mapM_ (recoverM (return ()) . checkValidTyCl) tyclss
; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
; tcExtendGlobalValEnv (mkDefaultMethodIds tyclss) $
tcAddImplicits tyclss } }
tcAddImplicits :: [TyThing] -> TcM TcGblEnv
tcAddImplicits tyclss
= tcExtendGlobalEnvImplicit implicit_things $
tcRecSelBinds rec_sel_binds
where
implicit_things = concatMap implicitTyThings tyclss
rec_sel_binds = mkRecSelBinds tyclss
zipRecTyClss :: [(Name, Kind)]
-> [TyThing]
-> [(Name,TyThing)]
zipRecTyClss kind_pairs rec_things
= [ (name, ATyCon (get name)) | (name, _kind) <- kind_pairs ]
where
rec_type_env :: TypeEnv
rec_type_env = mkTypeEnv rec_things
get name = case lookupTypeEnv rec_type_env name of
Just (ATyCon tc) -> tc
other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)
kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)]
kcTyClGroup (TyClGroup { group_tyclds = decls })
= do { mod <- getModule
; traceTc "kcTyClGroup" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
; let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls
; initial_kinds <- getInitialKinds non_syn_decls
; traceTc "kcTyClGroup: initial kinds" (ppr initial_kinds)
; lcl_env <- tcExtendKindEnv2 initial_kinds $
kcSynDecls (calcSynCycles syn_decls)
; setLclEnv lcl_env $
mapM_ kcLTyClDecl non_syn_decls
; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls
; traceTc "kcTyClGroup result" (ppr res)
; return res }
where
generalise :: TcTypeEnv -> Name -> TcM (Name, Kind)
generalise kind_env name
= do { let kc_kind = case lookupNameEnv kind_env name of
Just (AThing k) -> k
_ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env)
; kvs <- kindGeneralize (tyVarsOfType kc_kind)
; kc_kind' <- zonkTcKind kc_kind
; traceTc "Generalise kind" (vcat [ ppr name, ppr kc_kind, ppr kvs, ppr kc_kind' ])
; return (name, mkForAllTys kvs kc_kind') }
generaliseTCD :: TcTypeEnv -> LTyClDecl Name -> TcM [(Name, Kind)]
generaliseTCD kind_env (L _ decl)
| ClassDecl { tcdLName = (L _ name), tcdATs = ats } <- decl
= do { first <- generalise kind_env name
; rest <- mapM ((generaliseFamDecl kind_env) . unLoc) ats
; return (first : rest) }
| FamDecl { tcdFam = fam } <- decl
= do { res <- generaliseFamDecl kind_env fam
; return [res] }
| otherwise
= do { res <- generalise kind_env (tcdName decl)
; return [res] }
generaliseFamDecl :: TcTypeEnv -> FamilyDecl Name -> TcM (Name, Kind)
generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name })
= generalise kind_env name
mk_thing_env :: [LTyClDecl Name] -> [(Name, TcTyThing)]
mk_thing_env [] = []
mk_thing_env (decl : decls)
| L _ (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) <- decl
= (nm, APromotionErr ClassPE) :
(map (, APromotionErr TyConPE) $ map (unLoc . fdLName . unLoc) ats) ++
(mk_thing_env decls)
| otherwise
= (tcdName (unLoc decl), APromotionErr TyConPE) :
(mk_thing_env decls)
getInitialKinds :: [LTyClDecl Name] -> TcM [(Name, TcTyThing)]
getInitialKinds decls
= tcExtendKindEnv2 (mk_thing_env decls) $
do { pairss <- mapM (addLocM getInitialKind) decls
; return (concat pairss) }
getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)]
getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })
= do { (cl_kind, inner_prs) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $
do { inner_prs <- getFamDeclInitialKinds ats
; return (constraintKind, inner_prs) }
; let main_pr = (name, AThing cl_kind)
; return (main_pr : inner_prs) }
getInitialKind decl@(DataDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
, dd_cons = cons' } })
= let cons = cons'
in
do { (decl_kind, _) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $
do { res_k <- case m_sig of
Just ksig -> tcLHsKind ksig
Nothing -> return liftedTypeKind
; return (res_k, ()) }
; let main_pr = (name, AThing decl_kind)
inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
| L _ con' <- cons, con <- con_names con' ]
; return (main_pr : inner_prs) }
getInitialKind (FamDecl { tcdFam = decl })
= getFamDeclInitialKind decl
getInitialKind decl@(SynDecl {})
= pprPanic "getInitialKind" (ppr decl)
getFamDeclInitialKinds :: [LFamilyDecl Name] -> TcM [(Name, TcTyThing)]
getFamDeclInitialKinds decls
= tcExtendKindEnv2 [ (n, APromotionErr TyConPE)
| L _ (FamilyDecl { fdLName = L _ n }) <- decls] $
concatMapM (addLocM getFamDeclInitialKind) decls
getFamDeclInitialKind :: FamilyDecl Name
-> TcM [(Name, TcTyThing)]
getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name
, fdTyVars = ktvs
, fdKindSig = ksig })
= do { (fam_kind, _) <-
kcHsTyVarBndrs (famDeclHasCusk decl) ktvs $
do { res_k <- case ksig of
Just k -> tcLHsKind k
Nothing
| famDeclHasCusk decl -> return liftedTypeKind
| otherwise -> newMetaKindVar
; return (res_k, ()) }
; return [ (name, AThing fam_kind) ] }
kcSynDecls :: [SCC (LTyClDecl Name)]
-> TcM TcLclEnv
kcSynDecls [] = getLclEnv
kcSynDecls (group : groups)
= do { (n,k) <- kcSynDecl1 group
; lcl_env <- tcExtendKindEnv [(n,k)] (kcSynDecls groups)
; return lcl_env }
kcSynDecl1 :: SCC (LTyClDecl Name)
-> TcM (Name,TcKind)
kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl
kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM }
kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind)
kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
, tcdRhs = rhs })
= tcAddDeclCtxt decl $
do { (syn_kind, _) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) hs_tvs $
do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs))
; (_, rhs_kind) <- tcLHsType rhs
; traceTc "kcd2" (ppr name)
; return (rhs_kind, ()) }
; return (name, syn_kind) }
kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl)
kcLTyClDecl :: LTyClDecl Name -> TcM ()
kcLTyClDecl (L loc decl)
= setSrcSpan loc $ tcAddDeclCtxt decl $ kcTyClDecl decl
kcTyClDecl :: TyClDecl Name -> TcM ()
kcTyClDecl (DataDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdDataDefn = defn })
| HsDataDefn { dd_cons = cons, dd_kindSig = Just _ } <- defn
= mapM_ (wrapLocM kcConDecl) cons
| HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn
= kcTyClTyVars name hs_tvs $
do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kcConDecl) cons }
kcTyClDecl decl@(SynDecl {}) = pprPanic "kcTyClDecl" (ppr decl)
kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
, tcdCtxt = ctxt, tcdSigs = sigs })
= kcTyClTyVars name hs_tvs $
do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kc_sig) sigs }
where
kc_sig (TypeSig _ op_ty _) = discardResult (tcHsLiftedType op_ty)
kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty)
kc_sig _ = return ()
kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name
, fdTyVars = hs_tvs
, fdInfo = ClosedTypeFamily eqns }))
= do { tc_kind <- kcLookupKind fam_tc_name
; let fam_tc_shape = ( fam_tc_name, length (hsQTvBndrs hs_tvs), tc_kind)
; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns }
kcTyClDecl (FamDecl {}) = return ()
kcConDecl :: ConDecl Name -> TcM ()
kcConDecl (ConDecl { con_names = names, con_qvars = ex_tvs
, con_cxt = ex_ctxt, con_details = details
, con_res = res })
= addErrCtxt (dataConCtxtName names) $
do { _ <- kcHsTyVarBndrs False ex_tvs $
do { _ <- tcHsContext ex_ctxt
; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
; _ <- tcConRes res
; return (panic "kcConDecl", ()) }
; return () }
tcTyClDecl :: RecTyInfo -> LTyClDecl Name -> TcM [TyThing]
tcTyClDecl rec_info (L loc decl)
= setSrcSpan loc $ tcAddDeclCtxt decl $
traceTc "tcTyAndCl-x" (ppr decl) >>
tcTyClDecl1 NoParentTyCon rec_info decl
tcTyClDecl1 :: TyConParent -> RecTyInfo -> TyClDecl Name -> TcM [TyThing]
tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd })
= tcFamDecl1 parent fd
tcTyClDecl1 _parent rec_info
(SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs })
= ASSERT( isNoParent _parent )
tcTyClTyVars tc_name tvs $ \ tvs' kind ->
tcTySynRhs rec_info tc_name tvs' kind rhs
tcTyClDecl1 _parent rec_info
(DataDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdDataDefn = defn })
= ASSERT( isNoParent _parent )
tcTyClTyVars tc_name tvs $ \ tvs' kind ->
tcDataDefn rec_info tc_name tvs' kind defn
tcTyClDecl1 _parent rec_info
(ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs
, tcdCtxt = ctxt, tcdMeths = meths
, tcdFDs = fundeps, tcdSigs = sigs
, tcdATs = ats, tcdATDefs = at_defs })
= ASSERT( isNoParent _parent )
do { (clas, tvs', gen_dm_env) <- fixM $ \ ~(clas,_,_) ->
tcTyClTyVars class_name tvs $ \ tvs' kind ->
do { MASSERT( isConstraintKind kind )
; let tycon_name = tyConName (classTyCon clas)
tc_isrec = rti_is_rec rec_info tycon_name
roles = rti_roles rec_info tycon_name
; ctxt' <- tcHsContext ctxt
; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt'
; fds' <- mapM (addLocM tc_fundep) fundeps
; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs
; mindef <- tcClassMinimalDef class_name sigs sig_stuff
; clas <- buildClass
class_name tvs' roles ctxt' fds' at_stuff
sig_stuff mindef tc_isrec
; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds')
; return (clas, tvs', gen_dm_env) }
; let { gen_dm_ids = [ AnId (mkExportedLocalId VanillaId gen_dm_name gen_dm_ty)
| (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
, let gen_dm_tau = expectJust "tcTyClDecl1" $
lookupNameEnv gen_dm_env (idName sel_id)
, let gen_dm_ty = mkSigmaTy tvs'
[mkClassPred clas (mkTyVarTys tvs')]
gen_dm_tau
]
; class_ats = map ATyCon (classATs clas) }
; return (ATyCon (classTyCon clas) : gen_dm_ids ++ class_ats ) }
where
tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tc_fd_tyvar tvs1 ;
; tvs2' <- mapM tc_fd_tyvar tvs2 ;
; return (tvs1', tvs2') }
tc_fd_tyvar name
= do { tv <- tcLookupTyVar name
; ty <- zonkTyVarOcc emptyZonkEnv tv
; case getTyVar_maybe ty of
Just tv' -> return tv'
Nothing -> pprPanic "tc_fd_tyvar" (ppr name $$ ppr tv $$ ppr ty) }
tcFamDecl1 :: TyConParent -> FamilyDecl Name -> TcM [TyThing]
tcFamDecl1 parent
(FamilyDecl {fdInfo = OpenTypeFamily, fdLName = L _ tc_name, fdTyVars = tvs})
= tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
{ traceTc "open type family:" (ppr tc_name)
; checkFamFlag tc_name
; tycon <- buildFamilyTyCon tc_name tvs' OpenSynFamilyTyCon kind parent
; return [ATyCon tycon] }
tcFamDecl1 parent
(FamilyDecl { fdInfo = ClosedTypeFamily eqns
, fdLName = lname@(L _ tc_name), fdTyVars = tvs })
= do { traceTc "closed type family:" (ppr tc_name)
; (tvs', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind ->
return (tvs', kind)
; checkFamFlag tc_name
; tc_kind <- kcLookupKind tc_name
; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind)
; branches <- mapM (tcTyFamInstEqn fam_tc_shape) eqns
; fam_tc <- tcLookupLocatedTyCon lname
; loc <- getSrcSpanM
; co_ax_name <- newFamInstAxiomName loc tc_name []
; let co_ax = mkBranchedCoAxiom co_ax_name fam_tc branches
; let syn_rhs = if null eqns
then AbstractClosedSynFamilyTyCon
else ClosedSynFamilyTyCon co_ax
; tycon <- buildFamilyTyCon tc_name tvs' syn_rhs kind parent
; let result = if null eqns
then [ATyCon tycon]
else [ATyCon tycon, ACoAxiom co_ax]
; return result }
tcFamDecl1 parent
(FamilyDecl {fdInfo = DataFamily, fdLName = L _ tc_name, fdTyVars = tvs})
= tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
{ traceTc "data family:" (ppr tc_name)
; checkFamFlag tc_name
; extra_tvs <- tcDataKindSig kind
; let final_tvs = tvs' ++ extra_tvs
roles = map (const Nominal) final_tvs
tycon = buildAlgTyCon tc_name final_tvs roles Nothing []
DataFamilyTyCon Recursive
False
True
parent
; return [ATyCon tycon] }
tcTySynRhs :: RecTyInfo
-> Name
-> [TyVar] -> Kind
-> LHsType Name -> TcM [TyThing]
tcTySynRhs rec_info tc_name tvs kind hs_ty
= do { env <- getLclEnv
; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
; rhs_ty <- tcCheckLHsType hs_ty kind
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; let roles = rti_roles rec_info tc_name
; tycon <- buildSynonymTyCon tc_name tvs roles rhs_ty kind
; return [ATyCon tycon] }
tcDataDefn :: RecTyInfo -> Name
-> [TyVar] -> Kind
-> HsDataDefn Name -> TcM [TyThing]
tcDataDefn rec_info tc_name tvs kind
(HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = ctxt, dd_kindSig = mb_ksig
, dd_cons = cons' })
= let cons = cons'
in do { extra_tvs <- tcDataKindSig kind
; let final_tvs = tvs ++ extra_tvs
roles = rti_roles rec_info tc_name
; stupid_tc_theta <- tcHsContext ctxt
; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv stupid_tc_theta
; kind_signatures <- xoptM Opt_KindSignatures
; is_boot <- tcIsHsBootOrSig
; case mb_ksig of
Nothing -> return ()
Just hs_k -> do { checkTc (kind_signatures) (badSigTyDecl tc_name)
; tc_kind <- tcLHsKind hs_k
; checkKind kind tc_kind
; return () }
; gadt_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons
; tycon <- fixM $ \ tycon -> do
{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
; data_cons <- tcConDecls new_or_data tycon (final_tvs, res_ty) cons
; tc_rhs <-
if null cons && is_boot
then return totallyAbstractTyConRhs
else case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
; return (buildAlgTyCon tc_name final_tvs roles (fmap unLoc cType)
stupid_theta tc_rhs
(rti_is_rec rec_info tc_name)
(rti_promotable rec_info)
gadt_syntax NoParentTyCon) }
; return [ATyCon tycon] }
tcClassATs :: Name
-> TyConParent
-> [LFamilyDecl Name]
-> [LTyFamDefltEqn Name]
-> TcM [ClassATItem]
tcClassATs class_name parent ats at_defs
= do {
sequence_ [ failWithTc (badATErr class_name n)
| n <- map at_def_tycon at_defs
, not (n `elemNameSet` at_names) ]
; mapM tc_at ats }
where
at_def_tycon :: LTyFamDefltEqn Name -> Name
at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn)
at_fam_name :: LFamilyDecl Name -> Name
at_fam_name (L _ decl) = unLoc (fdLName decl)
at_names = mkNameSet (map at_fam_name ats)
at_defs_map :: NameEnv [LTyFamDefltEqn Name]
at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv
(at_def_tycon at_def) [at_def])
emptyNameEnv at_defs
tc_at at = do { [ATyCon fam_tc] <- addLocM (tcFamDecl1 parent) at
; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)
`orElse` []
; atd <- tcDefaultAssocDecl fam_tc at_defs
; return (ATI fam_tc atd) }
tcDefaultAssocDecl :: TyCon
-> [LTyFamDefltEqn Name]
-> TcM (Maybe Type)
tcDefaultAssocDecl _ []
= return Nothing
tcDefaultAssocDecl _ (d1:_:_)
= failWithTc (ptext (sLit "More than one default declaration for")
<+> ppr (tfe_tycon (unLoc d1)))
tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name
, tfe_pats = hs_tvs
, tfe_rhs = rhs })]
= setSrcSpan loc $
tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $
tcTyClTyVars tc_name hs_tvs $ \ tvs rhs_kind ->
do { traceTc "tcDefaultAssocDecl" (ppr tc_name)
; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
; let (fam_name, fam_pat_arity, _) = famTyConShape fam_tc
; ASSERT( fam_name == tc_name )
checkTc (length (hsQTvBndrs hs_tvs) == fam_pat_arity)
(wrongNumberOfParmsErr fam_pat_arity)
; rhs_ty <- tcCheckLHsType rhs rhs_kind
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; let fam_tc_tvs = tyConTyVars fam_tc
subst = zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs)
; return ( ASSERT( equalLength fam_tc_tvs tvs )
Just (substTy subst rhs_ty) ) }
kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM ()
kcTyFamInstEqn fam_tc_shape
(L loc (TyFamEqn { tfe_pats = pats, tfe_rhs = hs_ty }))
= setSrcSpan loc $
discardResult $
tc_fam_ty_pats fam_tc_shape pats (discardResult . (tcCheckLHsType hs_ty))
tcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM CoAxBranch
tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_)
(L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
, tfe_pats = pats
, tfe_rhs = hs_ty }))
= setSrcSpan loc $
tcFamTyPats fam_tc_shape pats (discardResult . (tcCheckLHsType hs_ty)) $
\tvs' pats' res_kind ->
do { checkTc (fam_tc_name == eqn_tc_name)
(wrongTyFamName fam_tc_name eqn_tc_name)
; rhs_ty <- tcCheckLHsType hs_ty res_kind
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> ppr tvs')
; return (mkCoAxBranch tvs' pats' rhs_ty loc) }
kcDataDefn :: HsDataDefn Name -> TcKind -> TcM ()
kcDataDefn (HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k
= do { _ <- tcHsContext ctxt
; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons
; kcResultKind mb_kind res_k }
kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM ()
kcResultKind Nothing res_k
= checkKind res_k liftedTypeKind
kcResultKind (Just k) res_k
= do { k' <- tcLHsKind k
; checkKind k' res_k }
type FamTyConShape = (Name, Arity, Kind)
famTyConShape :: TyCon -> FamTyConShape
famTyConShape fam_tc
= ( tyConName fam_tc
, length (filterOut isKindVar (tyConTyVars fam_tc))
, tyConKind fam_tc )
tc_fam_ty_pats :: FamTyConShape
-> HsWithBndrs Name [LHsType Name]
-> (TcKind -> TcM ())
-> TcM ([Kind], [Type], Kind)
tc_fam_ty_pats (name, arity, kind)
(HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars })
kind_checker
= do { let (fam_kvs, fam_body) = splitForAllTys kind
; checkTc (length arg_pats == arity) $
wrongNumberOfParmsErr arity
; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs
; loc <- getSrcSpanM
; let (arg_kinds, res_kind)
= splitKindFunTysN (length arg_pats) $
substKiWith fam_kvs fam_arg_kinds fam_body
hs_tvs = HsQTvs { hsq_kvs = kvars
, hsq_tvs = userHsTyVarBndrs loc tvars }
; typats <- tcHsTyVarBndrs hs_tvs $ \ _ ->
do { kind_checker res_kind
; tcHsArgTys (quotes (ppr name)) arg_pats arg_kinds }
; return (fam_arg_kinds, typats, res_kind) }
tcFamTyPats :: FamTyConShape
-> HsWithBndrs Name [LHsType Name]
-> (TcKind -> TcM ())
-> ([TKVar]
-> [TcType]
-> Kind -> TcM a)
-> TcM a
tcFamTyPats fam_shape@(name,_,_) pats kind_checker thing_inside
= do { (fam_arg_kinds, typats, res_kind)
<- tc_fam_ty_pats fam_shape pats kind_checker
; let all_args = fam_arg_kinds ++ typats
; qtkvs <- quantifyTyVars emptyVarSet (tyVarsOfTypes all_args)
; (ze, qtkvs') <- zonkTyBndrsX emptyZonkEnv qtkvs
; all_args' <- zonkTcTypeToTypes ze all_args
; res_kind' <- zonkTcTypeToType ze res_kind
; traceTc "tcFamTyPats" (ppr name)
; tcExtendTyVarEnv qtkvs' $
thing_inside qtkvs' all_args' res_kind' }
dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM Bool
dataDeclChecks tc_name new_or_data stupid_theta cons
= do {
gadtSyntax_ok <- xoptM Opt_GADTSyntax
; let gadt_syntax = consUseGadtSyntax cons
; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name)
; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)
; checkTc (new_or_data == DataType || isSingleton cons)
(newtypeConError tc_name (length cons))
; empty_data_decls <- xoptM Opt_EmptyDataDecls
; is_boot <- tcIsHsBootOrSig
; checkTc (not (null cons) || empty_data_decls || is_boot)
(emptyConDeclsErr tc_name)
; return gadt_syntax }
consUseGadtSyntax :: [LConDecl a] -> Bool
consUseGadtSyntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = True
consUseGadtSyntax _ = False
tcConDecls :: NewOrData -> TyCon -> ([TyVar], Type)
-> [LConDecl Name] -> TcM [DataCon]
tcConDecls new_or_data rep_tycon (tmpl_tvs, res_tmpl) cons
= concatMapM (addLocM $ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl)
cons
tcConDecl :: NewOrData
-> TyCon
-> [TyVar] -> Type
-> ConDecl Name
-> TcM [DataCon]
tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl
(ConDecl { con_names = names
, con_qvars = hs_tvs, con_cxt = hs_ctxt
, con_details = hs_details, con_res = hs_res_ty })
= addErrCtxt (dataConCtxtName names) $
do { traceTc "tcConDecl 1" (ppr names)
; (ctxt, arg_tys, res_ty, field_lbls, stricts)
<- tcHsTyVarBndrs hs_tvs $ \ _ ->
do { ctxt <- tcHsContext hs_ctxt
; details <- tcConArgs new_or_data hs_details
; res_ty <- tcConRes hs_res_ty
; let (field_lbls, btys) = details
(arg_tys, stricts) = unzip btys
; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
}
; tkvs <- case res_ty of
ResTyH98 -> quantifyTyVars (mkVarSet tmpl_tvs) (tyVarsOfTypes (ctxt++arg_tys))
ResTyGADT res_ty -> quantifyTyVars emptyVarSet (tyVarsOfTypes (res_ty:ctxt++arg_tys))
; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs
; arg_tys <- zonkTcTypeToTypes ze arg_tys
; ctxt <- zonkTcTypeToTypes ze ctxt
; res_ty <- case res_ty of
ResTyH98 -> return ResTyH98
ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty
; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty
; fam_envs <- tcGetFamInstEnvs
; let
buildOneDataCon (L _ name) = do
{ is_infix <- tcConIsInfix name hs_details res_ty
; buildDataCon fam_envs name is_infix
stricts field_lbls
univ_tvs ex_tvs eq_preds ctxt arg_tys
res_ty' rep_tycon
}
; mapM buildOneDataCon names
}
tcConIsInfix :: Name
-> HsConDetails (LHsType Name) [LConDeclField Name]
-> ResType Type
-> TcM Bool
tcConIsInfix _ details ResTyH98
= case details of
InfixCon {} -> return True
_ -> return False
tcConIsInfix con details (ResTyGADT _)
= case details of
InfixCon {} -> return True
RecCon {} -> return False
PrefixCon arg_tys
| isSymOcc (getOccName con)
, [_ty1,_ty2] <- arg_tys
-> do { fix_env <- getFixityEnv
; return (con `elemNameEnv` fix_env) }
| otherwise -> return False
tcConArgs :: NewOrData -> HsConDeclDetails Name
-> TcM ([Name], [(TcType, HsBang)])
tcConArgs new_or_data (PrefixCon btys)
= do { btys' <- mapM (tcConArg new_or_data) btys
; return ([], btys') }
tcConArgs new_or_data (InfixCon bty1 bty2)
= do { bty1' <- tcConArg new_or_data bty1
; bty2' <- tcConArg new_or_data bty2
; return ([], [bty1', bty2']) }
tcConArgs new_or_data (RecCon fields)
= do { btys' <- mapM (tcConArg new_or_data) btys
; return (field_names, btys') }
where
combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) fields
explode (ns,ty) = zip (map unLoc ns) (repeat ty)
exploded = concatMap explode combined
(field_names,btys) = unzip exploded
tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsBang)
tcConArg new_or_data bty
= do { traceTc "tcConArg 1" (ppr bty)
; arg_ty <- tcHsConArgType new_or_data bty
; traceTc "tcConArg 2" (ppr bty)
; return (arg_ty, getBangStrictness bty) }
tcConRes :: ResType (LHsType Name) -> TcM (ResType Type)
tcConRes ResTyH98 = return ResTyH98
tcConRes (ResTyGADT res_ty) = do { res_ty' <- tcHsLiftedType res_ty
; return (ResTyGADT res_ty') }
rejigConRes :: [TyVar] -> Type
-> [TyVar]
-> ResType Type
-> ([TyVar],
[TyVar],
[(TyVar,Type)],
Type)
rejigConRes tmpl_tvs res_ty dc_tvs ResTyH98
= (tmpl_tvs, dc_tvs, [], res_ty)
rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT res_ty)
= (univ_tvs, ex_tvs, eq_spec, res_ty)
where
Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty
(univ_tvs, eq_spec) = foldr choose ([], []) 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 -> (new_tmpl:univs, (new_tmpl,ty):eqs)
where
new_tmpl = updateTyVarKind (substTy subst) tmpl
| otherwise = pprPanic "tcResultType" (ppr res_ty)
ex_tvs = dc_tvs `minusList` univ_tvs
checkClassCycleErrs :: Class -> TcM ()
checkClassCycleErrs cls = mapM_ recClsErr (calcClassCycles cls)
checkValidTyCl :: TyThing -> TcM ()
checkValidTyCl thing
= setSrcSpan (getSrcSpan thing) $
addTyThingCtxt thing $
case thing of
ATyCon tc -> checkValidTyCon tc
AnId _ -> return ()
ACoAxiom _ -> return ()
_ -> pprTrace "checkValidTyCl" (ppr thing) $ return ()
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon tc
| Just cl <- tyConClass_maybe tc
= checkValidClass cl
| Just syn_rhs <- synTyConRhs_maybe tc
= checkValidType syn_ctxt syn_rhs
| Just fam_flav <- famTyConFlav_maybe tc
= case fam_flav of
{ ClosedSynFamilyTyCon ax -> checkValidClosedCoAxiom ax
; AbstractClosedSynFamilyTyCon ->
do { hsBoot <- tcIsHsBootOrSig
; checkTc hsBoot $
ptext (sLit "You may omit the equations in a closed type family") $$
ptext (sLit "only in a .hs-boot file") }
; OpenSynFamilyTyCon -> return ()
; BuiltInSynFamTyCon _ -> return () }
| otherwise
= do {
traceTc "cvtc1" (ppr tc)
; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
; traceTc "cvtc2" (ppr tc)
; dflags <- getDynFlags
; existential_ok <- xoptM Opt_ExistentialQuantification
; gadt_ok <- xoptM Opt_GADTs
; let ex_ok = existential_ok || gadt_ok
; mapM_ (checkValidDataCon dflags ex_ok 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 []"
checkValidClosedCoAxiom :: CoAxiom Branched -> TcM ()
checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc })
= tcAddClosedTypeFamilyDeclCtxt tc $
do { brListFoldlM_ check_accessibility [] branches
; void $ brListMapM (checkValidTyFamInst Nothing tc) branches }
where
check_accessibility :: [CoAxBranch]
-> CoAxBranch
-> TcM [CoAxBranch]
check_accessibility prev_branches cur_branch
= do { when (cur_branch `isDominatedBy` prev_branches) $
addWarnAt (coAxBranchSpan cur_branch) $
inaccessibleCoAxBranch tc cur_branch
; return (cur_branch : prev_branches) }
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 :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
checkValidDataCon dflags existential_ok tc con
= setSrcSpan (srcLocSpan (getSrcLoc con)) $
addErrCtxt (dataConCtxt con) $
do {
let tc_tvs = tyConTyVars tc
res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
orig_res_ty = dataConOrigResTy con
; traceTc "checkValidDataCon" (vcat
[ ppr con, ppr tc, ppr tc_tvs
, ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl)
, ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)])
; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
res_ty_tmpl
orig_res_ty))
(badDataConTyCon con res_ty_tmpl orig_res_ty)
; checkValidMonoType orig_res_ty
; checkValidType ctxt (dataConUserType con)
; when (isNewTyCon tc) (checkNewDataCon con)
; mapM_ check_bang (zip3 (dataConStrictMarks con) (dataConRepBangs con) [1..])
; checkTc (existential_ok || isVanillaDataCon con)
(badExistential con)
; checkTc (not (any (isKindVar . fst) (dataConEqSpec con)))
(badGadtKindCon con)
; traceTc "Done validity of data con" (ppr con <+> ppr (dataConRepType con))
}
where
ctxt = ConArgCtxt (dataConName con)
check_bang (HsUserBang (Just want_unpack) has_bang, rep_bang, n)
| want_unpack, not has_bang
= addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'")))
| want_unpack
, case rep_bang of { HsUnpack {} -> False; _ -> True }
, not (gopt Opt_OmitInterfacePragmas dflags)
= addWarnTc (bad_bang n (ptext (sLit "Ignoring unusable UNPACK pragma")))
check_bang _
= return ()
bad_bang n herald
= hang herald 2 (ptext (sLit "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))
; check_con (null eq_spec) $
ptext (sLit "A newtype constructor must have a return type of form T a1 ... an")
; check_con (null theta) $
ptext (sLit "A newtype constructor cannot have a context in its type")
; check_con (null ex_tvs) $
ptext (sLit "A newtype constructor cannot have existential type variables")
; checkTc (not (any isBanged (dataConStrictMarks con)))
(newtypeStrictError con)
}
where
(_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
check_con what msg
= checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con))
checkValidClass :: Class -> TcM ()
checkValidClass cls
= do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods
; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses
; nullary_type_classes <- xoptM Opt_NullaryTypeClasses
; fundep_classes <- xoptM Opt_FunctionalDependencies
; checkTc (multi_param_type_classes || arity == 1 ||
(nullary_type_classes && arity == 0))
(classArityErr arity cls)
; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
; checkValidTheta (ClassSCCtxt (className cls)) theta
; checkClassCycleErrs cls
; whenNoErrs $
mapM_ (check_op constrained_class_methods) op_stuff
; mapM_ check_at_defs at_stuff }
where
(tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls
arity = count isTypeVar tyvars
check_op constrained_class_methods (sel_id, dm)
= addErrCtxt (classOpCtxt sel_id tau) $ do
{ checkValidTheta ctxt (tail theta)
; traceTc "class op type" (ppr op_ty <+> ppr tau)
; checkValidType ctxt tau
; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
; checkTc (arity == 0 || tyVarsOfType tau `intersectsVarSet` grown_tyvars)
(noClassTyVarErr cls (ptext (sLit "class method") <+> quotes (ppr sel_id)))
; case dm of
GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
; checkValidType (FunSigCtxt op_name) (idType dm_id) }
_ -> return ()
}
where
ctxt = FunSigCtxt op_name
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)
check_at_defs (ATI fam_tc _)
= do { traceTc "check-at" (ppr fam_tc $$ ppr (tyConTyVars fam_tc) $$ ppr tyvars)
; checkTc (any (`elem` tyvars) (tyConTyVars fam_tc))
(noClassTyVarErr cls (ptext (sLit "associated type") <+> quotes (ppr fam_tc))) }
checkFamFlag :: Name -> TcM ()
checkFamFlag tc_name
= do { idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys err_msg }
where
err_msg = hang (ptext (sLit "Illegal family declaration for") <+> quotes (ppr tc_name))
2 (ptext (sLit "Use TypeFamilies to allow indexed type families"))
checkValidRoleAnnots :: RoleAnnots -> TyThing -> TcM ()
checkValidRoleAnnots role_annots thing
= case thing of
{ ATyCon tc
| isTypeSynonymTyCon tc -> check_no_roles
| isFamilyTyCon tc -> check_no_roles
| isAlgTyCon tc -> check_roles
where
name = tyConName tc
tyvars = tyConTyVars tc
roles = tyConRoles tc
(kind_vars, type_vars) = span isKindVar tyvars
type_roles = dropList kind_vars roles
role_annot_decl_maybe = lookupRoleAnnots role_annots name
check_roles
= whenIsJust role_annot_decl_maybe $
\decl@(L loc (RoleAnnotDecl _ the_role_annots)) ->
addRoleAnnotCtxt name $
setSrcSpan loc $ do
{ role_annots_ok <- xoptM Opt_RoleAnnotations
; checkTc role_annots_ok $ needXRoleAnnotations tc
; checkTc (type_vars `equalLength` the_role_annots)
(wrongNumberOfRoles type_vars decl)
; _ <- zipWith3M checkRoleAnnot type_vars the_role_annots type_roles
; incoherent_roles_ok <- xoptM Opt_IncoherentInstances
; checkTc ( incoherent_roles_ok
|| (not $ isClassTyCon tc)
|| (all (== Nominal) type_roles))
incoherentRoles
; lint <- goptM Opt_DoCoreLinting
; when lint $ checkValidRoles tc }
check_no_roles
= whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl
; _ -> return () }
checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()
checkRoleAnnot _ (L _ Nothing) _ = return ()
checkRoleAnnot tv (L _ (Just r1)) r2
= when (r1 /= r2) $
addErrTc $ badRoleAnnot (tyVarName tv) r1 r2
checkValidRoles :: TyCon -> TcM ()
checkValidRoles tc
| isAlgTyCon tc
= mapM_ check_dc_roles (tyConDataCons tc)
| Just rhs <- synTyConRhs_maybe tc
= check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs
| otherwise
= return ()
where
check_dc_roles datacon
= do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))
; mapM_ (check_ty_roles role_env Representational) $
eqSpecPreds eq_spec ++ theta ++ arg_tys }
where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig datacon
univ_roles = zipVarEnv univ_tvs (tyConRoles tc)
ex_roles = mkVarEnv (zip ex_tvs (repeat Nominal))
role_env = univ_roles `plusVarEnv` ex_roles
check_ty_roles env role (TyVarTy tv)
= case lookupVarEnv env tv of
Just role' -> unless (role' `ltRole` role || role' == role) $
report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+>
ptext (sLit "cannot have role") <+> ppr role <+>
ptext (sLit "because it was assigned role") <+> ppr role'
Nothing -> report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+>
ptext (sLit "missing in environment")
check_ty_roles env Representational (TyConApp tc tys)
= let roles' = tyConRoles tc in
zipWithM_ (maybe_check_ty_roles env) roles' tys
check_ty_roles env Nominal (TyConApp _ tys)
= mapM_ (check_ty_roles env Nominal) tys
check_ty_roles _ Phantom ty@(TyConApp {})
= pprPanic "check_ty_roles" (ppr ty)
check_ty_roles env role (AppTy ty1 ty2)
= check_ty_roles env role ty1
>> check_ty_roles env Nominal ty2
check_ty_roles env role (FunTy ty1 ty2)
= check_ty_roles env role ty1
>> check_ty_roles env role ty2
check_ty_roles env role (ForAllTy tv ty)
= check_ty_roles (extendVarEnv env tv Nominal) role ty
check_ty_roles _ _ (LitTy {}) = return ()
maybe_check_ty_roles env role ty
= when (role == Nominal || role == Representational) $
check_ty_roles env role ty
report_error doc
= addErrTc $ vcat [ptext (sLit "Internal error in role inference:"),
doc,
ptext (sLit "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug")]
mkDefaultMethodIds :: [TyThing] -> [Id]
mkDefaultMethodIds things
= [ mkExportedLocalId VanillaId dm_name (idType sel_id)
| ATyCon tc <- things
, Just cls <- [tyConClass_maybe tc]
, (sel_id, DefMeth dm_name) <- classOpItems cls ]
mkRecSelBinds :: [TyThing] -> HsValBinds Name
mkRecSelBinds tycons
= ValBindsOut [(NonRecursive, b) | b <- binds] sigs
where
(sigs, binds) = unzip rec_sels
rec_sels = map mkRecSelBind [ (tc,fld)
| ATyCon tc <- tycons
, 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 sel_name
sel_id = mkExportedLocalId rec_details sel_name sel_ty
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 (varSetElemsKvsFirst $
data_tvs `extendVarSetList` field_tvs) $
mkPhiTy (dataConStupidTheta con1) $
mkPhiTy field_theta $
mkFunTy data_ty field_tau
sel_bind = mkTopFunBind Generated sel_lname alts
where
alts | is_naughty = [mkSimpleMatch [] unit_rhs]
| otherwise = 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 = noLoc (HsRecField { hsRecFieldId = sel_lname
, hsRecFieldArg = L loc (VarPat field_var)
, hsRecPun = False })
sel_lname = L loc sel_name
field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
deflt | all dealt_with all_cons = []
| otherwise = [mkSimpleMatch [L loc (WildPat placeHolderType)]
(mkHsApp (L loc (HsVar (getName rEC_SEL_ERROR_ID)))
(L loc (HsLit msg_lit)))]
dealt_with con = con `elem` cons_w_field || dataConCannotMatch inst_tys con
inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec con1)) (dataConUnivTyVars con1)
unit_rhs = mkLHsTupleExpr []
msg_lit = HsStringPrim "" $ unsafeMkByteString $
occNameString (getOccName sel_name)
tyConFields :: TyCon -> [FieldLabel]
tyConFields tc
| isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
| otherwise = []
tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a
tcAddTyFamInstCtxt decl
= tcAddFamInstCtxt (ptext (sLit "type instance")) (tyFamInstDeclName decl)
tcAddDataFamInstCtxt :: DataFamInstDecl Name -> TcM a -> TcM a
tcAddDataFamInstCtxt decl
= tcAddFamInstCtxt (pprDataFamInstFlavour decl <+> ptext (sLit "instance"))
(unLoc (dfid_tycon decl))
tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt flavour tycon thing_inside
= addErrCtxt ctxt thing_inside
where
ctxt = hsep [ptext (sLit "In the") <+> flavour
<+> ptext (sLit "declaration for"),
quotes (ppr tycon)]
tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a
tcAddClosedTypeFamilyDeclCtxt tc
= addErrCtxt ctxt
where
ctxt = ptext (sLit "In the equations for closed type family") <+>
quotes (ppr tc)
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)]
dataConCtxtName :: [Located Name] -> SDoc
dataConCtxtName [con]
= ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)
dataConCtxtName con
= ptext (sLit "In the definition of data constructors") <+> interpp'SP con
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 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]
classArityErr :: Int -> Class -> SDoc
classArityErr n cls
| n == 0 = mkErr "No" "no-parameter"
| otherwise = mkErr "Too many" "multi-parameter"
where
mkErr howMany allowWhat =
vcat [ptext (sLit $ howMany ++ " parameters for class") <+> quotes (ppr cls),
parens (ptext (sLit $ "Use MultiParamTypeClasses to allow "
++ allowWhat ++ " classes"))]
classFunDepsErr :: Class -> SDoc
classFunDepsErr cls
= vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls),
parens (ptext (sLit "Use FunctionalDependencies to allow fundeps"))]
noClassTyVarErr :: Class -> SDoc -> SDoc
noClassTyVarErr clas what
= sep [ptext (sLit "The") <+> what,
ptext (sLit "mentions none of the type or kind variables of the class") <+>
quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]
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 :: [TyCon] -> TcRn ()
recClsErr cycles
= addErr (sep [ptext (sLit "Cycle in class declaration (via superclasses):"),
nest 2 (hsep (intersperse (text "->") (map ppr cycles)))])
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))
badGadtKindCon :: DataCon -> SDoc
badGadtKindCon data_con
= hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con)
<+> ptext (sLit "cannot be GADT-like in its *kind* arguments"))
2 (ppr data_con <+> dcolon <+> ppr (dataConUserType data_con))
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 GADTs to allow GADTs")) ]
badExistential :: DataCon -> SDoc
badExistential con
= hang (ptext (sLit "Data constructor") <+> quotes (ppr con) <+>
ptext (sLit "has existential type variables, a context, or a specialised result type"))
2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con)
, parens $ ptext (sLit "Use ExistentialQuantification or GADTs 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 ]
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")]
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 KindSignatures to allow kind signatures")) ]
emptyConDeclsErr :: Name -> SDoc
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
nest 2 $ ptext (sLit "(EmptyDataDecls permits this)")]
wrongKindOfFamily :: TyCon -> SDoc
wrongKindOfFamily family
= ptext (sLit "Wrong category of family instance; declaration was for a")
<+> kindOfFamily
where
kindOfFamily | isTypeFamilyTyCon family = text "type family"
| isDataFamilyTyCon family = text "data family"
| otherwise = pprPanic "wrongKindOfFamily" (ppr family)
wrongNumberOfParmsErr :: Arity -> SDoc
wrongNumberOfParmsErr max_args
= ptext (sLit "Number of parameters must match family declaration; expected")
<+> ppr max_args
wrongTyFamName :: Name -> Name -> SDoc
wrongTyFamName fam_tc_name eqn_tc_name
= hang (ptext (sLit "Mismatched type name in type family instance."))
2 (vcat [ ptext (sLit "Expected:") <+> ppr fam_tc_name
, ptext (sLit " Actual:") <+> ppr eqn_tc_name ])
inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc
inaccessibleCoAxBranch tc fi
= ptext (sLit "Overlapped type family instance equation:") $$
(pprCoAxBranch tc fi)
badRoleAnnot :: Name -> Role -> Role -> SDoc
badRoleAnnot var annot inferred
= hang (ptext (sLit "Role mismatch on variable") <+> ppr var <> colon)
2 (sep [ ptext (sLit "Annotation says"), ppr annot
, ptext (sLit "but role"), ppr inferred
, ptext (sLit "is required") ])
wrongNumberOfRoles :: [a] -> LRoleAnnotDecl Name -> SDoc
wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots))
= hang (ptext (sLit "Wrong number of roles listed in role annotation;") $$
ptext (sLit "Expected") <+> (ppr $ length tyvars) <> comma <+>
ptext (sLit "got") <+> (ppr $ length annots) <> colon)
2 (ppr d)
illegalRoleAnnotDecl :: LRoleAnnotDecl Name -> TcM ()
illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _))
= setErrCtxt [] $
setSrcSpan loc $
addErrTc (ptext (sLit "Illegal role annotation for") <+> ppr tycon <> char ';' $$
ptext (sLit "they are allowed only for datatypes and classes."))
needXRoleAnnotations :: TyCon -> SDoc
needXRoleAnnotations tc
= ptext (sLit "Illegal role annotation for") <+> ppr tc <> char ';' $$
ptext (sLit "did you intend to use RoleAnnotations?")
incoherentRoles :: SDoc
incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+>
text "for class parameters can lead to incoherence.") $$
(text "Use IncoherentInstances to allow this; bad role found")
addTyThingCtxt :: TyThing -> TcM a -> TcM a
addTyThingCtxt thing
= addErrCtxt ctxt
where
name = getName thing
flav = case thing of
ATyCon tc
| isClassTyCon tc -> ptext (sLit "class")
| isTypeFamilyTyCon tc -> ptext (sLit "type family")
| isDataFamilyTyCon tc -> ptext (sLit "data family")
| isTypeSynonymTyCon tc -> ptext (sLit "type")
| isNewTyCon tc -> ptext (sLit "newtype")
| isDataTyCon tc -> ptext (sLit "data")
_ -> pprTrace "addTyThingCtxt strange" (ppr thing)
Outputable.empty
ctxt = hsep [ ptext (sLit "In the"), flav
, ptext (sLit "declaration for"), quotes (ppr name) ]
addRoleAnnotCtxt :: Name -> TcM a -> TcM a
addRoleAnnotCtxt name
= addErrCtxt $
text "while checking a role annotation for" <+> quotes (ppr name)