diff options
Diffstat (limited to 'compiler/iface/TcIface.hs')
| -rw-r--r-- | compiler/iface/TcIface.hs | 346 |
1 files changed, 159 insertions, 187 deletions
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index da94136218..3931b18237 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -27,8 +27,9 @@ import BuildTyCl import TcRnMonad import TcType import Type -import Coercion hiding (substTy) -import TypeRep +import Coercion +import CoAxiom +import TyCoRep -- needs to build types & coercions in a knot import HscTypes import Annotations import InstEnv @@ -43,14 +44,10 @@ import MkId import IdInfo import Class import TyCon -import CoAxiom import ConLike import DataCon import PrelNames import TysWiredIn -import TysPrim ( superKindTyConName ) -import BasicTypes ( strongLoopBreaker, Arity, TupleSort(..) - , Boxity(..), DefMethSpec(..), pprRuleName ) import Literal import qualified Var import VarEnv @@ -69,6 +66,8 @@ import SrcLoc import DynFlags import Util import FastString +import BasicTypes hiding ( SuccessFlag(..) ) +import ListSetOps import Data.List import Control.Monad @@ -316,20 +315,21 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, tc_iface_decl _ _ (IfaceData {ifName = occ_name, ifCType = cType, + ifKind = kind, ifTyVars = tv_bndrs, ifRoles = roles, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, - ifRec = is_rec, ifPromotable = is_prom, - ifParent = mb_parent }) + ifRec = is_rec, ifParent = mb_parent }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name + ; kind' <- tcIfaceType kind ; tycon <- fixM $ \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt ; parent' <- tc_parent tc_name mb_parent - ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons is_prom - ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta - cons is_rec is_prom gadt_syn parent') } + ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons + ; return (mkAlgTyCon tc_name kind' tyvars roles cType stupid_theta + cons parent' is_rec gadt_syn) } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } where @@ -350,10 +350,10 @@ tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs, ifSynKind = kind }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] + ; kind <- tcIfaceType kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tcIfaceType rhs_ty - ; let tycon = buildSynonymTyCon tc_name tyvars roles rhs rhs_kind + ; let tycon = mkSynonymTyCon tc_name kind tyvars roles rhs ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type synonym") <+> ppr n @@ -364,12 +364,11 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, ifResVar = res, ifFamInj = inj }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] + ; kind <- tcIfaceType kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tc_fam_flav tc_name fam_flav ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res - ; let tycon = buildFamilyTyCon tc_name tyvars res_name rhs rhs_kind - parent inj + ; let tycon = mkFamilyTyCon tc_name kind tyvars res_name rhs parent inj ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type synonym") <+> ppr n @@ -390,13 +389,15 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, tc_iface_decl _parent ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, - ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds, + ifTyVars = tv_bndrs, ifRoles = roles, ifKind = kind, + ifFDs = rdr_fds, ifATs = rdr_ats, ifSigs = rdr_sigs, ifMinDef = mindef_occ, ifRec = tc_isrec }) -- ToDo: in hs-boot files we should really treat abstract classes specially, -- as we do abstract tycons - = bindIfaceTyVars tv_bndrs $ \ tyvars -> do + = bindIfaceTvBndrs tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop tc_occ + ; kind' <- tcIfaceType kind ; traceIf (text "tc-iface-class1" <+> ppr tc_occ) ; ctxt <- mapM tc_sc rdr_ctxt ; traceIf (text "tc-iface-class2" <+> ppr tc_occ) @@ -407,7 +408,7 @@ tc_iface_decl _parent ignore_prags ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_at cls) rdr_ats ; traceIf (text "tc-iface-class4" <+> ppr tc_occ) - ; buildClass tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec } + ; buildClass tc_name tyvars roles ctxt kind' fds ats sigs mindef tc_isrec } ; return (ATyCon (classTyCon cls)) } where tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) @@ -486,8 +487,8 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name) ; matcher <- tc_pr if_matcher ; builder <- fmapMaybeM tc_pr if_builder - ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do - { bindIfaceTyVars ex_tvs $ \ex_tvs -> do + ; bindIfaceTvBndrs univ_tvs $ \univ_tvs -> do + { bindIfaceTvBndrs ex_tvs $ \ex_tvs -> do { patsyn <- forkM (mk_doc name) $ do { prov_theta <- tcIfaceCtxt prov_ctxt ; req_theta <- tcIfaceCtxt req_ctxt @@ -508,22 +509,25 @@ tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] tc_ax_branch prev_branches - (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs + (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs + , ifaxbLHS = lhs, ifaxbRHS = rhs , ifaxbRoles = roles, ifaxbIncomps = incomps }) - = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do + = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom - { tc_lhs <- tcIfaceTcArgs lhs -- See Note [Checking IfaceTypes vs IfaceKinds] + bindIfaceIds cv_bndrs $ \ cvs -> do + { tc_lhs <- tcIfaceTcArgs lhs ; tc_rhs <- tcIfaceType rhs ; let br = CoAxBranch { cab_loc = noSrcSpan , cab_tvs = tvs + , cab_cvs = cvs , cab_lhs = tc_lhs , cab_roles = roles , cab_rhs = tc_rhs - , cab_incomps = map (prev_branches !!) incomps } + , cab_incomps = map (prev_branches `getNth`) incomps } ; return (prev_branches ++ [br]) } -tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> Bool -> IfL AlgTyConRhs -tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom +tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs +tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon dis -> return (AbstractTyCon dis) IfDataTyCon cons _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons) @@ -541,7 +545,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom ifConSrcStricts = if_src_stricts}) = -- Universally-quantified tyvars are shared with -- parent TyCon, and are alrady in scope - bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do + bindIfaceTvBndrs ex_tvs $ \ ex_tyvars -> do { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ) ; dc_name <- lookupIfaceTop occ @@ -568,14 +572,13 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom -- Remember, tycon is the representation tycon ; let orig_res_ty = mkFamilyTyConApp tycon - (substTyVars (mkTopTvSubst eq_spec) tc_tyvars) + (substTyVars (mkTopTCvSubst (map eqSpecPair eq_spec)) + tc_tyvars) - ; prom_info <- if is_prom then do { n <- newTyConRepName dc_name - ; return (Promoted n) } - else return NotPromoted + ; prom_rep_name <- newTyConRepName dc_name ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name)) - dc_name is_infix prom_info + dc_name is_infix prom_rep_name (map src_strict if_src_stricts) (Just stricts) -- Pass the HsImplBangs (i.e. final @@ -601,13 +604,13 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom src_strict :: IfaceSrcBang -> HsSrcBang src_strict (IfSrcBang unpk bang) = HsSrcBang Nothing unpk bang -tcIfaceEqSpec :: IfaceEqSpec -> IfL [(TyVar, Type)] +tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec] tcIfaceEqSpec spec = mapM do_item spec where do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ ; ty <- tcIfaceType if_ty - ; return (tv,ty) } + ; return (mkEqSpec tv ty) } {- Note [Synonym kind loop] @@ -874,70 +877,55 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo -} tcIfaceType :: IfaceType -> IfL Type -tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } -tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } -tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) } -tcIfaceType (IfaceFunTy t1 t2) = tcIfaceTypeFun t1 t2 -tcIfaceType (IfaceDFunTy t1 t2) = tcIfaceTypeFun t1 t2 -tcIfaceType (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks -tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc - ; tks' <- tcIfaceTcArgs tks - ; return (mkTyConApp tc' tks') } -tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } - -tcIfaceTypeFun :: IfaceType -> IfaceType -> IfL Type -tcIfaceTypeFun t1 t2 = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } - -tcIfaceKind :: IfaceKind -> IfL Type -tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') } -tcIfaceKind (IfaceFunTy t1 t2) = tcIfaceKindFun t1 t2 -tcIfaceKind (IfaceDFunTy t1 t2) = tcIfaceKindFun t1 t2 -tcIfaceKind (IfaceLitTy l) = pprPanic "tcIfaceKind" (ppr l) -tcIfaceKind k = tcIfaceType k - -tcIfaceKindFun :: IfaceKind -> IfaceKind -> IfL Type -tcIfaceKindFun t1 t2 = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') } +tcIfaceType = go + where + go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n + go (IfaceAppTy t1 t2) = AppTy <$> go t1 <*> go t2 + go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l + go (IfaceFunTy t1 t2) = ForAllTy <$> (Anon <$> go t1) <*> go t2 + go (IfaceDFunTy t1 t2) = ForAllTy <$> (Anon <$> go t1) <*> go t2 + go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks + go (IfaceTyConApp tc tks) + = do { tc' <- tcIfaceTyCon tc + ; tks' <- mapM go (tcArgsIfaceTypes tks) + ; return (mkTyConApp tc' tks') } + go (IfaceForAllTy bndr t) + = bindIfaceBndrTy bndr $ \ tv' vis -> mkNamedForAllTy tv' vis <$> go t + go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co + go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co tcIfaceTupleTy :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> IfL Type tcIfaceTupleTy sort info args = do { args' <- tcIfaceTcArgs args ; let arity = length args' - ; base_tc <- tcTupleTyCon sort arity + ; base_tc <- tcTupleTyCon True sort arity ; case info of NoIfaceTyConInfo -> return (mkTyConApp base_tc args') - IfacePromotedTyCon - | Promoted tc <- promotableTyCon_maybe base_tc - -> return (mkTyConApp tc args') - | otherwise - -> panic "tcIfaceTupleTy" (ppr base_tc) - IfacePromotedDataCon -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc) kind_args = map typeKind args' ; return (mkTyConApp tc (kind_args ++ args')) } } -tcTupleTyCon :: TupleSort -> Arity -> IfL TyCon -tcTupleTyCon sort arity +-- See Note [Unboxed tuple levity vars] in TyCon +tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr) + -> TupleSort + -> Arity -- the number of args. *not* the tuple arity. + -> IfL TyCon +tcTupleTyCon in_type sort arity = case sort of ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity) ; return (tyThingTyCon thing) } BoxedTuple -> return (tupleTyCon Boxed arity) - UnboxedTuple -> return (tupleTyCon Unboxed arity) + UnboxedTuple -> return (tupleTyCon Unboxed arity') + where arity' | in_type = arity `div` 2 + | otherwise = arity + -- in expressions, we only have term args tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type] -tcIfaceTcArgs args - = case args of - ITC_Type t ts -> - do { t' <- tcIfaceType t - ; ts' <- tcIfaceTcArgs ts - ; return (t':ts') } - ITC_Kind k ks -> - do { k' <- tcIfaceKind k - ; ks' <- tcIfaceTcArgs ks - ; return (k':ks') } - ITC_Nil -> return [] +tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes + ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType tcIfaceCtxt sts = mapM tcIfaceType sts @@ -948,49 +936,56 @@ tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) {- -************************************************************************ -* * +%************************************************************************ +%* * Coercions * * ************************************************************************ -} tcIfaceCo :: IfaceCoercion -> IfL Coercion -tcIfaceCo (IfaceReflCo r t) = mkReflCo r <$> tcIfaceType t -tcIfaceCo (IfaceFunCo r c1 c2) = mkFunCo r <$> tcIfaceCo c1 <*> tcIfaceCo c2 -tcIfaceCo (IfaceTyConAppCo r tc cs) = mkTyConAppCo r <$> tcIfaceTyCon tc - <*> mapM tcIfaceCo cs -tcIfaceCo (IfaceAppCo c1 c2) = mkAppCo <$> tcIfaceCo c1 - <*> tcIfaceCo c2 -tcIfaceCo (IfaceForAllCo tv c) = bindIfaceTyVar tv $ \ tv' -> - mkForAllCo tv' <$> tcIfaceCo c -tcIfaceCo (IfaceCoVarCo n) = mkCoVarCo <$> tcIfaceCoVar n -tcIfaceCo (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n - <*> pure i - <*> mapM tcIfaceCo cs -tcIfaceCo (IfaceUnivCo s r t1 t2) = UnivCo s r <$> tcIfaceType t1 - <*> tcIfaceType t2 -tcIfaceCo (IfaceSymCo c) = SymCo <$> tcIfaceCo c -tcIfaceCo (IfaceTransCo c1 c2) = TransCo <$> tcIfaceCo c1 - <*> tcIfaceCo c2 -tcIfaceCo (IfaceInstCo c1 t2) = InstCo <$> tcIfaceCo c1 - <*> tcIfaceType t2 -tcIfaceCo (IfaceNthCo d c) = NthCo d <$> tcIfaceCo c -tcIfaceCo (IfaceLRCo lr c) = LRCo lr <$> tcIfaceCo c -tcIfaceCo (IfaceSubCo c) = SubCo <$> tcIfaceCo c -tcIfaceCo (IfaceAxiomRuleCo ax tys cos) = AxiomRuleCo - <$> tcIfaceCoAxiomRule ax - <*> mapM tcIfaceType tys - <*> mapM tcIfaceCo cos - -tcIfaceCoVar :: FastString -> IfL CoVar -tcIfaceCoVar = tcIfaceLclId - -tcIfaceCoAxiomRule :: FastString -> IfL CoAxiomRule -tcIfaceCoAxiomRule n = - case Map.lookup n typeNatCoAxiomRules of - Just ax -> return ax - _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n) +tcIfaceCo = go + where + go (IfaceReflCo r t) = Refl r <$> tcIfaceType t + go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 + go (IfaceTyConAppCo r tc cs) + = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs + go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 + go (IfaceForAllCo tv k c) = do { k' <- go k + ; bindIfaceTyVar tv $ \ tv' -> + ForAllCo tv' k' <$> go c } + go (IfaceCoVarCo n) = CoVarCo <$> go_var n + go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs + go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r + <*> tcIfaceType t1 <*> tcIfaceType t2 + go (IfaceSymCo c) = SymCo <$> go c + go (IfaceTransCo c1 c2) = TransCo <$> go c1 + <*> go c2 + go (IfaceInstCo c1 t2) = InstCo <$> go c1 + <*> go t2 + go (IfaceNthCo d c) = NthCo d <$> go c + go (IfaceLRCo lr c) = LRCo lr <$> go c + go (IfaceCoherenceCo c1 c2) = CoherenceCo <$> go c1 + <*> go c2 + go (IfaceKindCo c) = KindCo <$> go c + go (IfaceSubCo c) = SubCo <$> go c + go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> go_axiom_rule ax + <*> mapM go cos + + go_var :: FastString -> IfL CoVar + go_var = tcIfaceLclId + + go_axiom_rule :: FastString -> IfL CoAxiomRule + go_axiom_rule n = + case Map.lookup n typeNatCoAxiomRules of + Just ax -> return ax + _ -> pprPanic "go_axiom_rule" (ppr n) + +tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance +tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv +tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco +tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco +tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str {- ************************************************************************ @@ -1028,8 +1023,12 @@ tcIfaceExpr (IfaceFCall cc ty) = do tcIfaceExpr (IfaceTuple sort args) = do { args' <- mapM tcIfaceExpr args - ; tc <- tcTupleTyCon sort arity - ; let con_args = map (Type . exprType) args' ++ args' + ; tc <- tcTupleTyCon False sort arity + ; let con_tys = map exprType args' + some_con_args = map Type con_tys ++ args' + con_args = case sort of + UnboxedTuple -> map (Type . getLevity "tcIfaceExpr") con_tys ++ some_con_args + _ -> some_con_args -- Put the missing type arguments back in con_id = dataConWorkId (tyConSingleDataCon tc) ; return (mkApps (Var con_id) con_args) } @@ -1044,7 +1043,7 @@ tcIfaceExpr (IfaceLam (bndr, os) body) tcIfaceOneShot _ b = b tcIfaceExpr (IfaceApp fun arg) - = tcIfaceApps fun arg + = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg tcIfaceExpr (IfaceECase scrut ty) = do { scrut' <- tcIfaceExpr scrut @@ -1056,7 +1055,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let scrut_ty = exprType scrut' - case_bndr' = mkLocalId case_bndr_name scrut_ty + case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty tc_app = splitTyConApp scrut_ty -- NB: Won't always succeed (polymorphic case) -- but won't be demanded in those cases @@ -1073,7 +1072,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body) ; ty' <- tcIfaceType ty ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} name ty' info - ; let id = mkLocalIdWithInfo name ty' id_info + ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info ; rhs' <- tcIfaceExpr rhs ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) ; return (Let (NonRec id rhs') body') } @@ -1088,7 +1087,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body) tc_rec_bndr (IfLetBndr fs ty _) = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; return (mkLocalId name ty') } + ; return (mkLocalIdOrCoVar name ty') } tc_pair (IfLetBndr _ _ info, rhs) id = do { rhs' <- tcIfaceExpr rhs ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} @@ -1107,31 +1106,6 @@ tcIfaceExpr (IfaceTick tickish expr) = do return (Tick tickish' expr') ------------------------- -tcIfaceApps :: IfaceExpr -> IfaceExpr -> IfL CoreExpr --- See Note [Checking IfaceTypes vs IfaceKinds] -tcIfaceApps fun arg - = go_down fun [arg] - where - go_down (IfaceApp fun arg) args = go_down fun (arg:args) - go_down fun args = do { fun' <- tcIfaceExpr fun - ; go_up fun' (exprType fun') args } - - go_up :: CoreExpr -> Type -> [IfaceExpr] -> IfL CoreExpr - go_up fun _ [] = return fun - go_up fun fun_ty (IfaceType t : args) - | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty - = do { t' <- if isKindVar tv - then tcIfaceKind t - else tcIfaceType t - ; let fun_ty' = substTyWith [tv] [t'] body_ty - ; go_up (App fun (Type t')) fun_ty' args } - go_up fun fun_ty (arg : args) - | Just (_, fun_ty') <- splitFunTy_maybe fun_ty - = do { arg' <- tcIfaceExpr arg - ; go_up (App fun arg') fun_ty' args } - go_up fun fun_ty args = pprPanic "tcIfaceApps" (ppr fun $$ ppr fun_ty $$ ppr args) - -------------------------- tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id) tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) @@ -1179,7 +1153,7 @@ tcIfaceDataAlt con inst_tys arg_strs rhs ; let (ex_tvs, arg_ids) = dataConRepFSInstPat arg_strs uniqs con inst_tys - ; rhs' <- extendIfaceTyVarEnv ex_tvs $ + ; rhs' <- extendIfaceEnvs ex_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } @@ -1377,17 +1351,9 @@ tcIfaceTyConByName name tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon (IfaceTyCon name info) = do { thing <- tcIfaceGlobal name - ; case info of - NoIfaceTyConInfo -> return (tyThingTyCon thing) - IfacePromotedDataCon -> return (promoteDataCon (tyThingDataCon thing)) - -- Same Name as its underlying DataCon - IfacePromotedTyCon -> return (promote_tc (tyThingTyCon thing)) } - -- Same Name as its underlying TyCon - where - promote_tc tc - | Promoted prom_tc <- promotableTyCon_maybe tc = prom_tc - | isSuperKind (tyConKind tc) = tc - | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr tc) + ; return $ case info of + NoIfaceTyConInfo -> tyThingTyCon thing + IfacePromotedDataCon -> promoteDataCon $ tyThingDataCon thing } tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name @@ -1413,12 +1379,23 @@ tcIfaceExtId name = do { thing <- tcIfaceGlobal name ************************************************************************ -} -bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a -bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside +bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a +bindIfaceId (fs, ty) thing_inside = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; let id = mkLocalId name ty' + ; let id = mkLocalIdOrCoVar name ty' ; extendIfaceIdEnv [id] (thing_inside id) } + +bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a +bindIfaceIds [] thing_inside = thing_inside [] +bindIfaceIds (b:bs) thing_inside + = bindIfaceId b $ \b' -> + bindIfaceIds bs $ \bs' -> + thing_inside (b':bs') + +bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a +bindIfaceBndr (IfaceIdBndr bndr) thing_inside + = bindIfaceId bndr thing_inside bindIfaceBndr (IfaceTvBndr bndr) thing_inside = bindIfaceTyVar bndr thing_inside @@ -1430,33 +1407,26 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- +bindIfaceBndrTy :: IfaceForAllBndr -> (TyVar -> VisibilityFlag -> IfL a) -> IfL a +bindIfaceBndrTy (IfaceTv tv vis) thing_inside + = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis + bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside = do { name <- newIfaceName (mkTyVarOccFS occ) ; tyvar <- mk_iface_tyvar name kind ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } -bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a -bindIfaceTyVars bndrs thing_inside - = do { names <- newIfaceNames (map mkTyVarOccFS occs) - ; let (kis_kind, tys_kind) = span isSuperIfaceKind kinds - (kis_name, tys_name) = splitAt (length kis_kind) names - -- We need to bring the kind variables in scope since type - -- variables may mention them. - ; kvs <- zipWithM mk_iface_tyvar kis_name kis_kind - ; extendIfaceTyVarEnv kvs $ do - { tvs <- zipWithM mk_iface_tyvar tys_name tys_kind - ; extendIfaceTyVarEnv tvs (thing_inside (kvs ++ tvs)) } } - where - (occs,kinds) = unzip bndrs - -isSuperIfaceKind :: IfaceKind -> Bool -isSuperIfaceKind (IfaceTyConApp tc ITC_Nil) = ifaceTyConName tc == superKindTyConName -isSuperIfaceKind _ = False +bindIfaceTvBndrs :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +bindIfaceTvBndrs [] thing_inside = thing_inside [] +bindIfaceTvBndrs (tv:tvs) thing_inside + = bindIfaceTyVar tv $ \tv' -> + bindIfaceTvBndrs tvs $ \tvs' -> + thing_inside (tv':tvs') mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar mk_iface_tyvar name ifKind - = do { kind <- tcIfaceKind ifKind + = do { kind <- tcIfaceType ifKind ; return (Var.mkTyVar name kind) } bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a @@ -1466,12 +1436,14 @@ bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a -- Here 'a' is in scope when we look at the 'data T' bindIfaceTyVars_AT [] thing_inside = thing_inside [] -bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside - = do { mb_tv <- lookupIfaceTyVar tv_occ - ; let bind_b :: (TyVar -> IfL a) -> IfL a - bind_b = case mb_tv of - Just b' -> \k -> k b' - Nothing -> bindIfaceTyVar b - ; bind_b $ \b' -> +bindIfaceTyVars_AT (b : bs) thing_inside + = do { bindIfaceTyVar_AT b $ \b' -> bindIfaceTyVars_AT bs $ \bs' -> thing_inside (b':bs') } + +bindIfaceTyVar_AT :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a +bindIfaceTyVar_AT tv thing + = do { mb_tv <- lookupIfaceTyVar tv + ; case mb_tv of + Just b' -> thing b' + Nothing -> bindIfaceTyVar tv thing } |