Remove m_type from Match (#14313)

this is a remains from supporting Result Type Signaturs in the ancient
past.

Differential Revision: https://phabricator.haskell.org/D4066

12 files changed, 23 insertions, 79 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index f9e5ca1958..bffb2028c3 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -762,8 +762,7 @@ cvtClause ctxt (Clause ps body wheres)
         ; pps <- mapM wrap_conpat ps'
         ; g'  <- cvtGuard body
         ; ds' <- cvtLocalDecs (text "a where clause") wheres
-        ; returnL $ Hs.Match ctxt pps Nothing
-                             (GRHSs g' (noLoc ds')) }
+        ; returnL $ Hs.Match ctxt pps (GRHSs g' (noLoc ds')) }
 
 
 -------------------------------------------------------------------
@@ -1001,8 +1000,7 @@ cvtMatch ctxt (TH.Match p body decs)
             _       -> wrap_conpat p'
         ; g' <- cvtGuard body
         ; decs' <- cvtLocalDecs (text "a where clause") decs
-        ; returnL $ Hs.Match ctxt [lp] Nothing
-                             (GRHSs g' (noLoc decs')) }
+        ; returnL $ Hs.Match ctxt [lp] (GRHSs g' (noLoc decs')) }
 
 cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 5ee359e6b3..1cfaa79af5 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1413,10 +1413,6 @@ data Match p body
         m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)),
           -- See note [m_ctxt in Match]
         m_pats :: [LPat p], -- The patterns
-        m_type :: (Maybe (LHsType p)),
-                                 -- A type signature for the result of the match
-                                 -- Nothing after typechecking
-                                 -- NB: No longer supported
         m_grhss :: (GRHSs p body)
   }
 deriving instance (Data body,DataId p) => Data (Match p body)
@@ -1540,7 +1536,6 @@ pprMatch :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
          => Match idR body -> SDoc
 pprMatch match
   = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
-        , nest 2 ppr_maybe_ty
         , nest 2 (pprGRHSs ctxt (m_grhss match)) ]
   where
     ctxt = m_ctxt match
@@ -1570,10 +1565,6 @@ pprMatch match
 
     (pat1:pats1) = m_pats match
     (pat2:pats2) = pats1
-    ppr_maybe_ty = case m_type match of
-                        Just ty -> dcolon <+> ppr ty
-                        Nothing -> empty
-
 
 pprGRHSs :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
          => HsMatchContext idL -> GRHSs idR body -> SDoc
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 8ba143e50e..3c1726b306 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -148,7 +148,7 @@ mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id))
               -> LMatch id (Located (body id))
 mkSimpleMatch ctxt pats rhs
   = L loc $
-    Match { m_ctxt = ctxt, m_pats = pats, m_type = Nothing
+    Match { m_ctxt = ctxt, m_pats = pats
           , m_grhss = unguardedGRHSs rhs }
   where
     loc = case pats of
@@ -774,7 +774,6 @@ mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p
 mkMatch ctxt pats expr lbinds
   = noLoc (Match { m_ctxt  = ctxt
                  , m_pats  = map paren pats
-                 , m_type  = Nothing
                  , m_grhss = GRHSs (unguardedRHS noSrcSpan expr) lbinds })
   where
     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index d13b9c0b7f..d4a26895d6 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1692,10 +1692,6 @@ opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) }
         : {- empty -}                   { ([],Nothing) }
         | '::' sigtype                  { ([mu AnnDcolon $1],Just $2) }
 
-opt_asig :: { ([AddAnn],Maybe (LHsType GhcPs)) }
-        : {- empty -}                   { ([],Nothing) }
-        | '::' atype                    { ([mu AnnDcolon $1],Just $2) }
-
 opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }
              : {- empty -}              { ([], Nothing) }
              | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }
@@ -2385,13 +2381,12 @@ infixexp_top :: { LHsExpr GhcPs }
                                          [mj AnnVal $2] }
 
 exp10_top :: { LHsExpr GhcPs }
