checker.
\begin{code}
+#include "HsVersions.h"
+
module TcHsSyn (
- TcIdBndr(..), TcIdOcc(..),
+ SYN_IE(TcIdBndr), TcIdOcc(..),
- TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..),
- TcExpr(..), TcGRHSsAndBinds(..), TcGRHS(..), TcMatch(..),
- TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcRecordBinds(..),
- TcHsModule(..),
+ SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcPat),
+ SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch),
+ SYN_IE(TcQual), SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds),
+ SYN_IE(TcHsModule),
- TypecheckedHsBinds(..), TypecheckedBind(..),
- TypecheckedMonoBinds(..), TypecheckedPat(..),
- TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..),
- TypecheckedQual(..), TypecheckedStmt(..),
- TypecheckedMatch(..), TypecheckedHsModule(..),
- TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
- TypecheckedRecordBinds(..),
+ SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedBind),
+ SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat),
+ SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo),
+ SYN_IE(TypecheckedQual), SYN_IE(TypecheckedStmt),
+ SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule),
+ SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
+ SYN_IE(TypecheckedRecordBinds),
mkHsTyApp, mkHsDictApp,
mkHsTyLam, mkHsDictLam,
- tcIdType,
+ tcIdType, tcIdTyVars,
zonkBinds,
zonkDictBinds
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-- friends:
import HsSyn -- oodles of it
-import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids
- DictVar(..), idType,
- IdEnv(..), growIdEnvList, lookupIdEnv
+import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids
+ SYN_IE(DictVar), idType,
+ SYN_IE(IdEnv), growIdEnvList, lookupIdEnv
)
-- others:
import Name ( Name{--O only-} )
import TcMonad hiding ( rnMtoTcM )
-import TcType ( TcType(..), TcMaybe, TcTyVar(..),
- zonkTcTypeToType, zonkTcTyVarToTyVar,
- tcInstType
+import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
+ zonkTcTypeToType, zonkTcTyVarToTyVar
)
-import Usage ( UVar(..) )
+import Usage ( SYN_IE(UVar) )
import Util ( zipEqual, panic, pprPanic, pprTrace )
import PprType ( GenType, GenTyVar ) -- instances
-import Type ( mkTyVarTy )
+import Type ( mkTyVarTy, tyVarsOfType )
import TyVar ( GenTyVar {- instances -},
- TyVarEnv(..), growTyVarEnvList ) -- instances
-import TysWiredIn ( voidTy )
+ SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet )
+import TysPrim ( voidTy )
import Unique ( Unique ) -- instances
import UniqFM
import PprStyle
type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
-type TcQual s = Qual (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcQual s = Qualifier (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TypecheckedBind = Bind TyVar UVar Id TypecheckedPat
type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat
type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat
-type TypecheckedQual = Qual TyVar UVar Id TypecheckedPat
+type TypecheckedQual = Qualifier TyVar UVar Id TypecheckedPat
type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat
type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat
type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat
tcIdType :: TcIdOcc s -> TcType s
tcIdType (TcId id) = idType id
tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id)
-\end{code}
-
+tcIdTyVars (TcId id) = tyVarsOfType (idType id)
+tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables
+\end{code}
\begin{code}
instance Eq (TcIdOcc s) where
zonkExpr te ve (HsLet binds expr)
= zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
- zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
+ zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
zonkExpr te ve (HsDo _ _) = panic "zonkExpr te ve:HsDo"
-zonkExpr te ve (HsDoOut stmts m_id mz_id src_loc)
+zonkExpr te ve (HsDoOut stmts then_id zero_id src_loc)
= zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (HsDoOut new_stmts m_new mz_new src_loc)
- where
- m_new = zonkIdOcc ve m_id
- mz_new = zonkIdOcc ve mz_id
+ returnNF_Tc (HsDoOut new_stmts (zonkIdOcc ve then_id) (zonkIdOcc ve zero_id) src_loc)
zonkExpr te ve (ListComp expr quals)
= zonkQuals te ve quals `thenNF_Tc` \ (new_quals, new_ve) ->
zonkStmts :: TyVarEnv Type -> IdEnv Id
-> [TcStmt s] -> NF_TcM s [TypecheckedStmt]
-zonkStmts te ve []
- = returnNF_Tc []
+zonkStmts te ve [] = returnNF_Tc []
+
+zonkStmts te ve [ExprStmt expr locn]
+ = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc [ExprStmt new_expr locn]
-zonkStmts te ve (BindStmt pat expr src_loc : stmts)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
- zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+zonkStmts te ve (ExprStmtOut expr locn a b : stmts)
+ = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType te a `thenNF_Tc` \ new_a ->
+ zonkTcTypeToType te b `thenNF_Tc` \ new_b ->
+ zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (ExprStmtOut new_expr locn new_a new_b : new_stmts)
+
+zonkStmts te ve (LetStmt binds : stmts)
+ = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
+ zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (LetStmt new_binds : new_stmts)
+
+zonkStmts te ve (BindStmtOut pat expr locn a b : stmts)
+ = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
+ zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType te a `thenNF_Tc` \ new_a ->
+ zonkTcTypeToType te b `thenNF_Tc` \ new_b ->
let
new_ve = extend_ve ve ids
in
zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (BindStmt new_pat new_expr src_loc : new_stmts)
+ returnNF_Tc (BindStmtOut new_pat new_expr locn new_a new_b : new_stmts)
-zonkStmts te ve (ExprStmt expr src_loc : stmts)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (ExprStmt new_expr src_loc : new_stmts)
-zonkStmts te ve (LetStmt binds : stmts)
- = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
- zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (LetStmt new_binds : new_stmts)
-------------------------------------------------------------------------
zonkRbinds :: TyVarEnv Type -> IdEnv Id