X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=93149e4646211b07c9789721cee8cae8730562e6;hb=ae45ff0e9831a0dc862a5d68d03e355d7e323c62;hp=ba69475148746d05e5a9eff16c62afae0896fe55;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index ba69475..93149e4 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -7,6 +7,8 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} +#include "HsVersions.h" + module TcHsSyn ( TcIdBndr(..), TcIdOcc(..), @@ -25,13 +27,13 @@ module TcHsSyn ( mkHsTyApp, mkHsDictApp, mkHsTyLam, mkHsDictLam, - tcIdType, + tcIdType, tcIdTyVars, zonkBinds, zonkDictBinds ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -- friends: import HsSyn -- oodles of it @@ -44,17 +46,16 @@ import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids import Name ( Name{--O only-} ) import TcMonad hiding ( rnMtoTcM ) import TcType ( TcType(..), TcMaybe, TcTyVar(..), - zonkTcTypeToType, zonkTcTyVarToTyVar, - tcInstType + zonkTcTypeToType, zonkTcTyVarToTyVar ) import Usage ( 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 ) + TyVarEnv(..), growTyVarEnvList, emptyTyVarSet ) +import TysPrim ( voidTy ) import Unique ( Unique ) -- instances import UniqFM import PprStyle @@ -85,7 +86,7 @@ type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s) 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) @@ -97,7 +98,7 @@ type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat 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 @@ -122,9 +123,10 @@ mkHsDictLam dicts expr = DictLam dicts expr 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 @@ -396,17 +398,14 @@ zonkExpr te ve (HsIf e1 e2 e3 src_loc) 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) -> @@ -558,27 +557,36 @@ zonkQuals te ve (LetQual binds : quals) 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