-        : '\\' apat apats opt_asig '->' exp
+        : '\\' apat apats '->' exp
                    {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
                             [sLL $1 $> $ Match { m_ctxt = LambdaExpr
                                                , m_pats = $2:$3
-                                               , m_type = snd $4
-                                               , m_grhss = unguardedGRHSs $6 }]))
-                          (mj AnnLam $1:mu AnnRarrow $5:(fst $4)) }
+                                               , m_grhss = unguardedGRHSs $5 }]))
+                          [mj AnnLam $1, mu AnnRarrow $4] }
 
         | 'let' binds 'in' exp          {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
                                                (mj AnnLet $1:mj AnnIn $3
@@ -2814,11 +2809,10 @@ alts1   :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
         | alt                   { sL1 $1 ([],[$1]) }
 
 alt     :: { LMatch GhcPs (LHsExpr GhcPs) }
-        : pat opt_asig alt_rhs  {%ams (sLL $1 $> (Match { m_ctxt = CaseAlt
-                                                        , m_pats = [$1]
-                                                        , m_type = snd $2
-                                                        , m_grhss = snd $ unLoc $3 }))
-                                      (fst $2 ++ (fst $ unLoc $3))}
+        : pat alt_rhs  {%ams (sLL $1 $> (Match { m_ctxt = CaseAlt
+                                               , m_pats = [$1]
+                                               , m_grhss = snd $ unLoc $2 }))
+                                      (fst $ unLoc $2)}
 
 alt_rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }
         : ralt wherebinds           { sLL $1 $> (fst $ unLoc $2,
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 4eabb66b43..126e92e7ad 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -517,12 +517,12 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
                wrongNameBindingErr loc decl
            ; match <- case details of
                PrefixCon pats -> return $ Match { m_ctxt = ctxt, m_pats = pats
-                                                , m_type = Nothing, m_grhss = rhs }
+                                                , m_grhss = rhs }
                    where
                      ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict }
 
                InfixCon p1 p2 -> return $ Match { m_ctxt = ctxt, m_pats = [p1, p2]
-                                                , m_type = Nothing, m_grhss = rhs }
+                                                , m_grhss = rhs }
                    where
                      ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }
 
@@ -944,12 +944,12 @@ checkValDef msg _strictness lhs (Just sig) grhss
   = checkPatBind msg (L (combineLocs lhs sig)
                         (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
 
-checkValDef msg strictness lhs opt_sig g@(L l (_,grhss))
+checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
             Just (fun, is_infix, pats, ann) ->
               checkFunBind msg strictness ann (getLoc lhs)
-                           fun is_infix pats opt_sig (L l grhss)
+                           fun is_infix pats (L l grhss)
             Nothing -> checkPatBind msg lhs g }
 
 checkFunBind :: SDoc
@@ -959,10 +959,9 @@ checkFunBind :: SDoc
              -> Located RdrName
              -> LexicalFixity
              -> [LHsExpr GhcPs]
-             -> Maybe (LHsType GhcPs)
              -> Located (GRHSs GhcPs (LHsExpr GhcPs))
              -> P ([AddAnn],HsBind GhcPs)
-checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
   = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
         -- Add back the annotations stripped from any HsPar values in the lhs
@@ -972,7 +971,6 @@ checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span gr
                                                          , mc_fixity = is_infix
                                                          , mc_strictness = strictness }
                                        , m_pats = ps
-                                       , m_type = opt_sig
                                        , m_grhss = grhss })])
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index f43715eaf4..bf3ee26ae7 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -54,7 +54,6 @@ import Digraph          ( SCC(..) )
 import Bag
 import Util
 import Outputable
-import FastString
 import UniqSet
 import Maybes           ( orElse )
 import qualified GHC.LanguageExtensions as LangExt
@@ -1159,15 +1158,8 @@ rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
          -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
          -> Match GhcPs (Located (body GhcPs))
          -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)
-rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
-                                  , m_type = maybe_rhs_sig, m_grhss = grhss })
-  = do  {       -- Result type signatures are no longer supported
-          case maybe_rhs_sig of
-                Nothing -> return ()
-                Just (L loc ty) -> addErrAt loc (resSigErr match ty)
-
-               -- Now the main event
-               -- Note that there are no local fixity decls for matches
+rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
+  = do  { -- Note that there are no local fixity decls for matches
         ; rnPats ctxt pats      $ \ pats' -> do
         { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
         ; let mf' = case (ctxt, mf) of
@@ -1175,7 +1167,7 @@ rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
                                             -> mf { mc_fun = L lf funid }
                       _                     -> ctxt
         ; return (Match { m_ctxt = mf', m_pats = pats'
-                        , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
+                        , m_grhss = grhss'}, grhss_fvs ) }}
 
 emptyCaseErr :: HsMatchContext Name -> SDoc
 emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
@@ -1186,15 +1178,6 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
                 LambdaExpr -> text "\\case expression"
                 _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt
 
-
-resSigErr :: Outputable body
-          => Match GhcPs body -> HsType GhcPs -> SDoc
-resSigErr match ty
-   = vcat [ text "Illegal result type signature" <+> quotes (ppr ty)
-          , nest 2 $ ptext (sLit
-                 "Result signatures are no longer supported in pattern matches")
-          , pprMatchInCtxt match ]
-
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index d456438671..96750f7260 100644
--- a/compiler/typecheck/TcArrows.hs
+++ b/compiler/typecheck/TcArrows.hs
@@ -253,7 +253,7 @@ tc_cmd env
                              tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
 
         ; let match' = L mtch_loc (Match { m_ctxt = LambdaExpr, m_pats = pats'
-                                         , m_type = Nothing, m_grhss = grhss' })
+                                         , m_grhss = grhss' })
               arg_tys = map hsLPatType pats'
               cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys
                                   , mg_res_ty = res_ty, mg_origin = origin })
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 0303ec6c33..2b56a78a91 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -570,8 +570,7 @@ zonkMatch :: ZonkEnv
 zonkMatch env zBody (L loc match@(Match { m_pats = pats, m_grhss = grhss }))
   = do  { (env1, new_pats) <- zonkPats env pats
         ; new_grhss <- zonkGRHSs env1 zBody grhss
-        ; return (L loc (match { m_pats = new_pats, m_type = Nothing
-                               , m_grhss = new_grhss })) }
+        ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
 
 -------------------------------------------------------------------------
 zonkGRHSs :: ZonkEnv
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index 89d34f5a60..acc33d9ff4 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -235,19 +235,12 @@ tcMatch ctxt pat_tys rhs_ty match
   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
   where
     tc_match ctxt pat_tys rhs_ty
-             match@(Match { m_pats = pats, m_type = maybe_rhs_sig, m_grhss = grhss })
+             match@(Match { m_pats = pats, m_grhss = grhss })
       = add_match_ctxt match $
         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
-                                tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
+                                tcGRHSs ctxt grhss rhs_ty
            ; return (Match { m_ctxt = mc_what ctxt, m_pats = pats'
-                           , m_type = Nothing, m_grhss = grhss' }) }
-
-    tc_grhss ctxt Nothing grhss rhs_ty
-      = tcGRHSs ctxt grhss rhs_ty       -- No result signature
-
-        -- Result type sigs are no longer supported
-    tc_grhss _ (Just {}) _ _
-      = panic "tc_ghrss"        -- Rejected by renamer
+                           , m_grhss = grhss' }) }
 
         -- For (\x -> e), tcExpr has already said "In the expression \x->e"
         -- so we don't want to add "In the lambda abstraction \x->e"
diff --git a/testsuite/tests/rename/should_fail/T2310.hs b/testsuite/tests/rename/should_fail/T2310.hs
deleted file mode 100644
index 10c9cbc72a..0000000000
--- a/testsuite/tests/rename/should_fail/T2310.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-{-# OPTIONS_GHC -XScopedTypeVariables #-}
-
-module Foo where
-
-foo = let c = \ (x :: a) -> (x :: a) in co
diff --git a/testsuite/tests/rename/should_fail/T2310.stderr b/testsuite/tests/rename/should_fail/T2310.stderr
deleted file mode 100644
index 1ac633f290..0000000000
--- a/testsuite/tests/rename/should_fail/T2310.stderr
+++ /dev/null
@@ -1,5 +0,0 @@
-
-T2310.hs:5:41: error:
-    • Variable not in scope: co
-    • Perhaps you meant one of these:
-        ‘c’ (line 5), ‘cos’ (imported from Prelude)
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index b0863725e9..2a85d89401 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -60,7 +60,6 @@ test('rnfail056', normal, compile_fail, [''])
 test('rnfail057', normal, compile_fail, [''])
 
 test('rn_dup', normal, compile_fail, [''])
-test('T2310', normal, compile_fail, [''])
 test('T2490', normal, compile_fail, [''])
 test('T2901', normal, compile_fail, [''])
 test('T2723', normal, compile, [''])  # Warnings only