X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=fb6634a2d452b51d9f362ba7792240080dabce36;hb=483817dd051f011218c3c7041809ef019a7ebd0d;hp=37b7036f137f5df3a8ddf1b6be46fd3f75ca8a9c;hpb=6c872fff42025a842e8500ddbb13fdcca60eaf75;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 37b7036..fb6634a 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -21,17 +21,18 @@ module TcHsSyn ( TypecheckedMatch, TypecheckedHsModule, TypecheckedGRHSs, TypecheckedGRHS, TypecheckedRecordBinds, TypecheckedDictBinds, + TypecheckedMatchContext, mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsLet, - idsToMonoBinds, + simpleHsLitTy, - -- re-exported from TcEnv - TcId, tcInstId, + collectTypedPatBinders, outPatType, - maybeBoxedPrimType, + -- re-exported from TcEnv + TcId, - zonkTopBinds, zonkId, zonkIdOcc, + zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr, zonkForeignExports, zonkRules ) where @@ -41,27 +42,25 @@ module TcHsSyn ( import HsSyn -- oodles of it -- others: -import Id ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id ) -import DataCon ( DataCon, dataConWrapId, splitProductType_maybe ) -import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv, - ValueEnv, TcId, tcInstId - ) +import Id ( idName, idType, setIdType, Id ) +import DataCon ( dataConWrapId ) +import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId ) import TcMonad -import TcType ( TcType, TcTyVar, - zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType - ) -import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type ) -import Name ( isLocallyDefined ) -import Var ( TyVar ) -import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList ) -import VarSet ( isEmptyVarSet ) -import CoreSyn ( Expr ) -import CoreUnfold( unfoldingTemplate ) -import BasicTypes ( RecFlag(..) ) +import Type ( Type ) +import TcType ( TcType ) +import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars ) +import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, + doublePrimTy, addrPrimTy + ) +import TysWiredIn ( charTy, stringTy, intTy, integerTy, + mkListTy, mkTupleTy, unitTy ) +import CoreSyn ( Expr ) +import Var ( isId ) +import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName ) import Bag -import UniqFM import Outputable +import HscTypes ( TyThing(..) ) \end{code} @@ -101,6 +100,7 @@ type TypecheckedHsExpr = HsExpr Id TypecheckedPat type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat type TypecheckedStmt = Stmt Id TypecheckedPat type TypecheckedMatch = Match Id TypecheckedPat +type TypecheckedMatchContext = HsMatchContext Id type TypecheckedGRHSs = GRHSs Id TypecheckedPat type TypecheckedGRHS = GRHS Id TypecheckedPat type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat @@ -126,35 +126,79 @@ mkHsLet EmptyMonoBinds expr = expr mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args +\end{code} + -idsToMonoBinds :: [Id] -> TcMonoBinds -idsToMonoBinds ids - = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id)) - | id <- ids - ] +------------------------------------------------------ +\begin{code} +simpleHsLitTy :: HsLit -> TcType +simpleHsLitTy (HsCharPrim c) = charPrimTy +simpleHsLitTy (HsStringPrim s) = addrPrimTy +simpleHsLitTy (HsInt i) = intTy +simpleHsLitTy (HsInteger i) = integerTy +simpleHsLitTy (HsIntPrim i) = intPrimTy +simpleHsLitTy (HsFloatPrim f) = floatPrimTy +simpleHsLitTy (HsDoublePrim d) = doublePrimTy +simpleHsLitTy (HsChar c) = charTy +simpleHsLitTy (HsString str) = stringTy \end{code} + %************************************************************************ %* * -\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} +\subsection[mkFailurePair]{Code for pattern-matching and other failures} %* * %************************************************************************ -Some gruesome hackery for desugaring ccalls. It's here because if we put it -in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and -DsCCall.lhs. +Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@, +then something is wrong. +\begin{code} +outPatType :: TypecheckedPat -> Type + +outPatType (WildPat ty) = ty +outPatType (VarPat var) = idType var +outPatType (LazyPat pat) = outPatType pat +outPatType (AsPat var pat) = idType var +outPatType (ConPat _ ty _ _ _) = ty +outPatType (ListPat ty _) = mkListTy ty +outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats) +outPatType (RecPat _ ty _ _ _) = ty +outPatType (SigPat _ ty _) = ty +outPatType (LitPat lit ty) = ty +outPatType (NPat lit ty _) = ty +outPatType (NPlusKPat _ _ ty _ _) = ty +outPatType (DictPat ds ms) = case (length ds_ms) of + 0 -> unitTy + 1 -> idType (head ds_ms) + n -> mkTupleTy Boxed n (map idType ds_ms) + where + ds_ms = ds ++ ms +\end{code} + + +Nota bene: @DsBinds@ relies on the fact that at least for simple +tuple patterns @collectTypedPatBinders@ returns the binders in +the same order as they appear in the tuple. + +@collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees. \begin{code} -maybeBoxedPrimType :: Type -> Maybe (DataCon, Type) -maybeBoxedPrimType ty - = case splitProductType_maybe ty of -- Product data type - Just (tycon, tys_applied, data_con, [data_con_arg_ty]) -- constr has one arg - | isUnLiftedType data_con_arg_ty -- which is primitive - -> Just (data_con, data_con_arg_ty) - - other_cases -> Nothing +collectTypedPatBinders :: TypecheckedPat -> [Id] +collectTypedPatBinders (VarPat var) = [var] +collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat +collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat +collectTypedPatBinders (SigPat pat _ _) = collectTypedPatBinders pat +collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat) + fields) +collectTypedPatBinders (DictPat ds ms) = ds ++ ms +collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var] +collectTypedPatBinders any_other_pat = [ {-no binders-} ] \end{code} + %************************************************************************ %* * \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} @@ -179,49 +223,51 @@ the environment manipulation is tiresome. \begin{code} -- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> NF_TcM s TcId +zonkId :: TcId -> NF_TcM TcId zonkId id = zonkTcType (idType id) `thenNF_Tc` \ ty' -> returnNF_Tc (setIdType id ty') -- zonkIdBndr is used *after* typechecking to get the Id's type -- to its final form. The TyVarEnv give -zonkIdBndr :: TcId -> NF_TcM s Id +zonkIdBndr :: TcId -> NF_TcM Id zonkIdBndr id = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' -> returnNF_Tc (setIdType id ty') -zonkIdOcc :: TcId -> NF_TcM s Id +zonkIdOcc :: TcId -> NF_TcM Id zonkIdOcc id - | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id - -- The omitIfaceSigForId thing may look wierd but it's quite - -- sensible really. We're avoiding looking up superclass selectors - -- and constructors; zonking them is a no-op anyway, and the + = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' -> + -- We're even look up up superclass selectors and constructors; + -- even though zonking them is a no-op anyway, and the -- superclass selectors aren't in the environment anyway. - = returnNF_Tc id - | otherwise - = tcLookupValueMaybe (idName id) `thenNF_Tc` \ maybe_id' -> + -- But we don't want to call isLocalId to find out whether + -- it's a superclass selector (for example) because that looks + -- at the IdInfo field, which in turn be in a knot because of + -- the big knot in typecheckModule let new_id = case maybe_id' of - Just id' -> id' - Nothing -> pprTrace "zonkIdOcc: " (ppr id) id + Just (AnId id') -> id' + other -> id -- WARN( isLocalId id, ppr id ) id + -- Oops: the warning can give a black hole + -- because it looks at the idinfo in returnNF_Tc new_id \end{code} \begin{code} -zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv) +zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv) zonkTopBinds binds -- Top level is implicitly recursive = fixNF_Tc (\ ~(_, new_ids) -> tcExtendGlobalValEnv (bagToList new_ids) $ zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) -> - tcGetValueEnv `thenNF_Tc` \ env -> + tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc ((binds', env), new_ids) ) `thenNF_Tc` \ (stuff, _) -> returnNF_Tc stuff -zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv) +zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv) zonkBinds binds = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> @@ -229,9 +275,9 @@ zonkBinds binds where -- go :: TcHsBinds -- -> (TypecheckedHsBinds - -- -> NF_TcM s (TypecheckedHsBinds, TcEnv) + -- -> NF_TcM (TypecheckedHsBinds, TcEnv) -- ) - -- -> NF_TcM s (TypecheckedHsBinds, TcEnv) + -- -> NF_TcM (TypecheckedHsBinds, TcEnv) go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' -> go b2 $ \ b2' -> @@ -253,7 +299,7 @@ zonkBinds binds \begin{code} ------------------------------------------------------------------------- zonkMonoBinds :: TcMonoBinds - -> NF_TcM s (TypecheckedMonoBinds, Bag Id) + -> NF_TcM (TypecheckedMonoBinds, Bag Id) zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag) @@ -304,9 +350,11 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind) new_globals) where zonkExport (tyvars, global, local) - = mapNF_Tc zonkTcTyVarBndr tyvars `thenNF_Tc` \ new_tyvars -> - zonkIdBndr global `thenNF_Tc` \ new_global -> - zonkIdOcc local `thenNF_Tc` \ new_local -> + = zonkTcSigTyVars tyvars `thenNF_Tc` \ new_tyvars -> + -- This isn't the binding occurrence of these tyvars + -- but they should *be* tyvars. Hence zonkTcSigTyVars. + zonkIdBndr global `thenNF_Tc` \ new_global -> + zonkIdOcc local `thenNF_Tc` \ new_local -> returnNF_Tc (new_tyvars, new_global, new_local) \end{code} @@ -317,19 +365,19 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind) %************************************************************************ \begin{code} -zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch +zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch -zonkMatch (Match _ pats _ grhss) +zonkMatch (Match pats _ grhss) = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) -> tcExtendGlobalValEnv (bagToList new_ids) $ zonkGRHSs grhss `thenNF_Tc` \ new_grhss -> - returnNF_Tc (Match [] new_pats Nothing new_grhss) + returnNF_Tc (Match new_pats Nothing new_grhss) ------------------------------------------------------------------------- zonkGRHSs :: TcGRHSs - -> NF_TcM s TypecheckedGRHSs + -> NF_TcM TypecheckedGRHSs -zonkGRHSs (GRHSs grhss binds (Just ty)) +zonkGRHSs (GRHSs grhss binds ty) = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> tcSetEnv new_env $ let @@ -339,7 +387,7 @@ zonkGRHSs (GRHSs grhss binds (Just ty)) in mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty)) + returnNF_Tc (GRHSs new_grhss new_binds new_ty) \end{code} %************************************************************************ @@ -349,21 +397,28 @@ zonkGRHSs (GRHSs grhss binds (Just ty)) %************************************************************************ \begin{code} -zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr +zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr zonkExpr (HsVar id) = zonkIdOcc id `thenNF_Tc` \ id' -> returnNF_Tc (HsVar id') zonkExpr (HsIPVar id) - = zonkIdOcc id `thenNF_Tc` \ id' -> + = mapIPNameTc zonkIdOcc id `thenNF_Tc` \ id' -> returnNF_Tc (HsIPVar id') -zonkExpr (HsLit _) = panic "zonkExpr:HsLit" +zonkExpr (HsLit (HsRat f ty)) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (HsLit (HsRat f new_ty)) -zonkExpr (HsLitOut lit ty) +zonkExpr (HsLit (HsLitLit lit ty)) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (HsLitOut lit new_ty) + returnNF_Tc (HsLit (HsLitLit lit new_ty)) + +zonkExpr (HsLit lit) + = returnNF_Tc (HsLit lit) + +-- HsOverLit doesn't appear in typechecker output zonkExpr (HsLam match) = zonkMatch match `thenNF_Tc` \ new_match -> @@ -411,14 +466,16 @@ zonkExpr (HsLet binds expr) returnNF_Tc (HsLet new_binds new_expr) zonkExpr (HsWith expr binds) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkIPBinds binds `thenNF_Tc` \ new_binds -> + = zonkIPBinds binds `thenNF_Tc` \ new_binds -> + tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $ + zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsWith new_expr new_binds) where zonkIPBinds = mapNF_Tc zonkIPBind - zonkIPBind (n, e) = - zonkExpr e `thenNF_Tc` \ e' -> - returnNF_Tc (n, e') + zonkIPBind (n, e) + = mapIPNameTc zonkIdBndr n `thenNF_Tc` \ n' -> + zonkExpr e `thenNF_Tc` \ e' -> + returnNF_Tc (n', e') zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo" @@ -431,12 +488,10 @@ zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc) returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id new_ty src_loc) -zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList" - -zonkExpr (ExplicitListOut ty exprs) +zonkExpr (ExplicitList ty exprs) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> - returnNF_Tc (ExplicitListOut new_ty new_exprs) + returnNF_Tc (ExplicitList new_ty new_exprs) zonkExpr (ExplicitTuple exprs boxed) = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> @@ -449,12 +504,13 @@ zonkExpr (RecordConOut data_con con_expr rbinds) zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd" -zonkExpr (RecordUpdOut expr ty dicts rbinds) +zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds) = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty -> + zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty -> mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds) + returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds) zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig" zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" @@ -499,7 +555,7 @@ zonkExpr (DictApp expr dicts) ------------------------------------------------------------------------- -zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo +zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo zonkArithSeq (From e) = zonkExpr e `thenNF_Tc` \ new_e -> @@ -523,23 +579,29 @@ zonkArithSeq (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- zonkStmts :: [TcStmt] - -> NF_TcM s [TypecheckedStmt] + -> NF_TcM [TypecheckedStmt] zonkStmts [] = returnNF_Tc [] -zonkStmts [ReturnStmt expr] - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc [ReturnStmt new_expr] +zonkStmts (ParStmtOut bndrstmtss : stmts) + = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss -> + let new_binders = concat new_bndrss in + mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss -> + tcExtendGlobalValEnv new_binders $ + zonkStmts stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts) + where (bndrss, stmtss) = unzip bndrstmtss -zonkStmts (ExprStmt expr locn : stmts) +zonkStmts (ResultStmt expr locn : stmts) = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (ExprStmt new_expr locn : new_stmts) + returnNF_Tc (ResultStmt new_expr locn : new_stmts) -zonkStmts (GuardStmt expr locn : stmts) +zonkStmts (ExprStmt expr ty locn : stmts) = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (GuardStmt new_expr locn : new_stmts) + returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts) zonkStmts (LetStmt binds : stmts) = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> @@ -557,7 +619,7 @@ zonkStmts (BindStmt pat expr locn : stmts) ------------------------------------------------------------------------- -zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds +zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds zonkRbinds rbinds = mapNF_Tc zonk_rbind rbinds @@ -566,8 +628,14 @@ zonkRbinds rbinds = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkIdOcc field `thenNF_Tc` \ new_field -> returnNF_Tc (new_field, new_expr, pun) + +------------------------------------------------------------------------- +mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b) +mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r) +mapIPNameTc f (Linear n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Linear r) \end{code} + %************************************************************************ %* * \subsection[BackSubst-Pats]{Patterns} @@ -575,7 +643,7 @@ zonkRbinds rbinds %************************************************************************ \begin{code} -zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id) +zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id) zonkPat (WildPat ty) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> @@ -629,6 +697,12 @@ zonkPat (LitPat lit ty) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> returnNF_Tc (LitPat lit new_ty, emptyBag) +zonkPat (SigPat pat ty expr) + = zonkPat pat `thenNF_Tc` \ (new_pat, ids) -> + zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + zonkExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (SigPat new_pat new_ty new_expr, ids) + zonkPat (NPat lit ty expr) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> zonkExpr expr `thenNF_Tc` \ new_expr -> @@ -665,28 +739,34 @@ zonkPats (pat:pats) \begin{code} -zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl] +zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl] zonkForeignExports ls = mapNF_Tc zonkForeignExport ls -zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl) -zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) = +zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl) +zonkForeignExport (ForeignExport i hs_ty spec src_loc) = zonkIdOcc i `thenNF_Tc` \ i' -> - returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc) + returnNF_Tc (ForeignExport i' undefined spec src_loc) \end{code} \begin{code} -zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl] +zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl] zonkRules rs = mapNF_Tc zonkRule rs -zonkRule (RuleDecl name tyvars vars lhs rhs loc) - = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> - mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs -> - tcExtendGlobalValEnv new_bndrs $ +zonkRule (HsRule name act vars lhs rhs loc) + = mapNF_Tc zonk_bndr vars `thenNF_Tc` \ new_bndrs -> + tcExtendGlobalValEnv (filter isId new_bndrs) $ + -- Type variables don't need an envt + -- They are bound through the mutable mechanism zonkExpr lhs `thenNF_Tc` \ new_lhs -> zonkExpr rhs `thenNF_Tc` \ new_rhs -> - returnNF_Tc (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc) + returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc) -- I hate this map RuleBndr stuff + where + zonk_bndr (RuleBndr v) + | isId v = zonkIdBndr v + | otherwise = zonkTcTyVarToTyVar v -zonkRule (IfaceRuleDecl fun rule loc) - = returnNF_Tc (IfaceRuleDecl fun rule loc) +zonkRule (IfaceRuleOut fun rule) + = zonkIdOcc fun `thenNF_Tc` \ fun' -> + returnNF_Tc (IfaceRuleOut fun' rule) \end{code}