Commit f0f9365f authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Ben Gamari

Remove fun_infix from Funbind, as it is now in Match

One of the changes D538 introduced is to add `m_fun_id_infix` to `Match`

```lang=hs
data Match id body
  = Match {
        m_fun_id_infix :: (Maybe (Located id,Bool)),
          -- fun_id and fun_infix for functions with multiple equations
          -- only present for a RdrName. See note [fun_id in Match]
        m_pats :: [LPat id], -- The patterns
        m_type :: (Maybe (LHsType id)),
                                 -- A type signature for the result of the match
                                 -- Nothing after typechecking
        m_grhss :: (GRHSs id body)
  } deriving (Typeable)
```

This was done to track the individual locations and fixity of the
`fun_id` for each of the defining equations for a function when there
are more than one.

For example, the function `(&&&)` is defined with some prefix and some
infix equations below.

```lang=hs
    (&&&  ) [] [] =  []
    xs    &&&   [] =  xs
    (  &&&  ) [] ys =  ys
```

This means that the fun_infix is now superfluous in the `FunBind`. This
has not been removed as a potentially risky change just before 7.10 RC2,
and so must be done after.

This ticket captures that task, which includes processing these fields
through the renamer and beyond.

Ticket #9988 introduced these fields into `Match` through renaming, this
ticket it to continue through type checking and then remove it from
`FunBind` completely.

The split happened so that #9988 could land in 7.10

Trac ticket : #10061

Test Plan: ./validate

Reviewers: goldfire, austin, simonpj, bgamari

Reviewed By: bgamari

Subscribers: simonpj, thomie, mpickering

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

GHC Trac Issues: #10061
parent ea8c116a
...@@ -108,10 +108,9 @@ dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless ...@@ -108,10 +108,9 @@ dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless
; return (unitOL (makeCorePair dflags var' False 0 core_expr)) } ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }
dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick , fun_co_fn = co_fn, fun_tick = tick })
, fun_infix = inf })
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches ; (args, body) <- matchWrapper (FunRhs (idName fun)) matches
; let body' = mkOptTickBox tick body ; let body' = mkOptTickBox tick body
; rhs <- dsHsWrapper co_fn (mkLams args body') ; rhs <- dsHsWrapper co_fn (mkLams args body')
; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -} ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
......
...@@ -144,10 +144,10 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] ...@@ -144,10 +144,10 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
; return (mkCoreLets ds_binds body2) } ; return (mkCoreLets ds_binds body2) }
dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
, fun_tick = tick, fun_infix = inf }) body , fun_tick = tick }) body
-- Can't be a bang pattern (that looks like a PatBind) -- Can't be a bang pattern (that looks like a PatBind)
-- so must be simply unboxed -- so must be simply unboxed
= do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches = do { (args, rhs) <- matchWrapper (FunRhs (idName fun )) matches
; MASSERT( null args ) -- Functions aren't lifted ; MASSERT( null args ) -- Functions aren't lifted
; MASSERT( isIdHsWrapper co_fn ) ; MASSERT( isIdHsWrapper co_fn )
; let rhs' = mkOptTickBox tick rhs ; let rhs' = mkOptTickBox tick rhs
......
...@@ -148,8 +148,8 @@ pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun ...@@ -148,8 +148,8 @@ pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
where where
(ppr_match, pref) (ppr_match, pref)
= case kind of = case kind of
FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp) _ -> (pprMatchContext kind, \ pp -> pp)
ppr_pats :: Outputable a => [a] -> SDoc ppr_pats :: Outputable a => [a] -> SDoc
ppr_pats pats = sep (map ppr pats) ppr_pats pats = sep (map ppr pats)
......
...@@ -630,7 +630,7 @@ cvtClause (Clause ps body wheres) ...@@ -630,7 +630,7 @@ cvtClause (Clause ps body wheres)
= do { ps' <- cvtPats ps = do { ps' <- cvtPats ps
; g' <- cvtGuard body ; g' <- cvtGuard body
; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' ds') } ; returnL $ Hs.Match NonFunBindMatch ps' Nothing (GRHSs g' ds') }
------------------------------------------------------------------- -------------------------------------------------------------------
...@@ -851,7 +851,7 @@ cvtMatch (TH.Match p body decs) ...@@ -851,7 +851,7 @@ cvtMatch (TH.Match p body decs)
= do { p' <- cvtPat p = do { p' <- cvtPat p
; g' <- cvtGuard body ; g' <- cvtGuard body
; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') } ; returnL $ Hs.Match NonFunBindMatch [p'] Nothing (GRHSs g' decs') }
cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)] cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (GuardedB pairs) = mapM cvtpair pairs
......
...@@ -140,8 +140,6 @@ data HsBindLR idL idR ...@@ -140,8 +140,6 @@ data HsBindLR idL idR
fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr
fun_infix :: Bool, -- ^ True => infix declaration
fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
...@@ -488,14 +486,14 @@ ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) ...@@ -488,14 +486,14 @@ ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
= pprPatBind pat grhss = pprPatBind pat grhss
ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
= sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, ppr_monobind (FunBind { fun_id = fun,
fun_co_fn = wrap, fun_co_fn = wrap,
fun_matches = matches, fun_matches = matches,
fun_tick = ticks }) fun_tick = ticks })
= pprTicks empty (if null ticks then empty = pprTicks empty (if null ticks then empty
else text "-- ticks = " <> ppr ticks) else text "-- ticks = " <> ppr ticks)
$$ ifPprDebug (pprBndr LetBind (unLoc fun)) $$ ifPprDebug (pprBndr LetBind (unLoc fun))
$$ pprFunBind (unLoc fun) inf matches $$ pprFunBind (unLoc fun) matches
$$ ifPprDebug (ppr wrap) $$ ifPprDebug (ppr wrap)
ppr_monobind (PatSynBind psb) = ppr psb ppr_monobind (PatSynBind psb) = ppr psb
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
...@@ -522,18 +520,18 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL ...@@ -522,18 +520,18 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL
ppr_lhs = ptext (sLit "pattern") <+> ppr_details ppr_lhs = ptext (sLit "pattern") <+> ppr_details
ppr_simple syntax = syntax <+> ppr pat ppr_simple syntax = syntax <+> ppr pat
(is_infix, ppr_details) = case details of ppr_details = case details of
InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2]) InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
PrefixPatSyn vs -> (False, hsep (pprPrefixOcc psyn : map ppr vs)) PrefixPatSyn vs -> hsep (pprPrefixOcc psyn : map ppr vs)
RecordPatSyn vs -> RecordPatSyn vs ->
(False, pprPrefixOcc psyn pprPrefixOcc psyn
<> braces (sep (punctuate comma (map ppr vs)))) <> braces (sep (punctuate comma (map ppr vs)))
ppr_rhs = case dir of ppr_rhs = case dir of
Unidirectional -> ppr_simple (ptext (sLit "<-")) Unidirectional -> ppr_simple (ptext (sLit "<-"))
ImplicitBidirectional -> ppr_simple equals ImplicitBidirectional -> ppr_simple equals
ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$ ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$
(nest 2 $ pprFunBind psyn is_infix mg) (nest 2 $ pprFunBind psyn mg)
pprTicks :: SDoc -> SDoc -> SDoc pprTicks :: SDoc -> SDoc -> SDoc
-- Print stuff about ticks only when -dppr-debug is on, to avoid -- Print stuff about ticks only when -dppr-debug is on, to avoid
......
...@@ -1123,9 +1123,8 @@ type LMatch id body = Located (Match id body) ...@@ -1123,9 +1123,8 @@ type LMatch id body = Located (Match id body)
-- For details on above see note [Api annotations] in ApiAnnotation -- For details on above see note [Api annotations] in ApiAnnotation
data Match id body data Match id body
= Match { = Match {
m_fun_id_infix :: (Maybe (Located id,Bool)), m_fixity :: MatchFixity id,
-- fun_id and fun_infix for functions with multiple equations -- See note [m_fixity in Match]
-- only present for a RdrName. See note [fun_id in Match]
m_pats :: [LPat id], -- The patterns m_pats :: [LPat id], -- The patterns
m_type :: (Maybe (LHsType id)), m_type :: (Maybe (LHsType id)),
-- A type signature for the result of the match -- A type signature for the result of the match
...@@ -1135,7 +1134,7 @@ data Match id body ...@@ -1135,7 +1134,7 @@ data Match id body
deriving instance (Data body,DataId id) => Data (Match id body) deriving instance (Data body,DataId id) => Data (Match id body)
{- {-
Note [fun_id in Match] Note [m_fixity in Match]
~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~
The parser initially creates a FunBind with a single Match in it for The parser initially creates a FunBind with a single Match in it for
...@@ -1160,6 +1159,20 @@ Example infix function definition requiring individual API Annotations ...@@ -1160,6 +1159,20 @@ Example infix function definition requiring individual API Annotations
-} -}
-- |When a Match is part of a FunBind, it captures one complete equation for the
-- function. As such it has the function name, and its fixity.
data MatchFixity id
= NonFunBindMatch
| FunBindMatch (Located id) -- of the Id
Bool -- is infix
deriving (Typeable)
deriving instance (DataId id) => Data (MatchFixity id)
isInfixMatch :: Match id body -> Bool
isInfixMatch match = case m_fixity match of
FunBindMatch _ True -> True
_ -> False
isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup :: MatchGroup id body -> Bool
isEmptyMatchGroup (MG { mg_alts = ms }) = null ms isEmptyMatchGroup (MG { mg_alts = ms }) = null ms
...@@ -1206,8 +1219,8 @@ pprMatches ctxt (MG { mg_alts = matches }) ...@@ -1206,8 +1219,8 @@ pprMatches ctxt (MG { mg_alts = matches })
-- Exported to HsBinds, which can't see the defn of HsMatchContext -- Exported to HsBinds, which can't see the defn of HsMatchContext
pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body) pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> idL -> Bool -> MatchGroup idR body -> SDoc => idL -> MatchGroup idR body -> SDoc
pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches pprFunBind fun matches = pprMatches (FunRhs fun) matches
-- Exported to HsBinds, which can't see the defn of HsMatchContext -- Exported to HsBinds, which can't see the defn of HsMatchContext
pprPatBind :: forall bndr id body. (OutputableBndr bndr, OutputableBndr id, Outputable body) pprPatBind :: forall bndr id body. (OutputableBndr bndr, OutputableBndr id, Outputable body)
...@@ -1217,15 +1230,16 @@ pprPatBind pat (grhss) ...@@ -1217,15 +1230,16 @@ pprPatBind pat (grhss)
pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body) pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> HsMatchContext idL -> Match idR body -> SDoc => HsMatchContext idL -> Match idR body -> SDoc
pprMatch ctxt (Match _ pats maybe_ty grhss) pprMatch ctxt match
= sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
, nest 2 ppr_maybe_ty , nest 2 ppr_maybe_ty
, nest 2 (pprGRHSs ctxt grhss) ] , nest 2 (pprGRHSs ctxt (m_grhss match)) ]
where where
is_infix = isInfixMatch match
(herald, other_pats) (herald, other_pats)
= case ctxt of = case ctxt of
FunRhs fun is_infix FunRhs fun
| not is_infix -> (pprPrefixOcc fun, pats) | not is_infix -> (pprPrefixOcc fun, m_pats match)
-- f x y z = e -- f x y z = e
-- Not pprBndr; the AbsBinds will -- Not pprBndr; the AbsBinds will
-- have printed the signature -- have printed the signature
...@@ -1238,14 +1252,14 @@ pprMatch ctxt (Match _ pats maybe_ty grhss) ...@@ -1238,14 +1252,14 @@ pprMatch ctxt (Match _ pats maybe_ty grhss)
where where
pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2 pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2
LambdaExpr -> (char '\\', pats) LambdaExpr -> (char '\\', m_pats match)
_ -> ASSERT( null pats1 ) _ -> ASSERT( null pats1 )
(ppr pat1, []) -- No parens around the single pat (ppr pat1, []) -- No parens around the single pat
(pat1:pats1) = pats (pat1:pats1) = m_pats match
(pat2:pats2) = pats1 (pat2:pats2) = pats1
ppr_maybe_ty = case maybe_ty of ppr_maybe_ty = case m_type match of
Just ty -> dcolon <+> ppr ty Just ty -> dcolon <+> ppr ty
Nothing -> empty Nothing -> empty
...@@ -1918,7 +1932,7 @@ pp_dotdot = ptext (sLit " .. ") ...@@ -1918,7 +1932,7 @@ pp_dotdot = ptext (sLit " .. ")
-} -}
data HsMatchContext id -- Context of a Match data HsMatchContext id -- Context of a Match
= FunRhs id Bool -- Function binding for f; True <=> written infix = FunRhs id -- Function binding for f
| LambdaExpr -- Patterns of a lambda | LambdaExpr -- Patterns of a lambda
| CaseAlt -- Patterns and guards on a case alternative | CaseAlt -- Patterns and guards on a case alternative
| IfAlt -- Guards of a multi-way if alternative | IfAlt -- Guards of a multi-way if alternative
...@@ -1990,7 +2004,7 @@ pprMatchContext ctxt ...@@ -1990,7 +2004,7 @@ pprMatchContext ctxt
want_an _ = False want_an _ = False
pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc
pprMatchContextNoun (FunRhs fun _) = ptext (sLit "equation for") pprMatchContextNoun (FunRhs fun) = ptext (sLit "equation for")
<+> quotes (ppr fun) <+> quotes (ppr fun)
pprMatchContextNoun CaseAlt = ptext (sLit "case alternative") pprMatchContextNoun CaseAlt = ptext (sLit "case alternative")
pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative") pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative")
...@@ -2042,13 +2056,13 @@ pprStmtContext (TransStmtCtxt c) ...@@ -2042,13 +2056,13 @@ pprStmtContext (TransStmtCtxt c)
-- Used to generate the string for a *runtime* error message -- Used to generate the string for a *runtime* error message
matchContextErrString :: Outputable id => HsMatchContext id -> SDoc matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
matchContextErrString (FunRhs fun _) = ptext (sLit "function") <+> ppr fun matchContextErrString (FunRhs fun) = ptext (sLit "function") <+> ppr fun
matchContextErrString CaseAlt = ptext (sLit "case") matchContextErrString CaseAlt = ptext (sLit "case")
matchContextErrString IfAlt = ptext (sLit "multi-way if") matchContextErrString IfAlt = ptext (sLit "multi-way if")
matchContextErrString PatBindRhs = ptext (sLit "pattern binding") matchContextErrString PatBindRhs = ptext (sLit "pattern binding")
matchContextErrString RecUpd = ptext (sLit "record update") matchContextErrString RecUpd = ptext (sLit "record update")
matchContextErrString LambdaExpr = ptext (sLit "lambda") matchContextErrString LambdaExpr = ptext (sLit "lambda")
matchContextErrString ProcExpr = ptext (sLit "proc") matchContextErrString ProcExpr = ptext (sLit "proc")
matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime
matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime
......
...@@ -53,4 +53,4 @@ pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body) ...@@ -53,4 +53,4 @@ pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body)
=> LPat bndr -> GRHSs id body -> SDoc => LPat bndr -> GRHSs id body -> SDoc
pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body) pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> idL -> Bool -> MatchGroup idR body -> SDoc => idL -> MatchGroup idR body -> SDoc
...@@ -39,6 +39,7 @@ module HsUtils( ...@@ -39,6 +39,7 @@ module HsUtils(
-- Bindings -- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
mkPatSynBind, mkPatSynBind,
isInfixFunBind,
-- Literals -- Literals
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
...@@ -134,7 +135,7 @@ mkHsPar e = L (getLoc e) (HsPar e) ...@@ -134,7 +135,7 @@ mkHsPar e = L (getLoc e) (HsPar e)
mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id)) mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
mkSimpleMatch pats rhs mkSimpleMatch pats rhs
= L loc $ = L loc $
Match Nothing pats Nothing (unguardedGRHSs rhs) Match NonFunBindMatch pats Nothing (unguardedGRHSs rhs)
where where
loc = case pats of loc = case pats of
[] -> getLoc rhs [] -> getLoc rhs
...@@ -603,7 +604,7 @@ l ...@@ -603,7 +604,7 @@ l
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
-> HsBind RdrName -> HsBind RdrName
-- Not infix, with place holders for coercion and free vars -- Not infix, with place holders for coercion and free vars
mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False mkFunBind fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroup Generated ms , fun_matches = mkMatchGroup Generated ms
, fun_co_fn = idHsWrapper , fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames , bind_fvs = placeHolderNames
...@@ -612,7 +613,7 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False ...@@ -612,7 +613,7 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)] mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
-> HsBind Name -> HsBind Name
-- In Name-land, with empty bind_fvs -- In Name-land, with empty bind_fvs
mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False mkTopFunBind origin fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroupName origin ms , fun_matches = mkMatchGroupName origin ms
, fun_co_fn = idHsWrapper , fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet -- NB: closed , bind_fvs = emptyNameSet -- NB: closed
...@@ -636,6 +637,16 @@ mkPatSynBind name details lpat dir = PatSynBind psb ...@@ -636,6 +637,16 @@ mkPatSynBind name details lpat dir = PatSynBind psb
, psb_dir = dir , psb_dir = dir
, psb_fvs = placeHolderNames } , psb_fvs = placeHolderNames }
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
= any isInfix matches
where
isInfix (L _ match) = isInfixMatch match
isInfixFunBind _ = False
------------ ------------
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsExpr RdrName -> LHsBind RdrName -> LHsExpr RdrName -> LHsBind RdrName
...@@ -645,7 +656,7 @@ mk_easy_FunBind loc fun pats expr ...@@ -645,7 +656,7 @@ mk_easy_FunBind loc fun pats expr
------------ ------------
mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id) mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
mkMatch pats expr binds mkMatch pats expr binds
= noLoc (Match Nothing (map paren pats) Nothing = noLoc (Match NonFunBindMatch (map paren pats) Nothing
(GRHSs (unguardedRHS noSrcSpan expr) binds)) (GRHSs (unguardedRHS noSrcSpan expr) binds))
where where
paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
......
...@@ -2021,7 +2021,7 @@ decl_no_th :: { LHsDecl RdrName } ...@@ -2021,7 +2021,7 @@ decl_no_th :: { LHsDecl RdrName }
| infixexp opt_sig rhs {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3; | infixexp opt_sig rhs {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
let { l = comb2 $1 $> }; let { l = comb2 $1 $> };
case r of { case r of {
(FunBind n _ _ _ _ _) -> (FunBind n _ _ _ _) ->
ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ; ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
(PatBind (L lh _lhs) _rhs _ _ _) -> (PatBind (L lh _lhs) _rhs _ _ _) ->
ams (L lh ()) (fst $2) >> return () } ; ams (L lh ()) (fst $2) >> return () } ;
...@@ -2158,7 +2158,7 @@ infixexp :: { LHsExpr RdrName } ...@@ -2158,7 +2158,7 @@ infixexp :: { LHsExpr RdrName }
exp10 :: { LHsExpr RdrName } exp10 :: { LHsExpr RdrName }
: '\\' apat apats opt_asig '->' exp : '\\' apat apats opt_asig '->' exp
{% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
[sLL $1 $> $ Match Nothing ($2:$3) (snd $4) (unguardedGRHSs $6)])) [sLL $1 $> $ Match NonFunBindMatch ($2:$3) (snd $4) (unguardedGRHSs $6)]))
(mj AnnLam $1:mj AnnRarrow $5:(fst $4)) } (mj AnnLam $1:mj AnnRarrow $5:(fst $4)) }
| 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
(mj AnnLet $1:mj AnnIn $3 (mj AnnLet $1:mj AnnIn $3
...@@ -2556,7 +2556,7 @@ alts1 :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } ...@@ -2556,7 +2556,7 @@ alts1 :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }
| alt { sL1 $1 ([],[$1]) } | alt { sL1 $1 ([],[$1]) }
alt :: { LMatch RdrName (LHsExpr RdrName) } alt :: { LMatch RdrName (LHsExpr RdrName) }
: pat opt_sig alt_rhs {%ams (sLL $1 $> (Match Nothing [$1] (snd $2) : pat opt_sig alt_rhs {%ams (sLL $1 $> (Match NonFunBindMatch [$1] (snd $2)
(snd $ unLoc $3))) (snd $ unLoc $3)))
((fst $2) ++ (fst $ unLoc $3))} ((fst $2) ++ (fst $ unLoc $3))}
......
...@@ -387,21 +387,22 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] ...@@ -387,21 +387,22 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
-- --
-- No AndMonoBinds or EmptyMonoBinds here; just single equations -- No AndMonoBinds or EmptyMonoBinds here; just single equations
getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
fun_matches = MG { mg_alts = mtchs1 } })) binds fun_matches = MG { mg_alts = mtchs1 } })) binds
| has_args mtchs1 | has_args mtchs1
= go is_infix1 mtchs1 loc1 binds [] = go mtchs1 loc1 binds []
where where
go is_infix mtchs loc go mtchs loc
(L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2, (L loc2 (ValD (FunBind { fun_id = L _ f2,
fun_matches = MG { mg_alts = mtchs2 } })) : binds) _ fun_matches = MG { mg_alts = mtchs2 } })) : binds) _
| f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) | f1 == f2 = go (mtchs2 ++ mtchs)
(combineSrcSpans loc loc2) binds [] (combineSrcSpans loc loc2) binds []
go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
= let doc_decls' = doc_decl : doc_decls = let doc_decls' = doc_decl : doc_decls
in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls' in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
go is_infix mtchs loc binds doc_decls go mtchs loc binds doc_decls
= (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds) = ( L loc (makeFunBind fun_id1 (reverse mtchs))
, (reverse doc_decls) ++ binds)
-- Reverse the final matches, to get it back in the right order -- Reverse the final matches, to get it back in the right order
-- Do the same thing with the trailing doc comments -- Do the same thing with the trailing doc comments
...@@ -465,9 +466,9 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) = ...@@ -465,9 +466,9 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
do { unless (name == patsyn_name) $ do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl wrongNameBindingErr loc decl
; match <- case details of ; match <- case details of
PrefixCon pats -> return $ Match Nothing pats Nothing rhs PrefixCon pats -> return $ Match NonFunBindMatch pats Nothing rhs
InfixCon pat1 pat2 -> InfixCon pat1 pat2 ->
return $ Match Nothing [pat1, pat2] Nothing rhs return $ Match NonFunBindMatch [pat1, pat2] Nothing rhs
RecCon{} -> recordPatSynErr loc pat RecCon{} -> recordPatSynErr loc pat
; return $ L loc match } ; return $ L loc match }
fromDecl (L loc decl) = extraDeclErr loc decl fromDecl (L loc decl) = extraDeclErr loc decl
...@@ -912,16 +913,17 @@ checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) ...@@ -912,16 +913,17 @@ checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
let match_span = combineSrcSpans lhs_loc rhs_span let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs -- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann -- mapM_ (\a -> a match_span) ann
return (ann,makeFunBind fun is_infix return (ann,makeFunBind fun
[L match_span (Match (Just (fun,is_infix)) ps opt_sig grhss)]) [L match_span (Match (FunBindMatch fun is_infix)
ps opt_sig grhss)])
-- The span of the match covers the entire equation. -- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now. -- That isn't quite right, but it'll do for now.
makeFunBind :: Located RdrName -> Bool -> [LMatch RdrName (LHsExpr RdrName)] makeFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
-> HsBind RdrName -> HsBind RdrName
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
makeFunBind fn is_infix ms makeFunBind fn ms
= FunBind { fun_id = fn, fun_infix = is_infix, = FunBind { fun_id = fn,
fun_matches = mkMatchGroup FromSource ms, fun_matches = mkMatchGroup FromSource ms,
fun_co_fn = idHsWrapper, fun_co_fn = idHsWrapper,
bind_fvs = placeHolderNames, bind_fvs = placeHolderNames,
......
...@@ -471,15 +471,15 @@ rnBind _ bind@(PatBind { pat_lhs = pat ...@@ -471,15 +471,15 @@ rnBind _ bind@(PatBind { pat_lhs = pat
return (bind', bndrs, all_fvs) } return (bind', bndrs, all_fvs) }
rnBind sig_fn bind@(FunBind { fun_id = name rnBind sig_fn bind@(FunBind { fun_id = name
, fun_infix = is_infix
, fun_matches = matches }) , fun_matches = matches })
-- invariant: no free vars here when it's a FunBind -- invariant: no free vars here when it's a FunBind
= do { let plain_name = unLoc name = do { let plain_name = unLoc name
; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-- bindSigTyVars tests for Opt_ScopedTyVars -- bindSigTyVars tests for Opt_ScopedTyVars
rnMatchGroup (FunRhs plain_name is_infix) rnMatchGroup (FunRhs plain_name)
rnLExpr matches rnLExpr matches
; let is_infix = isInfixFunBind bind
; when is_infix $ checkPrecMatch plain_name matches' ; when is_infix $ checkPrecMatch plain_name matches'
; mod <- getModule ; mod <- getModule
...@@ -1059,22 +1059,23 @@ rnMatch' :: Outputable (body RdrName) => HsMatchContext Name ...@@ -1059,22 +1059,23 @@ rnMatch' :: Outputable (body RdrName) => HsMatchContext Name
-> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
-> Match RdrName (Located (body RdrName)) -> Match RdrName (Located (body RdrName))
-> RnM (Match Name (Located (body Name)), FreeVars) -> RnM (Match Name (Located (body Name)), FreeVars)
rnMatch' ctxt rnBody match@(Match { m_fun_id_infix = mf, m_pats = pats rnMatch' ctxt rnBody match@(Match { m_fixity = mf, m_pats = pats
, m_type = maybe_rhs_sig, m_grhss = grhss }) , m_type = maybe_rhs_sig, m_grhss = grhss })
= do { -- Result type signatures are no longer supported = do { -- Result type signatures are no longer supported
case maybe_rhs_sig of case maybe_rhs_sig of
Nothing -> return () Nothing -> return ()
Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty) Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
; let isinfix = isInfixMatch match
-- Now the main event -- Now the main event
-- Note that there are no local fixity decls for matches -- Note that there are no local fixity decls for matches