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

@@ -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}

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}
 
 

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)

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}