summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/DsBinds.hs5
-rw-r--r--compiler/deSugar/DsExpr.hs4
-rw-r--r--compiler/deSugar/Match.hs4
-rw-r--r--compiler/hsSyn/Convert.hs4
-rw-r--r--compiler/hsSyn/HsBinds.hs18
-rw-r--r--compiler/hsSyn/HsExpr.hs58
-rw-r--r--compiler/hsSyn/HsExpr.hs-boot2
-rw-r--r--compiler/hsSyn/HsUtils.hs19
-rw-r--r--compiler/parser/Parser.y6
-rw-r--r--compiler/parser/RdrHsSyn.hs34
-rw-r--r--compiler/rename/RnBinds.hs15
-rw-r--r--compiler/typecheck/TcArrows.hs2
-rw-r--r--compiler/typecheck/TcBinds.hs22
-rw-r--r--compiler/typecheck/TcMatches.hs8
-rw-r--r--compiler/typecheck/TcMatches.hs-boot2
-rw-r--r--compiler/typecheck/TcPatSyn.hs6
16 files changed, 116 insertions, 93 deletions
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 93b50dfc7c..47a3419bcc 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -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)) }
dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
- , fun_co_fn = co_fn, fun_tick = tick
- , fun_infix = inf })
+ , fun_co_fn = co_fn, fun_tick = tick })
= do { dflags <- getDynFlags
- ; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
+ ; (args, body) <- matchWrapper (FunRhs (idName fun)) matches
; let body' = mkOptTickBox tick body
; rhs <- dsHsWrapper co_fn (mkLams args body')
; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 075a647588..0f5d6e5d53 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -144,10 +144,10 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
; return (mkCoreLets ds_binds body2) }
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)
-- 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( isIdHsWrapper co_fn )
; let rhs' = mkOptTickBox tick rhs
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 5840578942..8af0a6e5e3 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -148,8 +148,8 @@ pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
where
(ppr_match, pref)
= case kind of
- FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
- _ -> (pprMatchContext kind, \ pp -> pp)
+ FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+ _ -> (pprMatchContext kind, \ pp -> pp)
ppr_pats :: Outputable a => [a] -> SDoc
ppr_pats pats = sep (map ppr pats)
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 28b699d3fd..2d7194e2b3 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -630,7 +630,7 @@ cvtClause (Clause ps body wheres)
= do { ps' <- cvtPats ps
; g' <- cvtGuard body
; 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)
= do { p' <- cvtPat p
; g' <- cvtGuard body
; 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 (GuardedB pairs) = mapM cvtpair pairs
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index b1d13caf48..978d36349a 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -140,8 +140,6 @@ data HsBindLR idL idR
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_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 })
= pprPatBind pat grhss
ppr_monobind (VarBind { var_id = var, var_rhs = 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_matches = matches,
fun_tick = ticks })
= pprTicks empty (if null ticks then empty
else text "-- ticks = " <> ppr ticks)
$$ ifPprDebug (pprBndr LetBind (unLoc fun))
- $$ pprFunBind (unLoc fun) inf matches
+ $$ pprFunBind (unLoc fun) matches
$$ ifPprDebug (ppr wrap)
ppr_monobind (PatSynBind psb) = ppr psb
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
@@ -522,18 +520,18 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL
ppr_lhs = ptext (sLit "pattern") <+> ppr_details
ppr_simple syntax = syntax <+> ppr pat
- (is_infix, ppr_details) = case details of
- InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2])
- PrefixPatSyn vs -> (False, hsep (pprPrefixOcc psyn : map ppr vs))
+ ppr_details = case details of
+ InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
+ PrefixPatSyn vs -> hsep (pprPrefixOcc psyn : map ppr vs)
RecordPatSyn vs ->
- (False, pprPrefixOcc psyn
- <> braces (sep (punctuate comma (map ppr vs))))
+ pprPrefixOcc psyn
+ <> braces (sep (punctuate comma (map ppr vs)))
ppr_rhs = case dir of
Unidirectional -> ppr_simple (ptext (sLit "<-"))
ImplicitBidirectional -> ppr_simple equals
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
-- Print stuff about ticks only when -dppr-debug is on, to avoid
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 5ee17cff9b..19e7d2fade 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1123,9 +1123,8 @@ type LMatch id body = Located (Match id body)
-- For details on above see note [Api annotations] in ApiAnnotation
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_fixity :: MatchFixity id,
+ -- See note [m_fixity in Match]
m_pats :: [LPat id], -- The patterns
m_type :: (Maybe (LHsType id)),
-- A type signature for the result of the match
@@ -1135,7 +1134,7 @@ 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
@@ -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 (MG { mg_alts = ms }) = null ms
@@ -1206,8 +1219,8 @@ pprMatches ctxt (MG { mg_alts = matches })
-- Exported to HsBinds, which can't see the defn of HsMatchContext
pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
- => idL -> Bool -> MatchGroup idR body -> SDoc
-pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
+ => idL -> MatchGroup idR body -> SDoc
+pprFunBind fun matches = pprMatches (FunRhs fun) matches
-- Exported to HsBinds, which can't see the defn of HsMatchContext
pprPatBind :: forall bndr id body. (OutputableBndr bndr, OutputableBndr id, Outputable body)
@@ -1217,15 +1230,16 @@ pprPatBind pat (grhss)
pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> 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)
, nest 2 ppr_maybe_ty
- , nest 2 (pprGRHSs ctxt grhss) ]
+ , nest 2 (pprGRHSs ctxt (m_grhss match)) ]
where
+ is_infix = isInfixMatch match
(herald, other_pats)
= case ctxt of
- FunRhs fun is_infix
- | not is_infix -> (pprPrefixOcc fun, pats)
+ FunRhs fun
+ | not is_infix -> (pprPrefixOcc fun, m_pats match)
-- f x y z = e
-- Not pprBndr; the AbsBinds will
-- have printed the signature
@@ -1238,14 +1252,14 @@ pprMatch ctxt (Match _ pats maybe_ty grhss)
where
pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2
- LambdaExpr -> (char '\\', pats)
+ LambdaExpr -> (char '\\', m_pats match)
_ -> ASSERT( null pats1 )
(ppr pat1, []) -- No parens around the single pat
- (pat1:pats1) = pats
+ (pat1:pats1) = m_pats match
(pat2:pats2) = pats1
- ppr_maybe_ty = case maybe_ty of
+ ppr_maybe_ty = case m_type match of
Just ty -> dcolon <+> ppr ty
Nothing -> empty
@@ -1918,7 +1932,7 @@ pp_dotdot = ptext (sLit " .. ")
-}
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
| CaseAlt -- Patterns and guards on a case alternative
| IfAlt -- Guards of a multi-way if alternative
@@ -1990,7 +2004,7 @@ pprMatchContext ctxt
want_an _ = False
pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc
-pprMatchContextNoun (FunRhs fun _) = ptext (sLit "equation for")
+pprMatchContextNoun (FunRhs fun) = ptext (sLit "equation for")
<+> quotes (ppr fun)
pprMatchContextNoun CaseAlt = ptext (sLit "case alternative")
pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative")
@@ -2042,13 +2056,13 @@ pprStmtContext (TransStmtCtxt c)
-- Used to generate the string for a *runtime* error message
matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
-matchContextErrString (FunRhs fun _) = ptext (sLit "function") <+> ppr fun
-matchContextErrString CaseAlt = ptext (sLit "case")
-matchContextErrString IfAlt = ptext (sLit "multi-way if")
-matchContextErrString PatBindRhs = ptext (sLit "pattern binding")
-matchContextErrString RecUpd = ptext (sLit "record update")
-matchContextErrString LambdaExpr = ptext (sLit "lambda")
-matchContextErrString ProcExpr = ptext (sLit "proc")
+matchContextErrString (FunRhs fun) = ptext (sLit "function") <+> ppr fun
+matchContextErrString CaseAlt = ptext (sLit "case")
+matchContextErrString IfAlt = ptext (sLit "multi-way if")
+matchContextErrString PatBindRhs = ptext (sLit "pattern binding")
+matchContextErrString RecUpd = ptext (sLit "record update")
+matchContextErrString LambdaExpr = ptext (sLit "lambda")
+matchContextErrString ProcExpr = ptext (sLit "proc")
matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime
matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime
diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot
index eb9d23a9ed..bb5142f6ac 100644
--- a/compiler/hsSyn/HsExpr.hs-boot
+++ b/compiler/hsSyn/HsExpr.hs-boot
@@ -53,4 +53,4 @@ pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body)
=> LPat bndr -> GRHSs id body -> SDoc
pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
- => idL -> Bool -> MatchGroup idR body -> SDoc
+ => idL -> MatchGroup idR body -> SDoc
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index a2ed9488b8..e88c7b64f3 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -39,6 +39,7 @@ module HsUtils(
-- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
mkPatSynBind,
+ isInfixFunBind,
-- Literals
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
@@ -134,7 +135,7 @@ mkHsPar e = L (getLoc e) (HsPar e)
mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
mkSimpleMatch pats rhs
= L loc $
- Match Nothing pats Nothing (unguardedGRHSs rhs)
+ Match NonFunBindMatch pats Nothing (unguardedGRHSs rhs)
where
loc = case pats of
[] -> getLoc rhs
@@ -603,7 +604,7 @@ l
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
-> HsBind RdrName
-- 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_co_fn = idHsWrapper
, bind_fvs = placeHolderNames
@@ -612,7 +613,7 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
-> HsBind Name
-- 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_co_fn = idHsWrapper
, bind_fvs = emptyNameSet -- NB: closed
@@ -636,6 +637,16 @@ mkPatSynBind name details lpat dir = PatSynBind psb
, psb_dir = dir
, 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]
-> LHsExpr RdrName -> LHsBind RdrName
@@ -645,7 +656,7 @@ mk_easy_FunBind loc fun pats expr
------------
mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
mkMatch pats expr binds
- = noLoc (Match Nothing (map paren pats) Nothing
+ = noLoc (Match NonFunBindMatch (map paren pats) Nothing
(GRHSs (unguardedRHS noSrcSpan expr) binds))
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 e4ff162181..479fc28435 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2021,7 +2021,7 @@ decl_no_th :: { LHsDecl RdrName }
| infixexp opt_sig rhs {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
let { l = comb2 $1 $> };
case r of {
- (FunBind n _ _ _ _ _) ->
+ (FunBind n _ _ _ _) ->
ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
(PatBind (L lh _lhs) _rhs _ _ _) ->
ams (L lh ()) (fst $2) >> return () } ;
@@ -2158,7 +2158,7 @@ infixexp :: { LHsExpr RdrName }
exp10 :: { LHsExpr RdrName }
: '\\' apat apats opt_asig '->' exp
{% 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)) }
| 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
(mj AnnLet $1:mj AnnIn $3
@@ -2556,7 +2556,7 @@ alts1 :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }
| alt { sL1 $1 ([],[$1]) }
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)))
((fst $2) ++ (fst $ unLoc $3))}
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 5aa91ec296..2a5faffdcd 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -387,21 +387,22 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
--
-- 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
| has_args mtchs1
- = go is_infix1 mtchs1 loc1 binds []
+ = go mtchs1 loc1 binds []
where
- go is_infix mtchs loc
- (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
+ go mtchs loc
+ (L loc2 (ValD (FunBind { fun_id = L _ f2,
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 []
- 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
- in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
- go is_infix mtchs loc binds doc_decls
- = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
+ in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
+ go mtchs loc binds doc_decls
+ = ( L loc (makeFunBind fun_id1 (reverse mtchs))
+ , (reverse doc_decls) ++ binds)
-- Reverse the final matches, to get it back in the right order
-- Do the same thing with the trailing doc comments
@@ -465,9 +466,9 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
; match <- case details of
- PrefixCon pats -> return $ Match Nothing pats Nothing rhs
+ PrefixCon pats -> return $ Match NonFunBindMatch pats Nothing rhs
InfixCon pat1 pat2 ->
- return $ Match Nothing [pat1, pat2] Nothing rhs
+ return $ Match NonFunBindMatch [pat1, pat2] Nothing rhs
RecCon{} -> recordPatSynErr loc pat
; return $ L loc match }
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)
let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann
- return (ann,makeFunBind fun is_infix
- [L match_span (Match (Just (fun,is_infix)) ps opt_sig grhss)])
+ return (ann,makeFunBind fun
+ [L match_span (Match (FunBindMatch fun is_infix)
+ ps opt_sig grhss)])
-- The span of the match covers the entire equation.
-- 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
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
-makeFunBind fn is_infix ms
- = FunBind { fun_id = fn, fun_infix = is_infix,
+makeFunBind fn ms
+ = FunBind { fun_id = fn,
fun_matches = mkMatchGroup FromSource ms,
fun_co_fn = idHsWrapper,
bind_fvs = placeHolderNames,
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 159ed8bc1c..8db6603f0f 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -471,15 +471,15 @@ rnBind _ bind@(PatBind { pat_lhs = pat
return (bind', bndrs, all_fvs) }
rnBind sig_fn bind@(FunBind { fun_id = name
- , fun_infix = is_infix
, fun_matches = matches })
-- invariant: no free vars here when it's a FunBind
= do { let plain_name = unLoc name
; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-- bindSigTyVars tests for Opt_ScopedTyVars
- rnMatchGroup (FunRhs plain_name is_infix)
+ rnMatchGroup (FunRhs plain_name)
rnLExpr matches
+ ; let is_infix = isInfixFunBind bind
; when is_infix $ checkPrecMatch plain_name matches'
; mod <- getModule
@@ -1059,22 +1059,23 @@ rnMatch' :: Outputable (body RdrName) => HsMatchContext Name
-> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
-> Match RdrName (Located (body RdrName))
-> 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 })
= do { -- Result type signatures are no longer supported
case maybe_rhs_sig of
Nothing -> return ()
Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
+ ; let isinfix = isInfixMatch match
-- Now the main event
-- 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
- (FunRhs funid isinfix,Just (L lf _,_))
- -> Just (L lf funid,isinfix)
- _ -> Nothing
- ; return (Match { m_fun_id_infix = mf', m_pats = pats'
+ (FunRhs funid,FunBindMatch (L lf _) _)
+ -> FunBindMatch (L lf funid) isinfix
+ _ -> NonFunBindMatch
+ ; return (Match { m_fixity = mf', m_pats = pats'
, m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
emptyCaseErr :: HsMatchContext Name -> SDoc
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index dc2a38229c..76ef03785b 100644
--- a/compiler/typecheck/TcArrows.hs
+++ b/compiler/typecheck/TcArrows.hs
@@ -246,7 +246,7 @@ tc_cmd env
tcPats LambdaExpr pats arg_tys $
tc_grhss grhss cmd_stk' res_ty
- ; let match' = L mtch_loc (Match Nothing pats' Nothing grhss')
+ ; let match' = L mtch_loc (Match NonFunBindMatch pats' Nothing grhss')
arg_tys = map hsLPatType pats'
cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys
, mg_res_ty = res_ty, mg_origin = origin })
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 2cf517d280..9f96a91c9a 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -1340,7 +1340,7 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur
-> TcM (LHsBinds TcId, [MonoBindInfo])
tcMonoBinds is_rec sig_fn no_gen
- [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
+ [ L b_loc (FunBind { fun_id = L nm_loc name,
fun_matches = matches, bind_fvs = fvs })]
-- Single function binding,
| NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
@@ -1357,10 +1357,10 @@ tcMonoBinds is_rec sig_fn no_gen
-- We extend the error context even for a non-recursive
-- function so that in type error messages we show the
-- type of the thing whose rhs we are type checking
- tcMatchesFun name inf matches rhs_ty
+ tcMatchesFun name matches rhs_ty
; return (unitBag $ L b_loc $
- FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
+ FunBind { fun_id = L nm_loc mono_id,
fun_matches = matches', bind_fvs = fvs,
fun_co_fn = co_fn, fun_tick = [] },
[(name, Nothing, mono_id)]) }
@@ -1400,7 +1400,7 @@ tcMonoBinds _ sig_fn no_gen binds
-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
data TcMonoBind -- Half completed; LHS done, RHS not done
- = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name (LHsExpr Name))
+ = TcFunBind MonoBindInfo SrcSpan (MatchGroup Name (LHsExpr Name))
| TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
type MonoBindInfo = (Name, Maybe TcIdSigInfo, TcId)
@@ -1408,7 +1408,7 @@ type MonoBindInfo = (Name, Maybe TcIdSigInfo, TcId)
-- the monomorphic bound things
tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
-tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
+tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
| Just (TcIdSig sig) <- sig_fn name
, TISI { sig_bndr = s_bndr, sig_tau = tau } <- sig
= ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
@@ -1424,12 +1424,12 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matc
-> addErrCtxt (typeSigCtxt s_bndr) $
emitWildcardHoleConstraints nwcs
CompleteSig {} -> return ()
- ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
+ ; return (TcFunBind (name, Just sig, mono_id) nm_loc matches) }
| otherwise
= do { mono_ty <- newFlexiTyVarTy openTypeKind
; mono_id <- newNoSigLetBndr no_gen name mono_ty
- ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
+ ; return (TcFunBind (name, Nothing, mono_id) nm_loc matches) }
-- TODO: emit Hole Constraints for wildcards
tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
@@ -1456,13 +1456,13 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
-------------------
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
-tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc inf matches)
+tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc matches)
= tcExtendForRhs [info] $
tcExtendTyVarEnv2 (lexically_scoped_tvs mb_sig) $
do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
- ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
+ ; (co_fn, matches') <- tcMatchesFun (idName mono_id)
matches (idType mono_id)
- ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
+ ; return (FunBind { fun_id = L loc mono_id
, fun_matches = matches'
, fun_co_fn = co_fn
, bind_fvs = placeHolderNamesTc
@@ -1511,7 +1511,7 @@ getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo tc_binds
= foldr (get_info . unLoc) [] tc_binds
where
- get_info (TcFunBind info _ _ _) rest = info : rest
+ get_info (TcFunBind info _ _) rest = info : rest
get_info (TcPatBind infos _ _ _) rest = infos ++ rest
{-
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index 70afae44ae..81dfb6cc52 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -63,12 +63,12 @@ so it must be prepared to use tcGen to skolemise it.
See Note [sig_tau may be polymorphic] in TcPat.
-}
-tcMatchesFun :: Name -> Bool
+tcMatchesFun :: Name
-> MatchGroup Name (LHsExpr Name)
-> TcSigmaType -- Expected type of function
-> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
-- Returns type of body
-tcMatchesFun fun_name inf matches exp_ty
+tcMatchesFun fun_name matches exp_ty
= do { -- Check that they all have the same no of arguments
-- Location is in the monad, set the caller so that
-- any inter-equation error messages get some vaguely
@@ -88,7 +88,7 @@ tcMatchesFun fun_name inf matches exp_ty
arity = matchGroupArity matches
herald = ptext (sLit "The equation(s) for")
<+> quotes (ppr fun_name) <+> ptext (sLit "have")
- match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
+ match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody }
{-
@tcMatchesCase@ doesn't do the argument-count check because the
@@ -189,7 +189,7 @@ tcMatch ctxt pat_tys rhs_ty match
= add_match_ctxt match $
do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
- ; return (Match Nothing pats' Nothing grhss') }
+ ; return (Match NonFunBindMatch pats' Nothing grhss') }
tc_grhss ctxt Nothing grhss rhs_ty
= tcGRHSs ctxt grhss rhs_ty -- No result signature
diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot
index 50bad30aa7..5fea21d53d 100644
--- a/compiler/typecheck/TcMatches.hs-boot
+++ b/compiler/typecheck/TcMatches.hs-boot
@@ -10,7 +10,7 @@ tcGRHSsPat :: GRHSs Name (LHsExpr Name)
-> TcRhoType
-> TcM (GRHSs TcId (LHsExpr TcId))
-tcMatchesFun :: Name -> Bool
+tcMatchesFun :: Name
-> MatchGroup Name (LHsExpr Name)
-> TcRhoType
-> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index aec7ac83b0..094d3f62af 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -351,7 +351,6 @@ tcPatSynMatcher (L loc name) lpat
}
; let bind = FunBind{ fun_id = L loc matcher_id
- , fun_infix = False
, fun_matches = mg
, fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet
@@ -426,7 +425,6 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
| otherwise = match_group
bind = FunBind { fun_id = L loc (idName builder_id)
- , fun_infix = False
, fun_matches = match_group'
, fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNamesTc
@@ -458,8 +456,8 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
RecordPatSyn args -> map recordPatSynPatVar args
add_dummy_arg :: MatchGroup Name (LHsExpr Name) -> MatchGroup Name (LHsExpr Name)
- add_dummy_arg mg@(MG { mg_alts = [L loc (Match Nothing [] ty grhss)] })
- = mg { mg_alts = [L loc (Match Nothing [nlWildPatName] ty grhss)] }
+ add_dummy_arg mg@(MG {mg_alts = [L l (Match NonFunBindMatch [] ty grhss)] })
+ = mg { mg_alts = [L l (Match NonFunBindMatch [nlWildPatName] ty grhss)] }
add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
pprMatches (PatSyn :: HsMatchContext Name) other_mg
View Lorry Controller Status