From: Manuel M T Chakravarty Date: Fri, 4 Aug 2006 21:19:12 +0000 (+0000) Subject: Massive patch for the first months work adding System FC to GHC #16 X-Git-Tag: After_FC_branch_merge~165 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=2cab0d72186713bc2be393b3ee2c39b46a453783 Massive patch for the first months work adding System FC to GHC #16 Broken up massive patch -=chak Original log message: This is (sadly) all done in one patch to avoid Darcs bugs. It's not complete work... more FC stuff to come. A compiler using just this patch will fail dismally. --- diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index f81f2e7..5c76d55 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -14,26 +14,29 @@ module BuildTyCl ( import IfaceEnv ( newImplicitBinder ) import TcRnMonad -import DataCon ( DataCon, isNullarySrcDataCon, dataConTyVars, - mkDataCon, dataConFieldLabels, dataConOrigArgTys ) +import DataCon ( DataCon, isNullarySrcDataCon, dataConUnivTyVars, + mkDataCon, dataConFieldLabels, dataConInstOrigArgTys, + dataConTyCon ) import Var ( tyVarKind, TyVar, Id ) import VarSet ( isEmptyVarSet, intersectVarSet, elemVarSet ) import TysWiredIn ( unitTy ) import BasicTypes ( RecFlag, StrictnessMark(..) ) import Name ( Name ) import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc, - mkClassDataConOcc, mkSuperDictSelOcc ) + mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc ) import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId ) import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) ) import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta, tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ), - isRecursiveTyCon, + isRecursiveTyCon, tyConArity, ArgVrcs, AlgTyConRhs(..), newTyConRhs ) import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe, mkPredTys, mkTyVarTys, ThetaType, Type, - substTyWith, zipTopTvSubst, substTheta ) + substTyWith, zipTopTvSubst, substTheta, mkForAllTys, + mkTyConApp, mkTyVarTy ) +import Coercion ( mkNewTypeCoercion ) import Outputable import List ( nub ) @@ -54,11 +57,12 @@ buildAlgTyCon :: Name -> [TyVar] -> AlgTyConRhs -> ArgVrcs -> RecFlag -> Bool -- True <=> want generics functions + -> Bool -- True <=> was declared in GADT syntax -> TcRnIf m n TyCon -buildAlgTyCon tc_name tvs stupid_theta rhs arg_vrcs is_rec want_generics +buildAlgTyCon tc_name tvs stupid_theta rhs arg_vrcs is_rec want_generics gadt_syn = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs stupid_theta - rhs fields is_rec want_generics + rhs fields is_rec want_generics gadt_syn ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind ; fields = mkTyConSelIds tycon rhs } @@ -72,16 +76,23 @@ mkDataTyConRhs :: [DataCon] -> AlgTyConRhs mkDataTyConRhs cons = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons } -mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs -mkNewTyConRhs tycon con - = NewTyCon { data_con = con, - nt_rhs = rhs_ty, - nt_etad_rhs = eta_reduce tvs rhs_ty, - nt_rep = mkNewTyConRep tycon rhs_ty } +mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs +-- Monadic because it makes a Name for the coercion TyCon +-- We pass the Name of the parent TyCon, as well as the TyCon itself, +-- because the latter is part of a knot, whereas the former is not. +mkNewTyConRhs tycon_name tycon con + = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc + ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty + ; return (NewTyCon { data_con = con, + nt_co = co_tycon, + nt_rhs = rhs_ty, + nt_etad_rhs = eta_reduce tvs rhs_ty, + nt_rep = mkNewTyConRep tycon rhs_ty }) } where - tvs = dataConTyVars con - rhs_ty = head (dataConOrigArgTys con) - -- Newtypes are guaranteed vanilla, so OrigArgTys will do + tvs = tyConTyVars tycon + rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs)) + -- Instantiate the data con with the + -- type variables from the tycon eta_reduce [] ty = ([], ty) eta_reduce (a:as) ty | null as', @@ -132,19 +143,21 @@ mkNewTyConRep tc rhs_ty other -> rep_ty ------------------------------------------------------ -buildDataCon :: Name -> Bool -> Bool +buildDataCon :: Name -> Bool -> [StrictnessMark] -> [Name] -- Field labels - -> [TyVar] + -> [TyVar] -> [TyVar] -- Univ and ext + -> [(TyVar,Type)] -- Equality spec -> ThetaType -- Does not include the "stupid theta" - -> [Type] -> TyCon -> [Type] + -- or the GADT equalities + -> [Type] -> TyCon -> TcRnIf m n DataCon -- A wrapper for DataCon.mkDataCon that -- a) makes the worker Id -- b) makes the wrapper Id if necessary, including -- allocating its unique (hence monadic) -buildDataCon src_name declared_infix vanilla arg_stricts field_lbls - tyvars ctxt arg_tys tycon res_tys +buildDataCon src_name declared_infix arg_stricts field_lbls + univ_tvs ex_tvs eq_spec ctxt arg_tys tycon = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc -- This last one takes the name of the data constructor in the source @@ -152,11 +165,11 @@ buildDataCon src_name declared_infix vanilla arg_stricts field_lbls -- space, and puts it into the VarName name space ; let - stupid_ctxt = mkDataConStupidTheta tycon arg_tys res_tys - data_con = mkDataCon src_name declared_infix vanilla + stupid_ctxt = mkDataConStupidTheta tycon arg_tys univ_tvs + data_con = mkDataCon src_name declared_infix arg_stricts field_lbls - tyvars stupid_ctxt ctxt - arg_tys tycon res_tys dc_ids + univ_tvs ex_tvs eq_spec ctxt + arg_tys tycon stupid_ctxt dc_ids dc_ids = mkDataConIds wrap_name work_name data_con ; returnM data_con } @@ -164,18 +177,20 @@ buildDataCon src_name declared_infix vanilla arg_stricts field_lbls -- The stupid context for a data constructor should be limited to -- the type variables mentioned in the arg_tys -mkDataConStupidTheta tycon arg_tys res_tys +-- ToDo: Or functionally dependent on? +-- This whole stupid theta thing is, well, stupid. +mkDataConStupidTheta tycon arg_tys univ_tvs | null stupid_theta = [] -- The common case | otherwise = filter in_arg_tys stupid_theta where - tc_subst = zipTopTvSubst (tyConTyVars tycon) res_tys - stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) + tc_subst = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs) + stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) -- Start by instantiating the master copy of the -- stupid theta, taken from the TyCon arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys pred = not $ isEmptyVarSet $ - tyVarsOfPred pred `intersectVarSet` arg_tyvars + tyVarsOfPred pred `intersectVarSet` arg_tyvars ------------------------------------------------------ mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id] @@ -211,30 +226,34 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - ; fixM (\ clas -> do { -- Only name generation inside loop + ; fixM (\ rec_clas -> do { -- Only name generation inside loop - let { op_tys = [ty | (_,_,ty) <- sig_stuff] + let { rec_tycon = classTyCon rec_clas + ; op_tys = [ty | (_,_,ty) <- sig_stuff] ; sc_tys = mkPredTys sc_theta ; dict_component_tys = sc_tys ++ op_tys - ; sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names] - ; op_items = [ (mkDictSelId op_name clas, dm_info) + ; sc_sel_ids = [mkDictSelId sc_name rec_clas | sc_name <- sc_sel_names] + ; op_items = [ (mkDictSelId op_name rec_clas, dm_info) | (op_name, dm_info, _) <- sig_stuff ] } -- Build the selector id and default method id - ; dict_con <- buildDataCon datacon_name + ; dict_con <- buildDataCon datacon_name False -- Not declared infix - True -- Is vanilla; tyvars same as tycon (map (const NotMarkedStrict) dict_component_tys) [{- No labelled fields -}] - tvs [{-No context-}] dict_component_tys - (classTyCon clas) (mkTyVarTys tvs) + tvs [{- no existentials -}] + [{- No equalities -}] [{-No context-}] + dict_component_tys + rec_tycon - ; let { clas = mkClass class_name tvs fds - sc_theta sc_sel_ids op_items - tycon + ; rhs <- case dict_component_tys of + [rep_ty] -> mkNewTyConRhs tycon_name rec_tycon dict_con + other -> return (mkDataTyConRhs [dict_con]) + + ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind - ; tycon = mkClassTyCon tycon_name clas_kind tvs - tc_vrcs rhs clas tc_isrec + ; tycon = mkClassTyCon tycon_name clas_kind tvs + tc_vrcs rhs rec_clas tc_isrec -- A class can be recursive, and in the case of newtypes -- this matters. For example -- class C a where { op :: C b => a -> b -> Int } @@ -242,14 +261,10 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs -- a newtype, and it should be a *recursive* newtype. -- [If we don't make it a recursive newtype, we'll expand the -- newtype like a synonym, but that will lead to an infinite type] - - ; clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind - - ; rhs = case dict_component_tys of - [rep_ty] -> mkNewTyConRhs tycon dict_con - other -> mkDataTyConRhs [dict_con] } - ; return clas + ; return (mkClass class_name tvs fds + sc_theta sc_sel_ids op_items + tycon) })} \end{code} diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 92d3997..8134676 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -17,12 +17,15 @@ import LoadIface ( loadInterface, loadWiredInHomeIface, loadDecls, findAndReadIface ) import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, refineIfaceIdEnv, + tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, newIfaceName, newIfaceNames, ifaceExportNames ) import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, + liftedTypeKindTyCon, unliftedTypeKindTyCon, + openTypeKindTyCon, argTypeKindTyCon, + ubxTupleKindTyCon, mkTyVarTys, ThetaType ) import TypeRep ( Type(..), PredType(..) ) import TyCon ( TyCon, tyConName ) @@ -31,7 +34,6 @@ import HscTypes ( ExternalPackageState(..), ModIface(..), ModDetails(..), HomeModInfo(..), emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds ) import InstEnv ( Instance(..), mkImportedInstance ) -import Unify ( coreRefineTys ) import CoreSyn import CoreUtils ( exprType ) import CoreUnfold @@ -45,13 +47,13 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), vanillaIdInfo, newStrictnessInfo ) import Class ( Class ) import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) -import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConInstArgTys, isVanillaDataCon ) +import DataCon ( DataCon, dataConWorkId, dataConExTyVars, dataConInstArgTys ) import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) import Var ( TyVar, mkTyVar, tyVarKind ) import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, - wiredInNameTyThing_maybe, nameParent ) + nameOccName, wiredInNameTyThing_maybe ) import NameEnv -import OccName ( OccName, mkVarOccFS, mkTyVarOcc ) +import OccName ( OccName, mkVarOccFS, mkTyVarOccoccNameSpace, pprNameSpace ) import FastString ( FastString ) import Module ( Module, moduleName ) import UniqFM ( lookupUFM ) @@ -62,6 +64,7 @@ import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) import Util ( zipWithEqual, equalLength, splitAtList ) import DynFlags ( DynFlag(..), isOneShot ) + \end{code} This module takes @@ -161,7 +164,8 @@ importDecl name }}} where nd_doc = ptext SLIT("Need decl for") <+> ppr name - not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name)) + not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> + pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name) 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"), ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")]) \end{code} @@ -348,7 +352,7 @@ tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) tcIfaceDecl (IfaceData {ifName = occ_name, ifTyVars = tv_bndrs, - ifCtxt = ctxt, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifVrcs = arg_vrcs, ifRec = is_rec, ifGeneric = want_generic }) @@ -357,9 +361,9 @@ tcIfaceDecl (IfaceData {ifName = occ_name, { tycon <- fixM ( \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt - ; cons <- tcIfaceDataCons tycon tyvars rdr_cons + ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; buildAlgTyCon tc_name tyvars stupid_theta - cons arg_vrcs is_rec want_generic + cons arg_vrcs is_rec want_generic gadt_syn }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) @@ -405,33 +409,23 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0 [])) } -tcIfaceDataCons tycon tc_tyvars if_cons +tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon -> return mkAbstractTyConRhs IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con - ; return (mkNewTyConRhs tycon data_con) } + ; mkNewTyConRhs tycon_name tycon data_con } where - tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args, - ifConStricts = stricts, ifConFields = field_lbls}) - = do { name <- lookupIfaceTop occ - -- Read the argument types, but lazily to avoid faulting in - -- the component types unless they are really needed - ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) - ; lbl_names <- mappM lookupIfaceTop field_lbls - ; buildDataCon name is_infix True {- Vanilla -} - stricts lbl_names - tc_tyvars [] arg_tys tycon - (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys - } - - tc_con_decl (IfGadtCon { ifConTyVars = con_tvs, - ifConOcc = occ, ifConCtxt = ctxt, - ifConArgTys = args, ifConResTys = ress, - ifConStricts = stricts}) - = bindIfaceTyVars con_tvs $ \ con_tyvars -> do + tc_con_decl (IfCon { ifConInfix = is_infix, + ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, + ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, + ifConArgTys = args, ifConFields = field_lbls, + ifConStricts = stricts}) + = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do + bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do { name <- lookupIfaceTop occ + ; eq_spec <- tcIfaceEqSpec spec ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here -- At one stage I thought that this context checking *had* -- to be lazy, because of possible mutual recursion between the @@ -445,14 +439,22 @@ tcIfaceDataCons tycon tc_tyvars if_cons -- Read the argument types, but lazily to avoid faulting in -- the component types unless they are really needed ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) - ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress) + ; lbl_names <- mappM lookupIfaceTop field_lbls - ; buildDataCon name False {- Not infix -} False {- Not vanilla -} - stricts [{- No fields -}] - con_tyvars theta - arg_tys tycon res_tys + ; buildDataCon name is_infix {- Not infix -} + stricts lbl_names + univ_tyvars ex_tyvars + eq_spec theta + arg_tys tycon } mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name + +tcIfaceEqSpec spec + = mapM do_item spec + where + do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ + ; ty <- tcIfaceType if_ty + ; return (tv,ty) } \end{code} @@ -547,6 +549,7 @@ tcIfaceTypes tys = mapM tcIfaceType tys tcIfacePredType :: IfacePredType -> IfL PredType tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') } tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') } +tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') } ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType @@ -636,12 +639,14 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body) where (bndrs, rhss) = unzip pairs +tcIfaceExpr (IfaceCast expr co) = do + expr' <- tcIfaceExpr expr + co' <- tcIfaceType co + returnM (Cast expr' co') + tcIfaceExpr (IfaceNote note expr) = tcIfaceExpr expr `thenM` \ expr' -> case note of - IfaceCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' -> - returnM (Note (Coerce to_ty' - (exprType expr')) expr') IfaceInlineMe -> returnM (Note InlineMe expr') IfaceSCC cc -> returnM (Note (SCC cc) expr') IfaceCoreNote n -> returnM (Note (CoreNote n) expr') @@ -665,47 +670,29 @@ tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ) ; ASSERT2( con `elem` tyConDataCons tycon, ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) + tcIfaceDataAlt con inst_tys arg_strs rhs } - if isVanillaDataCon con then - tcVanillaAlt con inst_tys arg_strs rhs - else - do { -- General case - let (tyvar_strs, id_strs) = splitAtList (dataConTyVars con) arg_strs +tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) + = ASSERT( isTupleTyCon tycon ) + do { let [data_con] = tyConDataCons tycon + ; tcIfaceDataAlt data_con inst_tys arg_occs rhs } + +tcIfaceDataAlt con inst_tys arg_strs rhs + = do { arg_names <- newIfaceNames (map mkVarOccFS arg_strs) + ; let (tyvar_strs, id_strs) = splitAtList (dataConTyVars con) arg_strs ; tyvar_names <- mapM (newIfaceName . mkTyVarOcc) tyvar_strs ; id_names <- mapM (newIfaceName . mkVarOccFS) id_strs - ; let tyvars = [ mkTyVar name (tyVarKind tv) - | (name,tv) <- tyvar_names `zip` dataConTyVars con ] - arg_tys = dataConInstArgTys con (mkTyVarTys tyvars) + ; let ex_tvs = [ mkTyVar name (tyVarKind tv) + | (name,tv) <- tyvar_names `zip` dataConExTyVars con ] + arg_tys = dataConInstArgTys con (inst_tys ++ mkTyVarTys ex_tvs) arg_ids = ASSERT2( equalLength id_names arg_tys, - ppr (con, tyvar_names++id_names, rhs) $$ ppr tyvars $$ ppr arg_tys ) + ppr (con, tyvar_names++id_names, rhs) $$ ppr ex_tvs $$ ppr arg_tys ) zipWith mkLocalId id_names arg_tys - - Just refine = coreRefineTys con tyvars (mkTyConApp tycon inst_tys) - ; rhs' <- extendIfaceTyVarEnv tyvars $ + ; rhs' <- extendIfaceTyVarEnv ex_tvs $ extendIfaceIdEnv arg_ids $ - refineIfaceIdEnv refine $ - -- You might think that we don't need to refine the envt here, - -- but we do: \(x::a) -> case y of - -- MkT -> case x of { True -> ... } - -- In the "case x" we need to know x's type, because we use that - -- to find which module to look for "True" in. Sigh. tcIfaceExpr rhs - ; return (DataAlt con, tyvars ++ arg_ids, rhs') }} - -tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) - = ASSERT( isTupleTyCon tycon ) - do { let [data_con] = tyConDataCons tycon - ; tcVanillaAlt data_con inst_tys arg_occs rhs } - -tcVanillaAlt data_con inst_tys arg_strs rhs - = do { arg_names <- newIfaceNames (map mkVarOccFS arg_strs) - ; let arg_tys = dataConInstArgTys data_con inst_tys - ; let arg_ids = ASSERT2( equalLength arg_names arg_tys, - ppr data_con <+> ppr inst_tys <+> ppr arg_strs $$ ppr rhs ) - zipWith mkLocalId arg_names arg_tys - ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs) - ; returnM (DataAlt data_con, arg_ids, rhs') } + ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } \end{code} @@ -887,6 +874,12 @@ tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm #else check_tc tc = tc #endif +-- we should be okay just returning Kind constructors without extra loading +tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon +tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon +tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon +tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon +tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon -- Even though we are in an interface file, we want to make -- sure the instances and RULES of this tycon are loaded @@ -965,17 +958,22 @@ newExtCoreBndr (var, ty) bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside = do { name <- newIfaceName (mkTyVarOcc occ) - ; let tyvar = mk_iface_tyvar name kind + ; 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 mkTyVarOcc occs) - ; let tyvars = zipWith mk_iface_tyvar names kinds + ; tyvars <- zipWithM mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where (occs,kinds) = unzip bndrs +mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar +mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind + ; return (mkTyVar name kind) + } + mk_iface_tyvar name kind = mkTyVar name kind \end{code}