From d8d87fa2b22404b7939956974f53858c41ec7769 Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Tue, 3 Oct 2017 22:09:49 -0400
Subject: [PATCH] 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
---
compiler/hsSyn/Convert.hs | 6 ++---
compiler/hsSyn/HsExpr.hs | 9 --------
compiler/hsSyn/HsUtils.hs | 3 +--
compiler/parser/Parser.y | 20 ++++++----------
compiler/parser/RdrHsSyn.hs | 12 ++++------
compiler/rename/RnBinds.hs | 23 +++----------------
compiler/typecheck/TcArrows.hs | 2 +-
compiler/typecheck/TcHsSyn.hs | 3 +--
compiler/typecheck/TcMatches.hs | 13 +++--------
testsuite/tests/rename/should_fail/T2310.hs | 5 ----
.../tests/rename/should_fail/T2310.stderr | 5 ----
testsuite/tests/rename/should_fail/all.T | 1 -
12 files changed, 23 insertions(+), 79 deletions(-)
delete mode 100644 testsuite/tests/rename/should_fail/T2310.hs
delete mode 100644 testsuite/tests/rename/should_fail/T2310.stderr
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
--
GitLab