X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMatches.lhs;h=658c3e804e75bf590e1f66c6a546ad7e2c434b11;hb=1bba522f5ec82c43abd2ba4e84127b9c915dd020;hp=c5900a81b3418143054f882e366a8bbda3f39775;hpb=18976e614fd90a8d81ced2c3e9cd8e38d72a1f40;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index c5900a8..658c3e8 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, noSigs, sigPatCtxt ) -import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs ) -import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv ) -import TcPat ( tcPat, polyPatSig ) -import TcType ( TcType, newTyVarTy, newTyVarTy_OpenKind ) +import TcMonoType ( kcHsSigType, kcTyVarScope, newSigTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt ) +import Inst ( LIE, plusLIE, emptyLIE, plusLIEs ) +import TcEnv ( tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars ) +import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig ) +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 ( 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) @@ -135,21 +135,20 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt returnTc match_and_lie else - -- If there are sig tve we must be careful *not* to use + -- 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 -> - tcExtendTyVarEnv sig_tyvars ( - tc_match tyvar_ty - ) `thenTc` \ (pat_ids, match_and_lie) -> + kcTyVarScope sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tv_kinds -> + newSigTyVars sig_tv_kinds `thenNF_Tc` \ sig_tyvars -> + tcExtendTyVarEnv sig_tyvars (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,7 +157,10 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt returnTc match_and_lie where - tc_match expexted_ty -- Any sig tyvars are in scope by now + 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) -> let @@ -174,7 +176,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 +192,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 +214,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 @@ -243,9 +245,9 @@ tcMatchPats [] expected_ty = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE) tcMatchPats (pat:pats) expected_ty - = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) -> - tcPat noSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) -> - tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) -> + = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) -> + tcPat tcPatBndr_NoSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) -> + tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) -> returnTc ( rhs_ty, pat':pats', lie_req `plusLIE` lie_reqs, @@ -288,7 +290,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) -> @@ -309,7 +311,7 @@ tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty = tcAddSrcLoc src_loc ( tcSetErrCtxt (stmtCtxt do_or_lc stmt) $ newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty -> - tcPat noSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) -> + tcPat tcPatBndr_NoSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) -> tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) -> returnTc (pat', exp', pat_lie `plusLIE` exp_lie, @@ -333,7 +335,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 +343,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 +352,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 +404,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")