X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMatches.lhs;h=edebb87d88ef178e2f3e11679ae5c399e3ae4e41;hb=77a8c0dbd5c5ad90fe483cb9ddc2b6ef36d3f4d8;hp=9722bfe980fb302d46f1148f600a6cee4b8f9fee;hpb=bca10d12f3bfa9f826d7a96b907800994206b966;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 9722bfe..edebb87 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -1,4 +1,4 @@ -\% +% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcMatches]{Typecheck some @Matches@} @@ -12,17 +12,18 @@ import {-# SOURCE #-} TcExpr( tcExpr ) import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..), MonoBinds(..), StmtCtxt(..), Stmt(..), - pprMatch, getMatchLoc + pprMatch, getMatchLoc, consLetStmt, + mkMonoBind, collectSigTysFromPats ) import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt ) import TcHsSyn ( TcMatch, TcGRHSs, TcStmt ) import TcMonad -import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsType, sigPatCtxt ) +import TcMonoType ( kcHsSigType, kcTyVarScope, checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt ) import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs ) -import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars ) +import TcEnv ( tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars, tcGetGlobalTyVars ) import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig ) -import TcType ( TcType, newTyVarTy, newTyVarTy_OpenKind, zonkTcTyVars ) +import TcType ( TcType, newTyVarTy ) import TcBinds ( tcBindsAndThen ) import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) import TcUnify ( unifyFunTy, unifyTauTy ) @@ -30,10 +31,9 @@ import Name ( Name ) import TysWiredIn ( boolTy ) import BasicTypes ( RecFlag(..) ) -import Type ( Kind, tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind ) +import Type ( Kind, tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind, openTypeKind ) import VarSet import Var ( Id ) -import Util import Bag import Outputable import List ( nub ) @@ -88,7 +88,7 @@ tcMatchesCase :: [RenamedMatch] -- The case alternatives LIE) tcMatchesCase matches expr_ty - = newTyVarTy_OpenKind `thenNF_Tc` \ scrut_ty -> + = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty -> tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) -> returnTc (scrut_ty, matches', lie) @@ -138,18 +138,18 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt -- If there are sig tvs we must be careful *not* to use -- expected_ty right away, else we'll unify with tyvars free -- in the envt. So invent a fresh tyvar and use that instead - newTyVarTy_OpenKind `thenNF_Tc` \ tyvar_ty -> + newTyVarTy openTypeKind `thenNF_Tc` \ tyvar_ty -> -- Extend the tyvar env and check the match itself - mapNF_Tc tcHsTyVar sig_tvs `thenNF_Tc` \ sig_tyvars -> + kcTyVarScope sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars -> tcExtendTyVarEnv sig_tyvars ( - tc_match tyvar_ty + tc_match tyvar_ty ) `thenTc` \ (pat_ids, match_and_lie) -> -- Check that the scoped type variables from the patterns -- have not been constrained tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids) ( - checkSigTyVars sig_tyvars + checkSigTyVars sig_tyvars emptyVarSet ) `thenTc_` -- *Now* we're free to unify with expected_ty @@ -158,6 +158,9 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt returnTc match_and_lie where + sig_tys = case maybe_rhs_sig of { Just t -> [t]; Nothing -> [] } + ++ collectSigTysFromPats pats + tc_match expected_ty -- Any sig tyvars are in scope by now = -- STEP 1: Typecheck the patterns tcMatchPats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) -> @@ -174,7 +177,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt -- STEP 3: Unify with the rhs type signature if any (case maybe_rhs_sig of Nothing -> returnTc () - Just sig -> tcHsType sig `thenTc` \ sig_ty -> + Just sig -> tcHsSigType sig `thenTc` \ sig_ty -> -- Check that the signature isn't a polymorphic one, which -- we don't permit (at present, anyway) @@ -190,7 +193,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt -- STEP 5: Check for existentially bound type variables tcExtendGlobalTyVars (tyVarsOfType rhs_ty) ( tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids) $ - checkSigTyVars ex_tv_list `thenTc` \ zonked_ex_tvs -> + checkSigTyVars ex_tv_list emptyVarSet `thenTc` \ zonked_ex_tvs -> tcSimplifyAndCheck (text ("the existential context of a data constructor")) (mkVarSet zonked_ex_tvs) @@ -212,7 +215,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt -- glue_on just avoids stupid dross glue_on _ EmptyMonoBinds grhss = grhss -- The common case glue_on is_rec mbinds (GRHSs grhss binds ty) - = GRHSs grhss (MonoBind mbinds [] is_rec `ThenBinds` binds) ty + = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty tcGRHSs :: RenamedGRHSs -> TcType -> StmtCtxt @@ -288,7 +291,7 @@ tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty tcAddSrcLoc src_loc ( tcSetErrCtxt (stmtCtxt do_or_lc stmt) $ -- exp has type (m tau) for some tau (doesn't matter what) - newTyVarTy_OpenKind `thenNF_Tc` \ any_ty -> + newTyVarTy openTypeKind `thenNF_Tc` \ any_ty -> tcExpr exp (m any_ty) ) `thenTc` \ (exp', exp_lie) -> tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) -> @@ -333,7 +336,7 @@ tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $ tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids) $ - checkSigTyVars pat_tv_list `thenTc` \ zonked_pat_tvs -> + checkSigTyVars pat_tv_list emptyVarSet `thenTc` \ zonked_pat_tvs -> tcSimplifyAndCheck (text ("the existential context of a data constructor")) @@ -341,8 +344,7 @@ tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) -> returnTc (BindStmt pat' exp' src_loc : - LetStmt (MonoBind dict_binds [] Recursive) : - stmts', + consLetStmt (mkMonoBind dict_binds [] Recursive) stmts', lie_req `plusLIE` final_lie) tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty @@ -351,7 +353,7 @@ tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty binds (tcStmts do_or_lc m stmts elt_ty) where - combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts' + combine is_rec binds' stmts' = consLetStmt (mkMonoBind binds' [] is_rec) stmts' isDoStmt DoStmt = True @@ -403,7 +405,7 @@ stmtCtxt do_or_lc stmt where what = case do_or_lc of ListComp -> ptext SLIT("a list-comprehension qualifier") - DoStmt -> ptext SLIT("a do statement:") + DoStmt -> ptext SLIT("a do statement") PatBindRhs -> thing <+> ptext SLIT("a pattern binding") FunRhs f -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f) CaseAlt -> thing <+> ptext SLIT("a case alternative")