X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMatches.lhs;h=2914f618aa36d7a20533ab7bd51ce495168b968e;hb=92b67d724a648d1a2ddb371c8ecd3333b0a2ba18;hp=2e4e4e15ac037394569690035309a364e3e4e441;hpb=3af411e913102d8ec1234f32abe99374f077e3f7;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 2e4e4e1..2914f61 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -13,12 +13,12 @@ module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, import {-# SOURCE #-} TcExpr( tcExpr ) import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..), - MonoBinds(..), Stmt(..), HsMatchContext(..), + MonoBinds(..), Stmt(..), HsMatchContext(..), HsDoContext(..), pprMatch, getMatchLoc, pprMatchContext, isDoExpr, mkMonoBind, nullMonoBinds, collectSigTysFromPats ) import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedPat, RenamedHsType, - extractHsTyVars ) + RenamedMatchContext, extractHsTyVars ) import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat ) import TcMonad @@ -27,16 +27,15 @@ import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList ) import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv, tcExtendGlobalTyVars, tcInLocalScope ) import TcPat ( tcPat, tcMonoPatBndr, polyPatSig ) -import TcType ( TcType, newTyVarTy ) +import TcMType ( newTyVarTy, unifyFunTy, unifyTauTy ) +import TcType ( tyVarsOfType, isTauTy, mkFunTy, isOverloadedTy, + liftedTypeKind, openTypeKind ) import TcBinds ( tcBindsAndThen ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) -import TcUnify ( unifyFunTy, unifyTauTy ) import Name ( Name ) import TysWiredIn ( boolTy ) import Id ( idType ) import BasicTypes ( RecFlag(..) ) -import Type ( tyVarsOfType, isTauTy, mkFunTy, - liftedTypeKind, openTypeKind, splitSigmaTy ) import NameSet import VarSet import Var ( Id ) @@ -80,7 +79,7 @@ tcMatchesFun xve fun_name expected_ty matches@(first_match:_) -- may show up as something wrong with the (non-existent) type signature -- No need to zonk expected_ty, because unifyFunTy does that on the fly - tcMatches xve matches expected_ty (FunRhs fun_name) + tcMatches xve (FunRhs fun_name) matches expected_ty \end{code} @tcMatchesCase@ doesn't do the argument-count check because the @@ -95,26 +94,26 @@ tcMatchesCase :: [RenamedMatch] -- The case alternatives tcMatchesCase matches expr_ty = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty -> - tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) -> + tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenTc` \ (matches', lie) -> returnTc (scrut_ty, matches', lie) tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE) -tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaExpr +tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty \end{code} \begin{code} tcMatches :: [(Name,Id)] + -> RenamedMatchContext -> [RenamedMatch] -> TcType - -> HsMatchContext -> TcM ([TcMatch], LIE) -tcMatches xve matches expected_ty fun_or_case +tcMatches xve fun_or_case matches expected_ty = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) -> returnTc (matches, plusLIEs lies) where - tc_match match = tcMatch xve match expected_ty fun_or_case + tc_match match = tcMatch xve fun_or_case match expected_ty \end{code} @@ -126,13 +125,13 @@ tcMatches xve matches expected_ty fun_or_case \begin{code} tcMatch :: [(Name,Id)] + -> RenamedMatchContext -> RenamedMatch -> TcType -- Expected result-type of the Match. -- Early unification with this guy gives better error messages - -> HsMatchContext -> TcM (TcMatch, LIE) -tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt +tcMatch xve1 ctxt match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty = tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this; tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back @@ -150,7 +149,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt -- Typecheck the body tcExtendLocalValEnv xve1 $ - tcGRHSs grhss rhs_ty ctxt `thenTc` \ (grhss', lie) -> + tcGRHSs ctxt grhss rhs_ty `thenTc` \ (grhss', lie) -> returnTc ((pats', grhss'), lie) ) @@ -172,16 +171,16 @@ glue_on _ EmptyMonoBinds grhss = grhss -- The common case glue_on is_rec mbinds (GRHSs grhss binds ty) = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty -tcGRHSs :: RenamedGRHSs - -> TcType -> HsMatchContext +tcGRHSs :: RenamedMatchContext -> RenamedGRHSs + -> TcType -> TcM (TcGRHSs, LIE) -tcGRHSs (GRHSs grhss binds _) expected_ty ctxt +tcGRHSs ctxt (GRHSs grhss binds _) expected_ty = tcBindsAndThen glue_on binds (tc_grhss grhss) where tc_grhss grhss = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) -> - returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies) + returnTc (GRHSs grhss' EmptyBinds expected_ty, plusLIEs lies) tc_grhs (GRHS guarded locn) = tcAddSrcLoc locn $ @@ -224,9 +223,9 @@ tcMatchPats pats expected_ty thing_inside -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list -- might need (via lie_req2) something made available from an 'outer' -- pattern. But it's inconvenient to deal with, and I can't find an example - tcCheckExistentialPat pat_ids ex_tvs lie_avail lie_req1 rhs_ty `thenTc` \ (lie_req1', ex_binds) -> + tcCheckExistentialPat pat_ids ex_tvs lie_avail lie_req2 rhs_ty `thenTc` \ (lie_req2', ex_binds) -> - returnTc (result, lie_req1' `plusLIE` lie_req2, ex_binds) + returnTc (result, lie_req1 `plusLIE` lie_req2', ex_binds) tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a -- Find the not-already-in-scope signature type variables, @@ -283,8 +282,7 @@ tcCheckExistentialPat ids ex_tvs lie_avail lie_req result_ty where doc = text ("the existential context of a data constructor") tv_list = bagToList ex_tvs - not_overloaded id = case splitSigmaTy (idType id) of - (_, theta, _) -> null theta + not_overloaded id = not (isOverloadedTy (idType id)) tc_match_pats [] expected_ty = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE) @@ -337,7 +335,7 @@ tcStmts do_or_lc m_ty stmts tcStmtsAndThen :: (TcStmt -> thing -> thing) -- Combiner - -> HsMatchContext + -> RenamedMatchContext -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs -- elt_ty, where type of the comprehension is (m elt_ty) -> [RenamedStmt] @@ -384,7 +382,7 @@ tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside loop ((bndrs,stmts) : pairs) = tcStmtsAndThen - combine_par ListComp m_ty stmts + combine_par (DoCtxt ListComp) m_ty stmts -- Notice we pass on m_ty; the result type is used only -- to get escaping type variables for checkExistentialPat (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' -> @@ -396,19 +394,20 @@ tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside combine_par stmt (stmts, thing) = (stmt:stmts, thing) -- ExprStmt -tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp locn) thing_inside +tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside = tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( if isDoExpr do_or_lc then newTyVarTy openTypeKind `thenNF_Tc` \ any_ty -> - tcExpr exp (m any_ty) + tcExpr exp (m any_ty) `thenNF_Tc` \ (exp', lie) -> + returnTc (ExprStmt exp' any_ty locn, lie) else - tcExpr exp boolTy - ) `thenTc` \ (exp', stmt_lie) -> + tcExpr exp boolTy `thenNF_Tc` \ (exp', lie) -> + returnTc (ExprStmt exp' boolTy locn, lie) + ) `thenTc` \ (stmt', stmt_lie) -> thing_inside `thenTc` \ (thing, stmts_lie) -> - returnTc (combine (ExprStmt exp' locn) thing, - stmt_lie `plusLIE` stmts_lie) + returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie) -- Result statements @@ -451,25 +450,12 @@ sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1 \end{code} \begin{code} -matchCtxt CaseAlt match - = hang (ptext SLIT("In a case alternative:")) - 4 (pprMatch (True,empty) {-is_case-} match) - -matchCtxt (FunRhs fun) match - = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':']) - 4 (pprMatch (False, ppr_fun) {-not case-} match) - where - ppr_fun = ppr fun - -matchCtxt LambdaExpr match - = hang (ptext SLIT("In the lambda expression")) - 4 (pprMatch (True, empty) match) +matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match) +stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt) varyingArgsErr name matches = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)] lurkingRank2SigErr = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type") - -stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt) \end{code}