X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=db9089c30e6b1873a65252b20c8dac04ba288a36;hb=389cca214f33a29646e08d57e3dca862140007b2;hp=40e1ca0bdbef91010bf6bc7e512c603e1550a141;hpb=c233954abc34df844eb6d8603a8754b75962dbfe;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 40e1ca0..db9089c 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -7,12 +7,12 @@ TcMatches: Typecheck some @Matches@ \begin{code} module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - matchCtxt, TcMatchCtxt(..), + TcMatchCtxt(..), tcStmts, tcDoStmts, tcBody, tcDoStmt, tcMDoStmt, tcGuardStmt ) where -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr ) +import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcMonoExpr, tcPolyExpr ) import HsSyn import TcRnMonad @@ -36,6 +36,8 @@ import SrcLoc import FastString import Control.Monad + +#include "HsVersions.h" \end{code} %************************************************************************ @@ -71,7 +73,7 @@ tcMatchesFun fun_name inf matches exp_ty -- This is one of two places places we call subFunTys -- The point is that if expected_y is a "hole", we want -- to make pat_tys and rhs_ty as "holes" too. - ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty -> + ; subFunTys doc n_pats exp_ty (Just (FunSigCtxt fun_name)) $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty matches } where @@ -92,11 +94,18 @@ tcMatchesCase :: TcMatchCtxt -- Case context -> TcM (MatchGroup TcId) -- Translated alternatives tcMatchesCase ctxt scrut_ty matches res_ty + | isEmptyMatchGroup matches + = -- Allow empty case expressions + do { -- Make sure we follow the invariant that res_ty is filled in + res_ty' <- refineBoxToTau res_ty + ; return (MatchGroup [] (mkFunTys [scrut_ty] res_ty')) } + + | otherwise = tcMatches ctxt [scrut_ty] res_ty matches tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId) tcMatchLambda match res_ty - = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty -> + = subFunTys doc n_pats res_ty Nothing $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty match where n_pats = matchGroupArity match @@ -141,7 +150,8 @@ data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module -> TcM (LHsExpr TcId) } tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _) - = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches + = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in + do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) } ------------- @@ -156,7 +166,7 @@ tcMatch ctxt pat_tys rhs_ty match where tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss) = add_match_ctxt match $ - do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $ + do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $ tc_grhss ctxt maybe_rhs_sig grhss ; return (Match pats' Nothing grhss') } @@ -164,17 +174,15 @@ tcMatch ctxt pat_tys rhs_ty match = tcGRHSs ctxt grhss rhs_ty -- No result signature -- Result type sigs are no longer supported - tc_grhss ctxt (Just res_sig) grhss rhs_ty - = do { addErr (ptext (sLit "Ignoring (deprecated) result type signature") - <+> ppr res_sig) - ; tcGRHSs ctxt grhss rhs_ty } + tc_grhss _ (Just {}) _ _ + = panic "tc_ghrss" -- Rejected by renamer -- For (\x -> e), tcExpr has already said "In the expresssion \x->e" -- so we don't want to add "In the lambda abstraction \x->e" add_match_ctxt match thing_inside = case mc_what ctxt of LambdaExpr -> thing_inside - m_ctxt -> addErrCtxt (matchCtxt m_ctxt match) thing_inside + m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside ------------- tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType @@ -259,7 +267,7 @@ tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId) tcBody body res_ty = do { traceTc (text "tcBody" <+> ppr res_ty) - ; body' <- tcPolyExpr body res_ty + ; body' <- tcMonoExpr body res_ty ; return body' } \end{code} @@ -303,7 +311,7 @@ tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside = do { (stmt', (stmts', thing)) <- setSrcSpan loc $ - addErrCtxt (stmtCtxt ctxt stmt) $ + addErrCtxt (pprStmtInCtxt ctxt stmt) $ stmt_chk ctxt stmt res_ty $ \ res_ty' -> popErrCtxt $ tcStmts ctxt stmt_chk stmts res_ty' $ @@ -318,9 +326,9 @@ tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside ; thing <- thing_inside res_ty ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) } -tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside - = do { (rhs', rhs_ty) <- tcInferRho rhs - ; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside +tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside + = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } tcGuardStmt _ stmt _ _ @@ -334,10 +342,10 @@ tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) -> TcStmtChecker -- A generator, pat <- rhs -tcLcStmt m_tc _ (BindStmt pat rhs _ _) res_ty thing_inside +tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty -> tcMonoExpr rhs (mkTyConApp m_tc [ty]) - ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } -- A boolean guard @@ -396,7 +404,7 @@ tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty return (usingExpr', Nothing) Just byExpr -> do -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a] - (byExpr', tTy) <- tcInferRho byExpr + (byExpr', tTy) <- tcInferRhoNC byExpr usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy))) return (usingExpr', Just byExpr') @@ -420,7 +428,7 @@ tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_in tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing) GroupBySomething eitherUsingExpr byExpr -> do -- We must infer a type such that byExpr :: t - (byExpr', tTy) <- tcInferRho byExpr + (byExpr', tTy) <- tcInferRhoNC byExpr -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]] let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy)) @@ -455,8 +463,8 @@ tcLcStmt _ _ stmt _ _ tcDoStmt :: TcStmtChecker -tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside - = do { (rhs', rhs_ty) <- tcInferRho rhs +tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside + = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- We should use type *inference* for the RHS computations, -- becuase of GADTs. -- do { pat <- rhs; } @@ -481,13 +489,13 @@ tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside then return noSyntaxExpr else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty) - ; (pat', thing) <- tcLamPat pat pat_ty new_res_ty thing_inside + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside - = do { (rhs', rhs_ty) <- tcInferRho rhs + = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty ; (then_op', new_res_ty) <- @@ -514,9 +522,9 @@ tcDoStmt _ stmt _ _ tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference -> TcStmtChecker -tcMDoStmt tc_rhs _ (BindStmt pat rhs _ _) res_ty thing_inside +tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', pat_ty) <- tc_rhs rhs - ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside @@ -586,12 +594,3 @@ checkArgs fun (MatchGroup (match1:matches) _) checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty \end{code} -\begin{code} -matchCtxt :: HsMatchContext Name -> Match Name -> SDoc -matchCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon) - 4 (pprMatch ctxt match) - -stmtCtxt :: HsStmtContext Name -> StmtLR Name Name -> SDoc -stmtCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon) - 4 (ppr stmt) -\end{code}