From c1500e4888be2341c0b6e6897f494766c86feba0 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 4 Jun 2008 14:51:15 +0000 Subject: [PATCH] Fix Trac #2310: result type signatures are not supported any more We have not supported "result type signatures" for some time, but using one in the wrong way caused a crash. This patch tidies it up. --- compiler/hsSyn/HsExpr.lhs | 12 ++++++++++ compiler/rename/RnBinds.lhs | 48 +++++++++++++++++--------------------- compiler/typecheck/TcArrows.lhs | 2 +- compiler/typecheck/TcMatches.lhs | 21 ++++------------- 4 files changed, 40 insertions(+), 43 deletions(-) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 542f166..78508c8 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -1116,3 +1116,15 @@ matchContextErrString (StmtCtxt (MDoExpr _)) = "'mdo' expression" matchContextErrString (StmtCtxt ListComp) = "list comprehension" matchContextErrString (StmtCtxt PArrComp) = "array comprehension" \end{code} + +\begin{code} +pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR) + => HsMatchContext idL -> Match idR -> SDoc +pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon) + 4 (pprMatch ctxt match) + +pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR) + => HsStmtContext idL -> StmtLR idL idR -> SDoc +pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon) + 4 (ppr stmt) +\end{code} diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 6ca3bdb..2ae46bf 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -22,10 +22,10 @@ import HsSyn import RdrHsSyn import RnHsSyn import TcRnMonad -import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch) +import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch) import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, - NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker, - patSigErr) + NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker + ) import RnEnv import PrelNames ( mkUnboundName ) @@ -792,31 +792,27 @@ rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars) -rnMatch' ctxt (Match pats maybe_rhs_sig grhss) - = - -- Deal with the rhs type signature - bindPatSigTyVarsFV rhs_sig_tys $ do - opt_PatternSignatures <- doptM Opt_PatternSignatures - (maybe_rhs_sig', ty_fvs) <- - case maybe_rhs_sig of - Nothing -> return (Nothing, emptyFVs) - Just ty | opt_PatternSignatures -> do (ty', ty_fvs) <- rnHsTypeFVs doc_sig ty - return (Just ty', ty_fvs) - | otherwise -> do addLocErr ty patSigErr - return (Nothing, emptyFVs) - - -- Now the main event - -- note that there are no local ficity decls for matches - rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do - (grhss', grhss_fvs) <- rnGRHSs ctxt grhss - - return (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) +rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) + = do { -- Result type signatures are no longer supported + case maybe_rhs_sig of + Nothing -> return () + Just ty -> addLocErr ty (resSigErr ctxt match) + + + -- Now the main event + -- note that there are no local ficity decls for matches + ; rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do + { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss + + ; return (Match pats' Nothing grhss', grhss_fvs) }} -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs where - rhs_sig_tys = case maybe_rhs_sig of - Nothing -> [] - Just ty -> [ty] - doc_sig = text "In a result type-signature" + +resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc +resSigErr ctxt match ty + = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty) + , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches") + , pprMatchInCtxt ctxt match ] \end{code} diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index bc19d69..082f9da 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -180,7 +180,7 @@ tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] _)) (cmd_stk, res_ty) - = addErrCtxt (matchCtxt match_ctxt match) $ + = addErrCtxt (pprMatchInCtxt match_ctxt match) $ do { -- Check the cmd stack is big enough ; checkTc (lengthAtLeast cmd_stk n_pats) diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 40e1ca0..b16c8d3 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -7,7 +7,7 @@ TcMatches: Typecheck some @Matches@ \begin{code} module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - matchCtxt, TcMatchCtxt(..), + TcMatchCtxt(..), tcStmts, tcDoStmts, tcBody, tcDoStmt, tcMDoStmt, tcGuardStmt ) where @@ -164,17 +164,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 @@ -303,7 +301,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' $ @@ -586,12 +584,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} -- 1.7.10.4