TypecheckedMatch, TypecheckedHsModule,
TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
+ TypecheckedMatchContext,
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
- idsToMonoBinds,
-- re-exported from TcEnv
- TcId, tcInstId,
+ TcId,
- zonkTopBinds, zonkId, zonkIdOcc,
+ zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
zonkForeignExports, zonkRules
) where
import HsSyn -- oodles of it
-- others:
-import Id ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id )
+import Id ( idName, idType, setIdType, Id )
import DataCon ( dataConWrapId )
-import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
- ValueEnv, TcId, tcInstId
+import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
+ TcEnv, TcId
)
import TcMonad
import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
)
-import Name ( isLocallyDefined )
import CoreSyn ( Expr )
-import CoreUnfold( unfoldingTemplate )
import BasicTypes ( RecFlag(..) )
import Bag
import Outputable
+import HscTypes ( TyThing(..) )
\end{code}
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
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}
%************************************************************************
\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 ->
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' ->
\begin{code}
-------------------------------------------------------------------------
zonkMonoBinds :: TcMonoBinds
- -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
+ -> NF_TcM (TypecheckedMonoBinds, Bag Id)
zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
%************************************************************************
\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) ->
-------------------------------------------------------------------------
zonkGRHSs :: TcGRHSs
- -> NF_TcM s TypecheckedGRHSs
+ -> NF_TcM TypecheckedGRHSs
zonkGRHSs (GRHSs grhss binds (Just ty))
= zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
%************************************************************************
\begin{code}
-zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
+zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
zonkExpr (HsVar id)
= zonkIdOcc id `thenNF_Tc` \ id' ->
zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
-zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
-zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
+zonkExpr (NegApp _) = panic "zonkExpr: NegApp"
+zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
zonkExpr (SectionL expr op)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
-------------------------------------------------------------------------
-zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
+zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
zonkArithSeq (From e)
= zonkExpr e `thenNF_Tc` \ new_e ->
-------------------------------------------------------------------------
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 locn : stmts)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (GuardStmt new_expr locn : new_stmts)
+ returnNF_Tc (ExprStmt new_expr locn : new_stmts)
zonkStmts (LetStmt binds : stmts)
= zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
-------------------------------------------------------------------------
-zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
+zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
zonkRbinds rbinds
= mapNF_Tc zonk_rbind 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 ->
\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 (HsRule name tyvars vars lhs rhs loc)
projects / ghc-hetmet.git / blobdiff