X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=9d2c3ee57f0215f84b9d52b1bf8954395a454cee;hb=a7526448bb4d9836032352c05837efb42ccb227b;hp=c45fab75016e498ee6aecec05770ff9a19053402;hpb=495ef8bd9ef30bffe50ea399b91e3ba09646b59a;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index c45fab7..9d2c3ee 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -24,12 +24,11 @@ module TcHsSyn ( mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsLet, - idsToMonoBinds, -- re-exported from TcEnv TcId, tcInstId, - zonkTopBinds, zonkId, zonkIdOcc, + zonkTopBinds, zonkId, zonkIdOcc, zonkExpr, zonkForeignExports, zonkRules ) where @@ -39,27 +38,20 @@ 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, isLocalId, setIdType, isIP, Id ) +import DataCon ( dataConWrapId ) +import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, + TcEnv, TcId, tcInstId ) import TcMonad -import TcType ( TcType, TcTyVar, - zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType +import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars ) -import Type ( mkTyVarTy, 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 Bag -import UniqFM import Outputable +import HscTypes ( TyThing(..) ) \end{code} @@ -124,12 +116,6 @@ 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 - -idsToMonoBinds :: [Id] -> TcMonoBinds -idsToMonoBinds ids - = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id)) - | id <- ids - ] \end{code} %************************************************************************ @@ -156,49 +142,48 @@ 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 + | not (isLocalId id) || isIP id + -- We're avoiding looking up superclass selectors -- and constructors; 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' -> + = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' -> let new_id = case maybe_id' of - Just id' -> id' - Nothing -> pprTrace "zonkIdOcc: " (ppr id) id + Just (AnId id') -> id' + other -> pprTrace "zonkIdOcc:" (ppr id) id 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 -> @@ -206,9 +191,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' -> @@ -230,7 +215,7 @@ zonkBinds binds \begin{code} ------------------------------------------------------------------------- zonkMonoBinds :: TcMonoBinds - -> NF_TcM s (TypecheckedMonoBinds, Bag Id) + -> NF_TcM (TypecheckedMonoBinds, Bag Id) zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag) @@ -281,9 +266,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} @@ -294,7 +281,7 @@ 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) = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) -> @@ -304,7 +291,7 @@ zonkMatch (Match _ pats _ grhss) ------------------------------------------------------------------------- zonkGRHSs :: TcGRHSs - -> NF_TcM s TypecheckedGRHSs + -> NF_TcM TypecheckedGRHSs zonkGRHSs (GRHSs grhss binds (Just ty)) = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> @@ -326,7 +313,7 @@ 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' -> @@ -336,11 +323,18 @@ zonkExpr (HsIPVar id) = 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 -> @@ -388,14 +382,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 fst new_binds) $ + zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsWith new_expr new_binds) where zonkIPBinds = mapNF_Tc zonkIPBind zonkIPBind (n, e) = + zonkIdBndr n `thenNF_Tc` \ n' -> zonkExpr e `thenNF_Tc` \ e' -> - returnNF_Tc (n, e') + returnNF_Tc (n', e') zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo" @@ -476,7 +472,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 -> @@ -500,10 +496,19 @@ zonkArithSeq (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- zonkStmts :: [TcStmt] - -> NF_TcM s [TypecheckedStmt] + -> NF_TcM [TypecheckedStmt] zonkStmts [] = returnNF_Tc [] +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 [ReturnStmt expr] = zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc [ReturnStmt new_expr] @@ -534,7 +539,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 @@ -552,7 +557,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 -> @@ -642,17 +647,17 @@ 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 :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl) zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) = zonkIdOcc i `thenNF_Tc` \ i' -> returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc) \end{code} \begin{code} -zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl] +zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl] zonkRules rs = mapNF_Tc zonkRule rs zonkRule (HsRule name tyvars vars lhs rhs loc)