Commit c1500e48 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent e1cae123
...@@ -1116,3 +1116,15 @@ matchContextErrString (StmtCtxt (MDoExpr _)) = "'mdo' expression" ...@@ -1116,3 +1116,15 @@ matchContextErrString (StmtCtxt (MDoExpr _)) = "'mdo' expression"
matchContextErrString (StmtCtxt ListComp) = "list comprehension" matchContextErrString (StmtCtxt ListComp) = "list comprehension"
matchContextErrString (StmtCtxt PArrComp) = "array comprehension" matchContextErrString (StmtCtxt PArrComp) = "array comprehension"
\end{code} \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}
...@@ -22,10 +22,10 @@ import HsSyn ...@@ -22,10 +22,10 @@ import HsSyn
import RdrHsSyn import RdrHsSyn
import RnHsSyn import RnHsSyn
import TcRnMonad import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch) import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch)
import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat,
NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker, NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker
patSigErr) )
import RnEnv import RnEnv
import PrelNames ( mkUnboundName ) import PrelNames ( mkUnboundName )
...@@ -792,31 +792,27 @@ rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) ...@@ -792,31 +792,27 @@ rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) rnMatch ctxt = wrapLocFstM (rnMatch' ctxt)
rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars) rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars)
rnMatch' ctxt (Match pats maybe_rhs_sig grhss) rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
= = do { -- Result type signatures are no longer supported
-- Deal with the rhs type signature case maybe_rhs_sig of
bindPatSigTyVarsFV rhs_sig_tys $ do Nothing -> return ()
opt_PatternSignatures <- doptM Opt_PatternSignatures Just ty -> addLocErr ty (resSigErr ctxt match)
(maybe_rhs_sig', ty_fvs) <-
case maybe_rhs_sig of
Nothing -> return (Nothing, emptyFVs) -- Now the main event
Just ty | opt_PatternSignatures -> do (ty', ty_fvs) <- rnHsTypeFVs doc_sig ty -- note that there are no local ficity decls for matches
return (Just ty', ty_fvs) ; rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do
| otherwise -> do addLocErr ty patSigErr { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
return (Nothing, emptyFVs)
; return (Match pats' Nothing grhss', grhss_fvs) }}
-- 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)
-- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
where where
rhs_sig_tys = case maybe_rhs_sig of
Nothing -> [] resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc
Just ty -> [ty] resSigErr ctxt match ty
doc_sig = text "In a result type-signature" = 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} \end{code}
......
...@@ -180,7 +180,7 @@ tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) ...@@ -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))] _)) tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] _))
(cmd_stk, res_ty) (cmd_stk, res_ty)
= addErrCtxt (matchCtxt match_ctxt match) $ = addErrCtxt (pprMatchInCtxt match_ctxt match) $
do { -- Check the cmd stack is big enough do { -- Check the cmd stack is big enough
; checkTc (lengthAtLeast cmd_stk n_pats) ; checkTc (lengthAtLeast cmd_stk n_pats)
......
...@@ -7,7 +7,7 @@ TcMatches: Typecheck some @Matches@ ...@@ -7,7 +7,7 @@ TcMatches: Typecheck some @Matches@
\begin{code} \begin{code}
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
matchCtxt, TcMatchCtxt(..), TcMatchCtxt(..),
tcStmts, tcDoStmts, tcBody, tcStmts, tcDoStmts, tcBody,
tcDoStmt, tcMDoStmt, tcGuardStmt tcDoStmt, tcMDoStmt, tcGuardStmt
) where ) where
...@@ -164,17 +164,15 @@ tcMatch ctxt pat_tys rhs_ty match ...@@ -164,17 +164,15 @@ tcMatch ctxt pat_tys rhs_ty match
= tcGRHSs ctxt grhss rhs_ty -- No result signature = tcGRHSs ctxt grhss rhs_ty -- No result signature
-- Result type sigs are no longer supported -- Result type sigs are no longer supported
tc_grhss ctxt (Just res_sig) grhss rhs_ty tc_grhss _ (Just {}) _ _
= do { addErr (ptext (sLit "Ignoring (deprecated) result type signature") = panic "tc_ghrss" -- Rejected by renamer
<+> ppr res_sig)
; tcGRHSs ctxt grhss rhs_ty }
-- For (\x -> e), tcExpr has already said "In the expresssion \x->e" -- 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" -- so we don't want to add "In the lambda abstraction \x->e"
add_match_ctxt match thing_inside add_match_ctxt match thing_inside
= case mc_what ctxt of = case mc_what ctxt of
LambdaExpr -> thing_inside 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 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType
...@@ -303,7 +301,7 @@ tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside ...@@ -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 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
= do { (stmt', (stmts', thing)) <- = do { (stmt', (stmts', thing)) <-
setSrcSpan loc $ setSrcSpan loc $
addErrCtxt (stmtCtxt ctxt stmt) $ addErrCtxt (pprStmtInCtxt ctxt stmt) $
stmt_chk ctxt stmt res_ty $ \ res_ty' -> stmt_chk ctxt stmt res_ty $ \ res_ty' ->
popErrCtxt $ popErrCtxt $
tcStmts ctxt stmt_chk stmts res_ty' $ tcStmts ctxt stmt_chk stmts res_ty' $
...@@ -586,12 +584,3 @@ checkArgs fun (MatchGroup (match1:matches) _) ...@@ -586,12 +584,3 @@ checkArgs fun (MatchGroup (match1:matches) _)
checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty
\end{code} \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}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment