module TcTyClsDecls (
tcTyAndClassDecls, tcAddImplicits,
kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
tcFamTyPats, tcTyFamInstEqn, famTyConShape,
tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
wrongKindOfFamily, dataConCtxt
) where
#include "HsVersions.h"
import HsSyn
import HscTypes
import BuildTyCl
import TcRnMonad
import TcEnv
import TcValidity
import TcHsSyn
import TcTyDecls
import TcClassDcl
import TcUnify
import TcHsType
import TcMType
import TysWiredIn ( unitTy )
import TcType
import FamInst
import FamInstEnv
import Coercion
import Type
import TyCoRep
import Kind
import Class
import CoAxiom
import TyCon
import DataCon
import Id
import Var
import VarEnv
import VarSet
import Module
import Name
import NameSet
import NameEnv
import RnEnv
import Outputable
import Maybes
import Unify
import Util
import SrcLoc
import ListSetOps
import Digraph
import DynFlags
import Unique
import BasicTypes
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.List
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid ( mempty )
#endif
tcTyAndClassDecls :: [TyClGroup Name]
-> TcM TcGblEnv
tcTyAndClassDecls 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 tyclds
; setGblEnv tcg_env $ fold_env tyclds_s }
tcTyClGroup :: TyClGroup Name -> TcM TcGblEnv
tcTyClGroup tyclds
= do {
tc_tycons <- kcTyClGroup tyclds
; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
; let role_annots = extractRoleAnnots tyclds
decls = group_tyclds tyclds
; tyclss <- fixM $ \ ~rec_tyclss -> do
{ is_boot <- tcIsHsBootOrSig
; self_boot <- tcSelfBootInfo
; let rec_flags = calcRecFlags self_boot is_boot
role_annots rec_tyclss
; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $
tcExtendKindEnv2 (map mkTcTyConPair tc_tycons) $
mapM (tcTyClDecl rec_flags) decls }
; traceTc "Starting validity check" (ppr tyclss)
; tyclss <- mapM checkValidTyCl tyclss
; traceTc "Done validity check" (ppr tyclss)
; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
; tcExtendTyConEnv tyclss $
tcAddImplicits tyclss }
where
ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma
, ppr (tyConBinders tc) <> comma
, ppr (tyConResKind tc) ])
zipRecTyClss :: [TcTyCon]
-> [TyCon]
-> [(Name,TyThing)]
zipRecTyClss tc_tycons rec_tycons
= [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]
where
rec_tc_env :: NameEnv TyCon
rec_tc_env = foldr add_tc emptyNameEnv rec_tycons
add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc tc env = foldr add_one_tc env (tc : tyConATs tc)
add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_one_tc tc env = extendNameEnv env (tyConName tc) tc
get name = case lookupNameEnv rec_tc_env name of
Just tc -> tc
other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)
kcTyClGroup :: TyClGroup Name -> TcM [TcTyCon]
kcTyClGroup (TyClGroup { group_tyclds = decls })
= do { mod <- getModule
; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls))
; lcl_env <- solveEqualities $
do {
let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls
; initial_kinds <- getInitialKinds non_syn_decls
; traceTc "kcTyClGroup: initial kinds" $
vcat (map pp_initial_kind initial_kinds)
; lcl_env <- tcExtendKindEnv2 initial_kinds $
kcSynDecls (calcSynCycles syn_decls)
; setLclEnv lcl_env $
mapM_ kcLTyClDecl non_syn_decls
; return lcl_env }
; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls
; traceTc "kcTyClGroup result" (vcat (map pp_res res))
; return res }
where
generalise :: TcTypeEnv -> Name -> TcM TcTyCon
generalise kind_env name
= do { let tc = case lookupNameEnv kind_env name of
Just (ATcTyCon tc) -> tc
_ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env)
kc_binders = tyConBinders tc
kc_res_kind = tyConResKind tc
; kvs <- kindGeneralize (mkForAllTys kc_binders kc_res_kind)
; (kc_binders', kc_res_kind') <- zonkTcKindToKind kc_binders kc_res_kind
; traceTc "Generalise kind" $
vcat [ ppr name, ppr kc_binders, ppr kc_res_kind
, ppr kvs, ppr kc_binders', ppr kc_res_kind' ]
; return (mkTcTyCon name
(mkNamedBinders Invisible kvs ++ kc_binders')
kc_res_kind'
(mightBeUnsaturatedTyCon tc)) }
generaliseTCD :: TcTypeEnv
-> LTyClDecl Name -> TcM [TcTyCon]
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 TcTyCon
generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name })
= generalise kind_env name
pp_initial_kind (name, ATcTyCon tc)
= ppr name <+> dcolon <+> ppr (tyConKind tc)
pp_initial_kind pair
= ppr pair
pp_res tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
mkTcTyConPair :: TcTyCon -> (Name, TcTyThing)
mkTcTyConPair tc
= (getName tc, ATcTyCon tc)
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_binders, cl_kind, inner_prs) <-
kcHsTyVarBndrs cusk False True ktvs $
do { inner_prs <- getFamDeclInitialKinds (Just cusk) ats
; return (constraintKind, inner_prs) }
; cl_binders <- mapM zonkTcTyBinder cl_binders
; cl_kind <- zonkTcType cl_kind
; let main_pr = mkTcTyConPair (mkTcTyCon name cl_binders cl_kind True)
; return (main_pr : inner_prs) }
where
cusk = hsDeclHasCusk decl
getInitialKind decl@(DataDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
, dd_cons = cons } })
= do { (decl_binders, decl_kind, _) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) False True ktvs $
do { res_k <- case m_sig of
Just ksig -> tcLHsKind ksig
Nothing -> return liftedTypeKind
; return (res_k, ()) }
; decl_binders <- mapM zonkTcTyBinder decl_binders
; decl_kind <- zonkTcType decl_kind
; let main_pr = mkTcTyConPair (mkTcTyCon name decl_binders decl_kind True)
inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
| L _ con' <- cons, con <- getConNames con' ]
; return (main_pr : inner_prs) }
getInitialKind (FamDecl { tcdFam = decl })
= getFamDeclInitialKind Nothing decl
getInitialKind decl@(SynDecl {})
= pprPanic "getInitialKind" (ppr decl)
getFamDeclInitialKinds :: Maybe Bool
-> [LFamilyDecl Name] -> TcM [(Name, TcTyThing)]
getFamDeclInitialKinds mb_cusk decls
= tcExtendKindEnv2 [ (n, APromotionErr TyConPE)
| L _ (FamilyDecl { fdLName = L _ n }) <- decls] $
concatMapM (addLocM (getFamDeclInitialKind mb_cusk)) decls
getFamDeclInitialKind :: Maybe Bool
-> FamilyDecl Name
-> TcM [(Name, TcTyThing)]
getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name
, fdTyVars = ktvs
, fdResultSig = L _ resultSig
, fdInfo = info })
= do { (fam_binders, fam_kind, _) <-
kcHsTyVarBndrs cusk open True ktvs $
do { res_k <- case resultSig of
KindSig ki -> tcLHsKind ki
TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKind ki
_
| open -> return liftedTypeKind
| otherwise -> newMetaKindVar
; return (res_k, ()) }
; fam_binders <- mapM zonkTcTyBinder fam_binders
; fam_kind <- zonkTcType fam_kind
; return [ mkTcTyConPair (mkTcTyCon name fam_binders fam_kind unsat) ] }
where
cusk = famDeclHasCusk mb_cusk decl
(open, unsat) = case info of
DataFamily -> (True, True)
OpenTypeFamily -> (True, False)
ClosedTypeFamily _ -> (False, False)
kcSynDecls :: [SCC (LTyClDecl Name)]
-> TcM TcLclEnv
kcSynDecls [] = getLclEnv
kcSynDecls (group : groups)
= do { tc <- kcSynDecl1 group
; traceTc "kcSynDecl" (ppr tc <+> dcolon <+> ppr (tyConKind tc))
; tcExtendKindEnv2 [ mkTcTyConPair tc ] $
kcSynDecls groups }
kcSynDecl1 :: SCC (LTyClDecl Name)
-> TcM TcTyCon
kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl
kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM }
kcSynDecl :: TyClDecl Name -> TcM TcTyCon
kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
, tcdRhs = rhs })
= tcAddDeclCtxt decl $
do { (syn_binders, syn_kind, _) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) False True hs_tvs $
do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs))
; (_, rhs_kind) <- tcLHsType rhs
; traceTc "kcd2" (ppr name)
; return (rhs_kind, ()) }
; return (mkTcTyCon name syn_binders syn_kind False) }
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 (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty
kc_sig _ = return ()
kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name
, fdTyVars = hs_tvs
, fdInfo = fd_info }))
= case fd_info of
ClosedTypeFamily (Just eqns) ->
do { (tc_binders, tc_res_kind) <- kcLookupKind fam_tc_name
; let fam_tc_shape = ( fam_tc_name
, length $ hsQTvExplicit hs_tvs
, tc_binders
, tc_res_kind )
; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns }
_ -> return ()
kcConDecl :: ConDecl Name -> TcM ()
kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
, con_cxt = ex_ctxt, con_details = details })
= addErrCtxt (dataConCtxtName [name]) $
do { _ <- kcHsTyVarBndrs False False False ((fromMaybe emptyLHsQTvs ex_tvs)) $
do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
; return (panic "kcConDecl", ()) }
; return () }
kcConDecl (ConDeclGADT { con_names = names
, con_type = ty })
= addErrCtxt (dataConCtxtName names) $
do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty
; return () }
tcTyClDecl :: RecTyInfo -> LTyClDecl Name -> TcM TyCon
tcTyClDecl rec_info (L loc decl)
| Just thing <- wiredInNameTyThing_maybe (tcdName decl)
= case thing of
ATyCon tc -> return tc
_ -> pprPanic "tcTyClDecl" (ppr thing)
| otherwise
= setSrcSpan loc $ tcAddDeclCtxt decl $
do { traceTc "tcTyAndCl-x" (ppr decl)
; tcTyClDecl1 Nothing rec_info decl }
tcTyClDecl1 :: Maybe Class -> RecTyInfo -> TyClDecl Name -> TcM TyCon
tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd })
= tcFamDecl1 parent fd
tcTyClDecl1 _parent rec_info
(SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs })
= ASSERT( isNothing _parent )
tcTyClTyVars tc_name tvs $ \ kvs' tvs' binders res_kind ->
tcTySynRhs rec_info tc_name (kvs' ++ tvs') binders res_kind rhs
tcTyClDecl1 _parent rec_info
(DataDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdDataDefn = defn })
= ASSERT( isNothing _parent )
tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_binders res_kind ->
tcDataDefn rec_info tc_name (kvs' ++ tvs') tycon_binders res_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( isNothing _parent )
do { clas <- fixM $ \ clas ->
tcTyClTyVars class_name tvs $ \ kvs' tvs' binders res_kind ->
do { MASSERT( isConstraintKind res_kind )
; traceTc "tcClassDecl 1" (ppr class_name $$ ppr kvs' $$
ppr tvs' $$ ppr binders)
; let tycon_name = tyConName (classTyCon clas)
tc_isrec = rti_is_rec rec_info tycon_name
roles = rti_roles rec_info tycon_name
; ctxt' <- solveEqualities $ tcHsContext ctxt
; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt'
; fds' <- mapM (addLocM tc_fundep) fundeps
; sig_stuff <- tcClassSigs class_name sigs meths
; at_stuff <- tcClassATs class_name clas ats at_defs
; mindef <- tcClassMinimalDef class_name sigs sig_stuff
; clas <- buildClass
class_name (kvs' ++ tvs') roles ctxt' binders
fds' at_stuff
sig_stuff mindef tc_isrec
; traceTc "tcClassDecl" (ppr fundeps $$ ppr (kvs' ++ tvs') $$
ppr fds')
; return clas }
; return (classTyCon clas) }
where
tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;
; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;
; return (tvs1', tvs2') }
tcFamDecl1 :: Maybe Class -> FamilyDecl Name -> TcM TyCon
tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_name)
, fdTyVars = tvs, fdResultSig = L _ sig
, fdInjectivityAnn = inj })
| DataFamily <- fam_info
= tcTyClTyVars tc_name tvs $ \ kvs' tvs' binders res_kind -> do
{ traceTc "data family:" (ppr tc_name)
; checkFamFlag tc_name
; (extra_tvs, extra_binders, real_res_kind) <- tcDataKindSig res_kind
; tc_rep_name <- newTyConRepName tc_name
; let final_tvs = (kvs' ++ tvs') `chkAppend` extra_tvs
tycon = mkFamilyTyCon tc_name (binders `chkAppend` extra_binders)
real_res_kind final_tvs
(resultVariableName sig)
(DataFamilyTyCon tc_rep_name)
parent NotInjective
; return tycon }
| OpenTypeFamily <- fam_info
= tcTyClTyVars tc_name tvs $ \ kvs' tvs' binders res_kind -> do
{ traceTc "open type family:" (ppr tc_name)
; checkFamFlag tc_name
; let all_tvs = kvs' ++ tvs'
; inj' <- tcInjectivity all_tvs inj
; let tycon = mkFamilyTyCon tc_name binders res_kind all_tvs
(resultVariableName sig) OpenSynFamilyTyCon
parent inj'
; return tycon }
| ClosedTypeFamily mb_eqns <- fam_info
=
do { traceTc "Closed type family:" (ppr tc_name)
; (tvs', inj', binders, res_kind)
<- tcTyClTyVars tc_name tvs
$ \ kvs' tvs' binders res_kind ->
do { let all_tvs = kvs' ++ tvs'
; inj' <- tcInjectivity all_tvs inj
; return (all_tvs, inj', binders, res_kind) }
; checkFamFlag tc_name
; case mb_eqns of
Nothing ->
return $ mkFamilyTyCon tc_name binders res_kind tvs'
(resultVariableName sig)
AbstractClosedSynFamilyTyCon parent
inj'
Just eqns -> do {
; let fam_tc_shape = (tc_name, length $ hsQTvExplicit tvs, binders, res_kind)
; branches <- mapM (tcTyFamInstEqn fam_tc_shape Nothing) eqns
; co_ax_name <- newFamInstAxiomName tc_lname []
; let mb_co_ax
| null eqns = Nothing
| otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)
fam_tc = mkFamilyTyCon tc_name binders res_kind tvs' (resultVariableName sig)
(ClosedSynFamilyTyCon mb_co_ax) parent inj'
; return fam_tc } }
| otherwise = panic "tcFamInst1"
tcInjectivity :: [TyVar] -> Maybe (LInjectivityAnn Name)
-> TcM Injectivity
tcInjectivity _ Nothing
= return NotInjective
tcInjectivity tvs (Just (L loc (InjectivityAnn _ lInjNames)))
= setSrcSpan loc $
do { dflags <- getDynFlags
; checkTc (xopt LangExt.TypeFamilyDependencies dflags)
(text "Illegal injectivity annotation" $$
text "Use TypeFamilyDependencies to allow this")
; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames
; let inj_ktvs = filterVarSet isTyVar $
closeOverKinds (mkVarSet inj_tvs)
; let inj_bools = map (`elemVarSet` inj_ktvs) tvs
; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs
, ppr inj_ktvs, ppr inj_bools ])
; return $ Injective inj_bools }
tcTySynRhs :: RecTyInfo
-> Name
-> [TyVar] -> [TyBinder] -> Kind
-> LHsType Name -> TcM TyCon
tcTySynRhs rec_info tc_name tvs binders res_kind hs_ty
= do { env <- getLclEnv
; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; let roles = rti_roles rec_info tc_name
tycon = mkSynonymTyCon tc_name binders res_kind tvs roles rhs_ty
; return tycon }
tcDataDefn :: RecTyInfo -> Name
-> [TyVar] -> [TyBinder] -> Kind
-> HsDataDefn Name -> TcM TyCon
tcDataDefn rec_info
tc_name tvs tycon_binders res_kind
(HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = ctxt, dd_kindSig = mb_ksig
, dd_cons = cons })
= do { (extra_tvs, extra_bndrs, real_res_kind) <- tcDataKindSig res_kind
; let final_bndrs = tycon_binders `chkAppend` extra_bndrs
final_tvs = tvs `chkAppend` extra_tvs
roles = rti_roles rec_info tc_name
; stupid_tc_theta <- solveEqualities $ tcHsContext ctxt
; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv
stupid_tc_theta
; kind_signatures <- xoptM LangExt.KindSignatures
; is_boot <- tcIsHsBootOrSig
; when (isJust mb_ksig) $
checkTc (kind_signatures) (badSigTyDecl tc_name)
; 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, final_bndrs, res_ty) cons
; tc_rhs <- mk_tc_rhs is_boot tycon data_cons
; tc_rep_nm <- newTyConRepName tc_name
; return (mkAlgTyCon tc_name (tycon_binders `chkAppend` extra_bndrs)
real_res_kind final_tvs roles
(fmap unLoc cType)
stupid_theta tc_rhs
(VanillaAlgTyCon tc_rep_nm)
(rti_is_rec rec_info tc_name)
gadt_syntax) }
; return tycon }
where
mk_tc_rhs is_boot tycon data_cons
| null data_cons, is_boot
= return totallyAbstractTyConRhs
| otherwise
= case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
tcClassATs :: Name
-> Class
-> [LFamilyDecl Name]
-> [LTyFamDefltEqn Name]
-> TcM [ClassATItem]
tcClassATs class_name cls 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 { fam_tc <- addLocM (tcFamDecl1 (Just cls)) 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, SrcSpan))
tcDefaultAssocDecl _ []
= return Nothing
tcDefaultAssocDecl _ (d1:_:_)
= failWithTc (text "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 })]
| HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs
=
setSrcSpan loc $
tcAddFamInstCtxt (text "default type instance") tc_name $
do { traceTc "tcDefaultAssocDecl" (ppr tc_name)
; let shape@(fam_tc_name, fam_arity, _, _) = famTyConShape fam_tc
; ASSERT( fam_tc_name == tc_name )
checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
; checkTc (length exp_vars == fam_arity)
(wrongNumberOfParmsErr fam_arity)
; let pats = HsIB { hsib_vars = imp_vars ++ map hsLTyVarName exp_vars
, hsib_body = map hsLTyVarBndrToType exp_vars }
; (pats', rhs_ty)
<- tcFamTyPats shape Nothing pats
(discardResult . tcCheckLHsType rhs) $ \_ pats' rhs_kind ->
do { rhs_ty <- solveEqualities $
tcCheckLHsType rhs rhs_kind
; return (pats', rhs_ty) }
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; case tcMatchTys pats' (mkTyVarTys (tyConTyVars fam_tc)) of
Just subst -> return ( Just (substTyUnchecked subst rhs_ty, loc) )
Nothing -> failWithTc (defaultAssocKindErr fam_tc)
}
kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM ()
kcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_)
(L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
, tfe_pats = pats
, tfe_rhs = hs_ty }))
= setSrcSpan loc $
do { checkTc (fam_tc_name == eqn_tc_name)
(wrongTyFamName fam_tc_name eqn_tc_name)
; discardResult $
tc_fam_ty_pats fam_tc_shape Nothing
pats (discardResult . (tcCheckLHsType hs_ty)) }
tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInfo -> LTyFamInstEqn Name -> TcM CoAxBranch
tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo
(L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
, tfe_pats = pats
, tfe_rhs = hs_ty }))
= ASSERT( fam_tc_name == eqn_tc_name )
setSrcSpan loc $
tcFamTyPats fam_tc_shape mb_clsinfo pats (discardResult . (tcCheckLHsType hs_ty)) $
\tvs' pats' res_kind ->
do { rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTvBndrs tvs')
; return (mkCoAxBranch tvs' [] pats' rhs_ty
(map (const Nominal) tvs')
loc) }
kcDataDefn :: Name
-> HsTyPats Name
-> HsDataDefn Name
-> TcKind
-> TcM ()
kcDataDefn fam_name (HsIB { hsib_body = pats })
(HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k
= do { _ <- tcHsContext ctxt
; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons
; discardResult $
case mb_kind of
Nothing -> unifyKind (Just hs_ty_pats) res_k liftedTypeKind
Just k -> do { k' <- tcLHsKind k
; unifyKind (Just hs_ty_pats) res_k k' } }
where
hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar (noLoc fam_name)) pats
type FamTyConShape = (Name, Arity, [TyBinder], Kind)
famTyConShape :: TyCon -> FamTyConShape
famTyConShape fam_tc
= ( tyConName fam_tc
, length $ filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
, tyConBinders fam_tc
, tyConResKind fam_tc )
tc_fam_ty_pats :: FamTyConShape
-> Maybe ClsInfo
-> HsTyPats Name
-> (TcKind -> TcM ())
-> TcM ([Type], Kind)
tc_fam_ty_pats (name, _, binders, res_kind) mb_clsinfo
(HsIB { hsib_body = arg_pats, hsib_vars = tv_names })
kind_checker
= do {
(_, (insted_res_kind, typats)) <- tcImplicitTKBndrs tv_names $
do { (insting_subst, _leftover_binders, args, leftovers, n)
<- tcInferArgs name binders (snd <$> mb_clsinfo) arg_pats
; case leftovers of
hs_ty:_ -> addErrTc $ too_many_args hs_ty n
_ -> return ()
; let insted_res_kind = substTyUnchecked insting_subst res_kind
; kind_checker insted_res_kind
; return ((insted_res_kind, args), emptyVarSet) }
; return (typats, insted_res_kind) }
where
too_many_args hs_ty n
= hang (text "Too many parameters to" <+> ppr name <> colon)
2 (vcat [ ppr hs_ty <+> text "is unexpected;"
, text (if n == 1 then "expected" else "expected only") <+>
speakNOf (n1) (text "parameter") ])
tcFamTyPats :: FamTyConShape
-> Maybe ClsInfo
-> HsTyPats Name
-> (TcKind -> TcM ())
-> ( [TyVar]
-> [TcType]
-> Kind -> TcM a)
-> TcM a
tcFamTyPats fam_shape@(name,_,_,_) mb_clsinfo pats kind_checker thing_inside
= do { (typats, res_kind)
<- solveEqualities $
tc_fam_ty_pats fam_shape mb_clsinfo pats kind_checker
; vars <- zonkTcTypesAndSplitDepVars typats
; qtkvs <- quantifyZonkedTyVars emptyVarSet vars
; MASSERT( isEmptyVarSet $ coVarsOfTypes typats )
; (ze, qtkvs') <- zonkTyBndrsX emptyZonkEnv qtkvs
; typats' <- zonkTcTypeToTypes ze typats
; res_kind' <- zonkTcTypeToType ze res_kind
; traceTc "tcFamTyPats" (ppr name $$ ppr typats)
; tcExtendTyVarEnv qtkvs' $
thing_inside qtkvs' typats' res_kind' }
dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM Bool
dataDeclChecks tc_name new_or_data stupid_theta cons
= do {
gadtSyntax_ok <- xoptM LangExt.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 LangExt.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 _ (ConDeclGADT { }) : _) = True
consUseGadtSyntax _ = False
tcConDecls :: NewOrData -> TyCon -> ([TyVar], [TyBinder], Type)
-> [LConDecl Name] -> TcM [DataCon]
tcConDecls new_or_data rep_tycon (tmpl_tvs, tmpl_bndrs, res_tmpl)
= concatMapM $ addLocM $
tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl
tcConDecl :: NewOrData
-> TyCon
-> [TyVar] -> [TyBinder] -> Type
-> ConDecl Name
-> TcM [DataCon]
tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl
(ConDeclH98 { con_name = name
, con_qvars = hs_qvars, con_cxt = hs_ctxt
, con_details = hs_details })
= addErrCtxt (dataConCtxtName [name]) $
do { traceTc "tcConDecl 1" (ppr name)
; let (hs_kvs, hs_tvs) = case hs_qvars of
Nothing -> ([], [])
Just (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })
-> (kvs, tvs)
; (imp_tvs, (exp_tvs, ctxt, arg_tys, field_lbls, stricts))
<- solveEqualities $
tcImplicitTKBndrs hs_kvs $
tcExplicitTKBndrs hs_tvs $ \ exp_tvs ->
do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
; btys <- tcConArgs new_or_data hs_details
; field_lbls <- lookupConstructorFields (unLoc name)
; let (arg_tys, stricts) = unzip btys
bound_vars = allBoundVariabless ctxt `unionVarSet`
allBoundVariabless arg_tys
; return ((exp_tvs, ctxt, arg_tys, field_lbls, stricts), bound_vars)
}
; let all_user_tvs = imp_tvs ++ exp_tvs
; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys all_user_tvs $
mkFunTys ctxt $
mkFunTys arg_tys $
unitTy)
; kvs <- quantifyZonkedTyVars (mkVarSet tmpl_tvs) vars
; (ze, qkvs) <- zonkTyBndrsX emptyZonkEnv kvs
; (ze, user_qtvs) <- zonkTyBndrsX ze all_user_tvs
; arg_tys <- zonkTcTypeToTypes ze arg_tys
; ctxt <- zonkTcTypeToTypes ze ctxt
; fam_envs <- tcGetFamInstEnvs
; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
; let
ex_tvs = qkvs ++ user_qtvs
ex_binders = mkNamedBinders Invisible qkvs ++
mkNamedBinders Specified user_qtvs
buildOneDataCon (L _ name) = do
{ is_infix <- tcConIsInfixH98 name hs_details
; rep_nm <- newTyConRepName name
; buildDataCon fam_envs name is_infix rep_nm
stricts Nothing field_lbls
tmpl_tvs tmpl_bndrs
ex_tvs ex_binders
[] ctxt arg_tys
res_tmpl rep_tycon
}
; traceTc "tcConDecl 2" (ppr name)
; mapM buildOneDataCon [name]
}
tcConDecl _new_or_data rep_tycon tmpl_tvs _tmpl_bndrs res_tmpl
(ConDeclGADT { con_names = names, con_type = ty })
= addErrCtxt (dataConCtxtName names) $
do { traceTc "tcConDecl 1" (ppr names)
; (user_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)
<- tcGadtSigType (ppr names) (unLoc $ head names) ty
; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys user_tvs $
mkFunTys ctxt $
mkFunTys arg_tys $
res_ty)
; tkvs <- quantifyZonkedTyVars emptyVarSet vars
; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv (tkvs ++ user_tvs)
; arg_tys <- zonkTcTypeToTypes ze arg_tys
; ctxt <- zonkTcTypeToTypes ze ctxt
; res_ty <- zonkTcTypeToType ze res_ty
; let (univ_tvs, ex_tvs, eq_preds, res_ty', arg_subst)
= rejigConRes tmpl_tvs res_tmpl qtkvs res_ty
univ_bndrs = mkNamedBinders Specified univ_tvs
ex_bndrs = mkNamedBinders Specified ex_tvs
; fam_envs <- tcGetFamInstEnvs
; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
; let
buildOneDataCon (L _ name) = do
{ is_infix <- tcConIsInfixGADT name hs_details
; rep_nm <- newTyConRepName name
; buildDataCon fam_envs name is_infix
rep_nm
stricts Nothing field_lbls
univ_tvs univ_bndrs ex_tvs ex_bndrs eq_preds
(substTys arg_subst ctxt)
(substTys arg_subst arg_tys)
(substTy arg_subst res_ty')
rep_tycon
}
; traceTc "tcConDecl 2" (ppr names)
; mapM buildOneDataCon names
}
tcGadtSigType :: SDoc -> Name -> LHsSigType Name
-> TcM ( [TcTyVar], [PredType],[HsSrcBang], [FieldLabel], [Type], Type
, HsConDetails (LHsType Name)
(Located [LConDeclField Name]) )
tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
= do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty
; (hs_details, res_ty) <- updateGadtResult failWithTc doc hs_details' res_ty'
; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts))
<- solveEqualities $
tcImplicitTKBndrs vars $
tcExplicitTKBndrs gtvs $ \ exp_tvs ->
do { ctxt <- tcHsContext cxt
; btys <- tcConArgs DataType hs_details
; ty' <- tcHsLiftedType res_ty
; field_lbls <- lookupConstructorFields name
; let (arg_tys, stricts) = unzip btys
bound_vars = allBoundVariabless ctxt `unionVarSet`
allBoundVariabless arg_tys
; return ((exp_tvs, ctxt, arg_tys, ty', field_lbls, stricts), bound_vars)
}
; return (imp_tvs ++ exp_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty, hs_details)
}
tcConIsInfixH98 :: Name
-> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-> TcM Bool
tcConIsInfixH98 _ details
= case details of
InfixCon {} -> return True
_ -> return False
tcConIsInfixGADT :: Name
-> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-> TcM Bool
tcConIsInfixGADT con details
= 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 [(TcType, HsSrcBang)]
tcConArgs new_or_data (PrefixCon btys)
= mapM (tcConArg new_or_data) 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)
= mapM (tcConArg new_or_data) btys
where
combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields)
explode (ns,ty) = zip ns (repeat ty)
exploded = concatMap explode combined
(_,btys) = unzip exploded
tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsSrcBang)
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) }
rejigConRes :: [TyVar] -> Type
-> [TyVar]
-> Type
-> ([TyVar],
[TyVar],
[EqSpec],
Type,
TCvSubst)
rejigConRes tmpl_tvs res_tmpl dc_tvs res_ty
| Just subst <- ASSERT( isLiftedTypeKind (typeKind res_ty) )
ASSERT( isLiftedTypeKind (typeKind res_tmpl) )
tcMatchTy res_tmpl res_ty
= let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst
raw_ex_tvs = dc_tvs `minusList` univ_tvs
(arg_subst, substed_ex_tvs)
= mapAccumL substTyVarBndr kind_subst raw_ex_tvs
substed_eqs = map (substEqSpec arg_subst) raw_eqs
in
(univ_tvs, substed_ex_tvs, substed_eqs, res_ty, arg_subst)
| otherwise
= (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, [], res_ty, emptyTCvSubst)
where
mkGADTVars :: [TyVar]
-> [TyVar]
-> TCvSubst
-> ( [TyVar]
, [EqSpec]
, TCvSubst )
mkGADTVars tmpl_tvs dc_tvs subst
= choose [] [] empty_subst empty_subst tmpl_tvs
where
in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)
`unionInScope` getTCvInScope subst
empty_subst = mkEmptyTCvSubst in_scope
choose :: [TyVar]
-> [EqSpec]
-> TCvSubst
-> TCvSubst
-> [TyVar]
-> ( [TyVar]
, [EqSpec]
, TCvSubst )
choose univs eqs _t_sub r_sub []
= (reverse univs, reverse eqs, r_sub)
choose univs eqs t_sub r_sub (t_tv:t_tvs)
| Just r_ty <- lookupTyVar subst t_tv
= case getTyVar_maybe r_ty of
Just r_tv
| not (r_tv `elem` univs)
, tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv))
->
choose (r_tv:univs) eqs
(extendTvSubst t_sub t_tv r_ty')
(extendTvSubst r_sub r_tv r_ty')
t_tvs
where
r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv)
r_ty' = mkTyVarTy r_tv1
_ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs)
t_sub r_sub t_tvs
where t_tv' = updateTyVarKind (substTy t_sub) t_tv
| otherwise
= pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)
choose_tv_name :: TyVar -> TyVar -> Name
choose_tv_name r_tv t_tv
| isSystemName r_tv_name
= setNameUnique t_tv_name (getUnique r_tv_name)
| otherwise
= r_tv_name
where
r_tv_name = getName r_tv
t_tv_name = getName t_tv
checkValidTyCl :: TyCon -> TcM TyCon
checkValidTyCl tc
= setSrcSpan (getSrcSpan tc) $
addTyConCtxt tc $
recoverM (do { traceTc "Aborted validity for tycon" (ppr tc)
; return (makeTyConAbstract tc) })
(do { traceTc "Starting validity for tycon" (ppr tc)
; checkValidTyCon tc
; traceTc "Done validity for tycon" (ppr tc)
; return tc })
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon tc
| isPrimTyCon tc
= return ()
| otherwise
= do { checkValidTyConTyVars tc
; if | 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 (Just ax)
-> tcAddClosedTypeFamilyDeclCtxt tc $
checkValidCoAxiom ax
; ClosedSynFamilyTyCon Nothing -> return ()
; AbstractClosedSynFamilyTyCon ->
do { hsBoot <- tcIsHsBootOrSig
; checkTc hsBoot $
text "You may define an abstract closed type family" $$
text "only in a .hs-boot file" }
; DataFamilyTyCon {} -> return ()
; OpenSynFamilyTyCon -> return ()
; BuiltInSynFamTyCon _ -> return () }
| otherwise -> do
{
traceTc "cvtc1" (ppr tc)
; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
; traceTc "cvtc2" (ppr tc)
; dflags <- getDynFlags
; existential_ok <- xoptM LangExt.ExistentialQuantification
; gadt_ok <- xoptM LangExt.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,_) = flLabel f1 `compare` flLabel f2
get_fields con = dataConFieldLabels con `zip` repeat con
check_fields ((label, con1) : other_fields)
= recoverM (return ()) $ mapM_ checkOne other_fields
where
(_, _, _, res1) = dataConSig con1
fty1 = dataConFieldType con1 lbl
lbl = flLabel label
checkOne (_, con2)
= do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2
; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }
where
(_, _, _, res2) = dataConSig con2
fty2 = dataConFieldType con2 lbl
check_fields [] = panic "checkValidTyCon/check_fields []"
checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
-> Type -> Type -> Type -> Type -> TcM ()
checkFieldCompat fld con1 con2 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 res1 res2
mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
checkValidTyConTyVars :: TyCon -> TcM ()
checkValidTyConTyVars tc
= do {
let stripped_tvs | duplicate_vars
= reverse $ nub $ reverse tvs
| otherwise
= tvs
vis_tvs = filterOutInvisibleTyVars tc tvs
extra | not (vis_tvs `equalLength` stripped_tvs)
= text "NB: Implicitly declared kind variables are put first."
| otherwise
= empty
; checkValidTelescope (pprTvBndrs vis_tvs) stripped_tvs extra
`and_if_that_doesn't_error`
when duplicate_vars (
addErr (vcat [ text "Invalid declaration for" <+>
quotes (ppr tc) <> semi <+> text "you must explicitly"
, text "declare which variables are dependent on which others."
, hang (text "Inferred variable kinds:")
2 (vcat (map pp_tv stripped_tvs)) ])) }
where
tvs = tyConTyVars tc
duplicate_vars = sizeVarSet (mkVarSet tvs) < length tvs
pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
and_if_that_doesn't_error :: TcM () -> TcM () -> TcM ()
try_first `and_if_that_doesn't_error` try_second
= recoverM (return ()) $
do { checkNoErrs try_first
; try_second }
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 res_ty_tmpl
orig_res_ty))
(badDataConTyCon con res_ty_tmpl orig_res_ty)
; traceTc "checkValidDataCon 2" (ppr (dataConUserType con))
; checkValidMonoType orig_res_ty
; checkValidType ctxt (dataConUserType con)
; when (isNewTyCon tc) (checkNewDataCon con)
; checkTc (existential_ok || isVanillaDataCon con)
(badExistential con)
; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]
; traceTc "Done validity of data con" (ppr con <+> ppr (dataConRepType con))
}
where
ctxt = ConArgCtxt (dataConName con)
check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()
check_bang (HsSrcBang _ _ SrcLazy) _ n
| not (xopt LangExt.StrictData dflags)
= addErrTc
(bad_bang n (text "Lazy annotation (~) without StrictData"))
check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n
| isSrcUnpacked want_unpack, not is_strict
= addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))
| isSrcUnpacked want_unpack
, case rep_bang of { HsUnpack {} -> False; _ -> True }
, not (gopt Opt_OmitInterfacePragmas dflags)
= addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))
where
is_strict = case strict_mark of
NoSrcStrict -> xopt LangExt.StrictData dflags
bang -> isSrcStrict bang
check_bang _ _ _
= return ()
bad_bang n herald
= hang herald 2 (text "on the" <+> speakNth n
<+> text "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) $
text "A newtype constructor must have a return type of form T a1 ... an"
; check_con (null theta) $
text "A newtype constructor cannot have a context in its type"
; check_con (null ex_tvs) $
text "A newtype constructor cannot have existential type variables"
; checkTc (all ok_bang (dataConSrcBangs 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))
ok_bang (HsSrcBang _ _ SrcStrict) = False
ok_bang (HsSrcBang _ _ SrcLazy) = False
ok_bang _ = True
checkValidClass :: Class -> TcM ()
checkValidClass cls
= do { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods
; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses
; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses
; fundep_classes <- xoptM LangExt.FunctionalDependencies
; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses
; checkTc (multi_param_type_classes || cls_arity == 1 ||
(nullary_type_classes && cls_arity == 0))
(classArityErr cls_arity cls)
; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
; checkValidTheta (ClassSCCtxt (className cls)) theta
; unless undecidable_super_classes $
case checkClassCycles cls of
Just err -> setSrcSpan (getSrcSpan cls) $
addErrTc err
Nothing -> return ()
; whenNoErrs $
mapM_ (check_op constrained_class_methods) op_stuff
; mapM_ check_at at_stuff }
where
(tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls
cls_arity = length $ filterOutInvisibleTyVars (classTyCon cls) tyvars
cls_tv_set = mkVarSet tyvars
check_op constrained_class_methods (sel_id, dm)
= setSrcSpan (getSrcSpan sel_id) $
addErrCtxt (classOpCtxt sel_id op_ty) $ do
{ traceTc "class op type" (ppr op_ty)
; checkValidType ctxt op_ty
; unless constrained_class_methods $
mapM_ check_constraint (tail (theta1 ++ theta2))
; check_dm ctxt dm
}
where
ctxt = FunSigCtxt op_name True
op_name = idName sel_id
op_ty = idType sel_id
(_,theta1,tau1) = tcSplitSigmaTy op_ty
(_,theta2,_) = tcSplitSigmaTy tau1
check_constraint :: TcPredType -> TcM ()
check_constraint pred
= when (not (isEmptyVarSet pred_tvs) &&
pred_tvs `subVarSet` cls_tv_set)
(addErrTc (badMethPred sel_id pred))
where
pred_tvs = tyCoVarsOfType pred
check_at (ATI fam_tc m_dflt_rhs)
= do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)
(noClassTyVarErr cls fam_tc)
; whenIsJust m_dflt_rhs $ \ (rhs, loc) ->
checkValidTyFamEqn (Just (cls, mini_env)) fam_tc
fam_tvs [] (mkTyVarTys fam_tvs) rhs loc }
where
fam_tvs = tyConTyVars fam_tc
mini_env = zipVarEnv tyvars (mkTyVarTys tyvars)
check_dm :: UserTypeCtxt -> DefMethInfo -> TcM ()
check_dm ctxt (Just (_, GenericDM ty))
= checkValidType ctxt (mkSpecForAllTys tyvars ty)
check_dm _ _ = return ()
checkFamFlag :: Name -> TcM ()
checkFamFlag tc_name
= do { idx_tys <- xoptM LangExt.TypeFamilies
; checkTc idx_tys err_msg }
where
err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))
2 (text "Use TypeFamilies to allow indexed type families")
checkValidRoleAnnots :: RoleAnnots -> TyCon -> TcM ()
checkValidRoleAnnots role_annots tc
| isTypeSynonymTyCon tc = check_no_roles
| isFamilyTyCon tc = check_no_roles
| isAlgTyCon tc = check_roles
| otherwise = return ()
where
name = tyConName tc
tyvars = tyConTyVars tc
roles = tyConRoles tc
(vis_roles, vis_vars) = unzip $ snd $
partitionInvisibles tc (mkTyVarTy . snd) $
zip roles tyvars
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 LangExt.RoleAnnotations
; checkTc role_annots_ok $ needXRoleAnnotations tc
; checkTc (vis_vars `equalLength` the_role_annots)
(wrongNumberOfRoles vis_vars decl)
; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles
; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances
; checkTc ( incoherent_roles_ok
|| (not $ isClassTyCon tc)
|| (all (== Nominal) vis_roles))
incoherentRoles
; lint <- goptM Opt_DoCoreLinting
; when lint $ checkValidRoles tc }
check_no_roles
= whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl
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 (map (, Nominal) ex_tvs)
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 $ text "type variable" <+> quotes (ppr tv) <+>
text "cannot have role" <+> ppr role <+>
text "because it was assigned role" <+> ppr role'
Nothing -> report_error $ text "type variable" <+> quotes (ppr tv) <+>
text "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 (ForAllTy (Anon ty1) ty2)
= check_ty_roles env role ty1
>> check_ty_roles env role ty2
check_ty_roles env role (ForAllTy (Named tv _) ty)
= check_ty_roles env Nominal (tyVarKind tv)
>> check_ty_roles (extendVarEnv env tv Nominal) role ty
check_ty_roles _ _ (LitTy {}) = return ()
check_ty_roles env role (CastTy t _)
= check_ty_roles env role t
check_ty_roles _ role (CoercionTy co)
= unless (role == Phantom) $
report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role
maybe_check_ty_roles env role ty
= when (role == Nominal || role == Representational) $
check_ty_roles env role ty
report_error doc
= addErrTc $ vcat [text "Internal error in role inference:",
doc,
text "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug"]
tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a
tcAddTyFamInstCtxt decl
= tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)
tcMkDataFamInstCtxt :: DataFamInstDecl Name -> SDoc
tcMkDataFamInstCtxt decl
= tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")
(unLoc (dfid_tycon decl))
tcAddDataFamInstCtxt :: DataFamInstDecl Name -> TcM a -> TcM a
tcAddDataFamInstCtxt decl
= addErrCtxt (tcMkDataFamInstCtxt decl)
tcMkFamInstCtxt :: SDoc -> Name -> SDoc
tcMkFamInstCtxt flavour tycon
= hsep [ text "In the" <+> flavour <+> text "declaration for"
, quotes (ppr tycon) ]
tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt flavour tycon thing_inside
= addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside
tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a
tcAddClosedTypeFamilyDeclCtxt tc
= addErrCtxt ctxt
where
ctxt = text "In the equations for closed type family" <+>
quotes (ppr tc)
resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
resultTypeMisMatch field_name con1 con2
= vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,
text "have a common field" <+> quotes (ppr field_name) <> comma],
nest 2 $ text "but have different result types"]
fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
fieldTypeMisMatch field_name con1 con2
= sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,
text "give different types for field", quotes (ppr field_name)]
dataConCtxtName :: [Located Name] -> SDoc
dataConCtxtName [con]
= text "In the definition of data constructor" <+> quotes (ppr con)
dataConCtxtName con
= text "In the definition of data constructors" <+> interpp'SP con
dataConCtxt :: Outputable a => a -> SDoc
dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con)
classOpCtxt :: Var -> Type -> SDoc
classOpCtxt sel_id tau = sep [text "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 [text (howMany ++ " parameters for class") <+> quotes (ppr cls),
parens (text ("Use MultiParamTypeClasses to allow "
++ allowWhat ++ " classes"))]
classFunDepsErr :: Class -> SDoc
classFunDepsErr cls
= vcat [text "Fundeps in class" <+> quotes (ppr cls),
parens (text "Use FunctionalDependencies to allow fundeps")]
badMethPred :: Id -> TcPredType -> SDoc
badMethPred sel_id pred
= vcat [ hang (text "Constraint" <+> quotes (ppr pred)
<+> text "in the type of" <+> quotes (ppr sel_id))
2 (text "constrains only the class type variables")
, text "Use ConstrainedClassMethods to allow it" ]
noClassTyVarErr :: Class -> TyCon -> SDoc
noClassTyVarErr clas fam_tc
= sep [ text "The associated type" <+> quotes (ppr fam_tc)
, text "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 [text "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
badDataConTyCon :: DataCon -> Type -> Type -> SDoc
badDataConTyCon data_con res_ty_tmpl actual_res_ty
= hang (text "Data constructor" <+> quotes (ppr data_con) <+>
text "returns type" <+> quotes (ppr actual_res_ty))
2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))
badGadtDecl :: Name -> SDoc
badGadtDecl tc_name
= vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)
, nest 2 (parens $ text "Use GADTs to allow GADTs") ]
badExistential :: DataCon -> SDoc
badExistential con
= hang (text "Data constructor" <+> quotes (ppr con) <+>
text "has existential type variables, a context, or a specialised result type")
2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con)
, parens $ text "Use ExistentialQuantification or GADTs to allow this" ])
badStupidTheta :: Name -> SDoc
badStupidTheta tc_name
= text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)
newtypeConError :: Name -> Int -> SDoc
newtypeConError tycon n
= sep [text "A newtype must have exactly one constructor,",
nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]
newtypeStrictError :: DataCon -> SDoc
newtypeStrictError con
= sep [text "A newtype constructor cannot have a strictness annotation,",
nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"]
newtypeFieldErr :: DataCon -> Int -> SDoc
newtypeFieldErr con_name n_flds
= sep [text "The constructor of a newtype must have exactly one field",
nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds]
badSigTyDecl :: Name -> SDoc
badSigTyDecl tc_name
= vcat [ text "Illegal kind signature" <+>
quotes (ppr tc_name)
, nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ]
emptyConDeclsErr :: Name -> SDoc
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> text "has no constructors",
nest 2 $ text "(EmptyDataDecls permits this)"]
wrongKindOfFamily :: TyCon -> SDoc
wrongKindOfFamily family
= text "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
= text "Number of parameters must match family declaration; expected"
<+> ppr max_args
defaultAssocKindErr :: TyCon -> SDoc
defaultAssocKindErr fam_tc
= text "Kind mis-match on LHS of default declaration for"
<+> quotes (ppr fam_tc)
wrongTyFamName :: Name -> Name -> SDoc
wrongTyFamName fam_tc_name eqn_tc_name
= hang (text "Mismatched type name in type family instance.")
2 (vcat [ text "Expected:" <+> ppr fam_tc_name
, text " Actual:" <+> ppr eqn_tc_name ])
badRoleAnnot :: Name -> Role -> Role -> SDoc
badRoleAnnot var annot inferred
= hang (text "Role mismatch on variable" <+> ppr var <> colon)
2 (sep [ text "Annotation says", ppr annot
, text "but role", ppr inferred
, text "is required" ])
wrongNumberOfRoles :: [a] -> LRoleAnnotDecl Name -> SDoc
wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots))
= hang (text "Wrong number of roles listed in role annotation;" $$
text "Expected" <+> (ppr $ length tyvars) <> comma <+>
text "got" <+> (ppr $ length annots) <> colon)
2 (ppr d)
illegalRoleAnnotDecl :: LRoleAnnotDecl Name -> TcM ()
illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _))
= setErrCtxt [] $
setSrcSpan loc $
addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$
text "they are allowed only for datatypes and classes.")
needXRoleAnnotations :: TyCon -> SDoc
needXRoleAnnotations tc
= text "Illegal role annotation for" <+> ppr tc <> char ';' $$
text "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")
addTyConCtxt :: TyCon -> TcM a -> TcM a
addTyConCtxt tc
= addErrCtxt ctxt
where
name = getName tc
flav = text (tyConFlavour tc)
ctxt = hsep [ text "In the", flav
, text "declaration for", quotes (ppr name) ]
addRoleAnnotCtxt :: Name -> TcM a -> TcM a
addRoleAnnotCtxt name
= addErrCtxt $
text "while checking a role annotation for" <+> quotes (ppr name)