Commit d8d87fa2 authored by Joachim Breitner's avatar Joachim Breitner

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
parent 7109fa81
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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,
......
......@@ -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.
......
......@@ -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 ]
{-
************************************************************************
* *
......
......@@ -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 })
......
......@@ -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
......
......@@ -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"
......
{-# OPTIONS_GHC -XScopedTypeVariables #-}
module Foo where
foo = let c = \ (x :: a) -> (x :: a) in co
T2310.hs:5:41: error:
• Variable not in scope: co
• Perhaps you meant one of these:
‘c’ (line 5), ‘cos’ (imported from Prelude)
......@@ -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
......
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