Commit 37299536 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

Treat banged bindings as FunBinds

This reworks the HsSyn representation to make banged variable patterns
(e.g. !x = e) be represented as FunBinds instead of PatBinds, adding a flag to
FunRhs to record the bang.

Fixes #13594.

Reviewers: austin, goldfire, alanz, simonpj

Reviewed By: simonpj

Subscribers: simonpj, rwbarton, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D3525
parent b99bae6d
...@@ -1742,9 +1742,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun ...@@ -1742,9 +1742,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
(ppr_match, pref) (ppr_match, pref)
= case kind of = case kind of
FunRhs (L _ fun) _ -> (pprMatchContext kind, FunRhs (L _ fun) _ _ -> (pprMatchContext kind,
\ pp -> ppr fun <+> pp) \ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp) _ -> (pprMatchContext kind, \ pp -> pp)
ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
ppr_pats kind pats ppr_pats kind pats
......
...@@ -142,7 +142,7 @@ dsHsBind dflags ...@@ -142,7 +142,7 @@ dsHsBind dflags
(FunBind { fun_id = L _ fun, fun_matches = matches (FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick }) , fun_co_fn = co_fn, fun_tick = tick })
= do { (args, body) <- matchWrapper = do { (args, body) <- matchWrapper
(FunRhs (noLoc $ idName fun) Prefix) (mkPrefixFunRhs (noLoc $ idName fun))
Nothing matches Nothing matches
; core_wrap <- dsHsWrapper co_fn ; core_wrap <- dsHsWrapper co_fn
; let body' = mkOptTickBox tick body ; let body' = mkOptTickBox tick body
...@@ -333,7 +333,7 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts ...@@ -333,7 +333,7 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
addDictsDs (toTcTypeBag (listToBag dicts)) $ addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check -- addDictsDs: push type constraints deeper for pattern match check
do { (args, body) <- matchWrapper do { (args, body) <- matchWrapper
(FunRhs (noLoc $ idName global) Prefix) (mkPrefixFunRhs (noLoc $ idName global))
Nothing matches Nothing matches
; core_wrap <- dsHsWrapper co_fn ; core_wrap <- dsHsWrapper co_fn
; let body' = mkOptTickBox tick body ; let body' = mkOptTickBox tick body
......
...@@ -200,7 +200,7 @@ dsUnliftedBind (FunBind { fun_id = L l fun ...@@ -200,7 +200,7 @@ dsUnliftedBind (FunBind { fun_id = L l fun
, fun_tick = tick }) 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 (L l $ idName fun) Prefix) = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
Nothing matches Nothing matches
; MASSERT( null args ) -- Functions aren't lifted ; MASSERT( null args ) -- Functions aren't lifted
; MASSERT( isIdHsWrapper co_fn ) ; MASSERT( isIdHsWrapper co_fn )
......
...@@ -140,7 +140,7 @@ cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName)) ...@@ -140,7 +140,7 @@ cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))
cvtDec (TH.ValD pat body ds) cvtDec (TH.ValD pat body ds)
| TH.VarP s <- pat | TH.VarP s <- pat
= do { s' <- vNameL s = do { s' <- vNameL s
; cl' <- cvtClause (FunRhs s' Prefix) (Clause [] body ds) ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] } ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
| otherwise | otherwise
...@@ -159,7 +159,7 @@ cvtDec (TH.FunD nm cls) ...@@ -159,7 +159,7 @@ cvtDec (TH.FunD nm cls)
<+> text "has no equations") <+> text "has no equations")
| otherwise | otherwise
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
; cls' <- mapM (cvtClause (FunRhs nm' Prefix)) cls ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
; returnJustL $ Hs.ValD $ mkFunBind nm' cls' } ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
cvtDec (TH.SigD nm typ) cvtDec (TH.SigD nm typ)
...@@ -375,7 +375,7 @@ cvtDec (TH.PatSynD nm args dir pat) ...@@ -375,7 +375,7 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDir _ Unidir = return Unidirectional cvtDir _ Unidir = return Unidirectional
cvtDir _ ImplBidir = return ImplicitBidirectional cvtDir _ ImplBidir = return ImplicitBidirectional
cvtDir n (ExplBidir cls) = cvtDir n (ExplBidir cls) =
do { ms <- mapM (cvtClause (FunRhs n Prefix)) cls do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms } ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
cvtDec (TH.PatSynSigD nm ty) cvtDec (TH.PatSynSigD nm ty)
......
...@@ -132,12 +132,41 @@ type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) ...@@ -132,12 +132,41 @@ type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
-- | Located Haskell Binding with separate Left and Right identifier types -- | Located Haskell Binding with separate Left and Right identifier types
type LHsBindLR idL idR = Located (HsBindLR idL idR) type LHsBindLR idL idR = Located (HsBindLR idL idR)
{- Note [Varieties of binding pattern matches]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The distinction between FunBind and PatBind is a bit subtle. FunBind covers
patterns which resemble function bindings and simple variable bindings.
f x = e
f !x = e
f = e
!x = e -- FunRhs has SrcStrict
x `f` y = e -- FunRhs has Infix
The actual patterns and RHSs of a FunBind are encoding in fun_matches.
The m_ctxt field of Match will be FunRhs and carries two bits of information
about the match,
* the mc_strictness field describes whether the match is decorated with a bang
(e.g. `!x = e`)
* the mc_fixity field describes the fixity of the function binder
By contrast, PatBind represents data constructor patterns, as well as a few
other interesting cases. Namely,
Just x = e
(x) = e
x :: Ty = e
-}
-- | Haskell Binding with separate Left and Right id's -- | Haskell Binding with separate Left and Right id's
data HsBindLR idL idR data HsBindLR idL idR
= -- | Function Binding = -- | Function-like Binding
-- --
-- FunBind is used for both functions @f x = e@ -- FunBind is used for both functions @f x = e@
-- and variables @f = \x -> e@ -- and variables @f = \x -> e@
-- and strict variables @!x = x + 1@
-- --
-- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'. -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
-- --
...@@ -148,6 +177,10 @@ data HsBindLR idL idR ...@@ -148,6 +177,10 @@ data HsBindLR idL idR
-- parses as a pattern binding, just like -- parses as a pattern binding, just like
-- @(f :: a -> a) = ... @ -- @(f :: a -> a) = ... @
-- --
-- Strict bindings have their strictness recorded in the 'SrcStrictness' of their
-- 'MatchContext'. See Note [Varities of binding pattern matches] for
-- details about the relationship between FunBind and PatBind.
--
-- 'ApiAnnotation.AnnKeywordId's -- 'ApiAnnotation.AnnKeywordId's
-- --
-- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches
...@@ -188,7 +221,10 @@ data HsBindLR idL idR ...@@ -188,7 +221,10 @@ data HsBindLR idL idR
-- | Pattern Binding -- | Pattern Binding
-- --
-- The pattern is never a simple variable; -- The pattern is never a simple variable;
-- That case is done by FunBind -- That case is done by FunBind.
-- See Note [Varities of binding pattern matches] for details about the
-- relationship between FunBind and PatBind.
-- --
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang', -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
......
...@@ -1454,8 +1454,8 @@ Example infix function definition requiring individual API Annotations ...@@ -1454,8 +1454,8 @@ Example infix function definition requiring individual API Annotations
isInfixMatch :: Match id body -> Bool isInfixMatch :: Match id body -> Bool
isInfixMatch match = case m_ctxt match of isInfixMatch match = case m_ctxt match of
FunRhs _ Infix -> True FunRhs {mc_fixity = Infix} -> True
_ -> False _ -> False
isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup :: MatchGroup id body -> Bool
isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
...@@ -1534,7 +1534,7 @@ pprMatch match ...@@ -1534,7 +1534,7 @@ pprMatch match
ctxt = m_ctxt match ctxt = m_ctxt match
(herald, other_pats) (herald, other_pats)
= case ctxt of = case ctxt of
FunRhs (L _ fun) fixity FunRhs {mc_fun=L _ fun, mc_fixity=fixity}
| fixity == Prefix -> (pprPrefixOcc fun, m_pats match) | fixity == Prefix -> (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
...@@ -2333,9 +2333,17 @@ pp_dotdot = text " .. " ...@@ -2333,9 +2333,17 @@ pp_dotdot = text " .. "
-- | Haskell Match Context -- | Haskell Match Context
-- --
-- Context of a Match -- Context of a pattern match. This is more subtle than it would seem. See Note
-- [Varieties of pattern matches].
data HsMatchContext id data HsMatchContext id
= FunRhs (Located id) LexicalFixity -- ^Function binding for f, fixity = FunRhs { mc_fun :: Located id -- ^ function binder of @f@
, mc_fixity :: LexicalFixity -- ^ fixing of @f@
, mc_strictness :: SrcStrictness
-- ^ was the pattern banged? See
-- Note [Varities of binding pattern matches]
}
-- ^A pattern matching on an argument of a
-- function binding
| 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
...@@ -2356,7 +2364,8 @@ data HsMatchContext id ...@@ -2356,7 +2364,8 @@ data HsMatchContext id
deriving instance (DataIdPost id) => Data (HsMatchContext id) deriving instance (DataIdPost id) => Data (HsMatchContext id)
instance OutputableBndr id => Outputable (HsMatchContext id) where instance OutputableBndr id => Outputable (HsMatchContext id) where
ppr (FunRhs (L _ id) fix) = text "FunRhs" <+> ppr id <+> ppr fix ppr (FunRhs (L _ id) fix str)
= text "FunRhs" <+> ppr id <+> ppr fix <+> ppr str
ppr LambdaExpr = text "LambdaExpr" ppr LambdaExpr = text "LambdaExpr"
ppr CaseAlt = text "CaseAlt" ppr CaseAlt = text "CaseAlt"
ppr IfAlt = text "IfAlt" ppr IfAlt = text "IfAlt"
...@@ -2441,7 +2450,8 @@ pprMatchContext ctxt ...@@ -2441,7 +2450,8 @@ pprMatchContext ctxt
pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id)
=> HsMatchContext id -> SDoc => HsMatchContext id -> SDoc
pprMatchContextNoun (FunRhs (L _ fun) _) = text "equation for" pprMatchContextNoun (FunRhs {mc_fun=L _ fun})
= text "equation for"
<+> quotes (ppr fun) <+> quotes (ppr fun)
pprMatchContextNoun CaseAlt = text "case alternative" pprMatchContextNoun CaseAlt = text "case alternative"
pprMatchContextNoun IfAlt = text "multi-way if alternative" pprMatchContextNoun IfAlt = text "multi-way if alternative"
...@@ -2501,13 +2511,13 @@ instance (Outputable id, Outputable (NameOrRdrName id)) ...@@ -2501,13 +2511,13 @@ instance (Outputable id, Outputable (NameOrRdrName id))
-- Used to generate the string for a *runtime* error message -- Used to generate the string for a *runtime* error message
matchContextErrString :: Outputable id matchContextErrString :: Outputable id
=> HsMatchContext id -> SDoc => HsMatchContext id -> SDoc
matchContextErrString (FunRhs (L _ fun) _) = text "function" <+> ppr fun matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case" matchContextErrString CaseAlt = text "case"
matchContextErrString IfAlt = text "multi-way if" matchContextErrString IfAlt = text "multi-way if"
matchContextErrString PatBindRhs = text "pattern binding" matchContextErrString PatBindRhs = text "pattern binding"
matchContextErrString RecUpd = text "record update" matchContextErrString RecUpd = text "record update"
matchContextErrString LambdaExpr = text "lambda" matchContextErrString LambdaExpr = text "lambda"
matchContextErrString ProcExpr = text "proc" matchContextErrString ProcExpr = text "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
......
...@@ -22,7 +22,7 @@ module HsUtils( ...@@ -22,7 +22,7 @@ module HsUtils(
-- Terms -- Terms
mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsCaseAlt, mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsCaseAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatch, mkHsLam, mkHsIf, mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
mkHsDictLet, mkHsLams, mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
...@@ -748,9 +748,13 @@ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] ...@@ -748,9 +748,13 @@ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsExpr RdrName -> LHsBind RdrName -> LHsExpr RdrName -> LHsBind RdrName
mk_easy_FunBind loc fun pats expr mk_easy_FunBind loc fun pats expr
= L loc $ mkFunBind (L loc fun) = L loc $ mkFunBind (L loc fun)
[mkMatch (FunRhs (L loc fun) Prefix) pats expr [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
(noLoc emptyLocalBinds)] (noLoc emptyLocalBinds)]
-- | Make a prefix, non-strict function 'HsMatchContext'
mkPrefixFunRhs :: Located id -> HsMatchContext id
mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict
------------ ------------
mkMatch :: HsMatchContext (NameOrRdrName id) -> [LPat id] -> LHsExpr id mkMatch :: HsMatchContext (NameOrRdrName id) -> [LPat id] -> LHsExpr id
-> Located (HsLocalBinds id) -> LMatch id (LHsExpr id) -> Located (HsLocalBinds id) -> LMatch id (LHsExpr id)
......
...@@ -2181,20 +2181,28 @@ docdecld :: { LDocDecl } ...@@ -2181,20 +2181,28 @@ docdecld :: { LDocDecl }
decl_no_th :: { LHsDecl RdrName } decl_no_th :: { LHsDecl RdrName }
: sigdecl { $1 } : sigdecl { $1 }
| '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) }; | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)
pat <- checkPattern empty e; -- Turn it all into an expression so that
_ <- ams (sLL $1 $> ()) -- checkPattern can check that bangs are enabled
(fst $ unLoc $3); ; l = comb2 $1 $> };
return $ sLL $1 $> $ ValD $ (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
PatBind pat (snd $ unLoc $3) -- Depending upon what the pattern looks like we might get either
placeHolderType -- a FunBind or PatBind back from checkValDef. See Note
placeHolderNames -- [Varieties of binding pattern matches]
([],[]) } } case r of {
-- Turn it all into an expression so that (FunBind n _ _ _ _) ->
-- checkPattern can check that bangs are enabled ams (L l ()) [mj AnnFunId n] >> return () ;
(PatBind (L lh _lhs) _rhs _ _ _) ->
| infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3; ams (L lh ()) [] >> return () } ;
_ <- ams (L l ()) (ann ++ fst (unLoc $3)) ;
return $! (sL l $ ValD r) } }
| infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
let { l = comb2 $1 $> }; let { l = comb2 $1 $> };
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
-- [Varieties of binding pattern matches]
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 () ;
......
...@@ -514,9 +514,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = ...@@ -514,9 +514,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
wrongNameBindingErr loc decl wrongNameBindingErr loc decl
; match <- case details of ; match <- case details of
PrefixCon pats -> PrefixCon pats ->
return $ Match (FunRhs ln Prefix) pats Nothing rhs return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs
InfixCon pat1 pat2 -> InfixCon pat1 pat2 ->
return $ Match (FunRhs ln Infix) [pat1, pat2] Nothing rhs return $ Match (FunRhs ln Infix NoSrcStrict) [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
...@@ -923,25 +923,27 @@ patIsRec e = e == mkUnqual varName (fsLit "rec") ...@@ -923,25 +923,27 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
-- Check Equation Syntax -- Check Equation Syntax
checkValDef :: SDoc checkValDef :: SDoc
-> SrcStrictness
-> LHsExpr RdrName -> LHsExpr RdrName
-> Maybe (LHsType RdrName) -> Maybe (LHsType RdrName)
-> Located (a,GRHSs RdrName (LHsExpr RdrName)) -> Located (a,GRHSs RdrName (LHsExpr RdrName))
-> P ([AddAnn],HsBind RdrName) -> P ([AddAnn],HsBind RdrName)
checkValDef msg lhs (Just sig) grhss checkValDef msg _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding -- x :: ty = rhs parses as a *pattern* binding
= checkPatBind msg (L (combineLocs lhs sig) = checkPatBind msg (L (combineLocs lhs sig)
(ExprWithTySig lhs (mkLHsSigWcType sig))) grhss (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
checkValDef msg lhs opt_sig g@(L l (_,grhss)) checkValDef msg strictness lhs opt_sig g@(L l (_,grhss))
= do { mb_fun <- isFunLhs lhs = do { mb_fun <- isFunLhs lhs
; case mb_fun of ; case mb_fun of
Just (fun, is_infix, pats, ann) -> Just (fun, is_infix, pats, ann) ->
checkFunBind msg ann (getLoc lhs) checkFunBind msg strictness ann (getLoc lhs)
fun is_infix pats opt_sig (L l grhss) fun is_infix pats opt_sig (L l grhss)
Nothing -> checkPatBind msg lhs g } Nothing -> checkPatBind msg lhs g }
checkFunBind :: SDoc checkFunBind :: SDoc
-> SrcStrictness
-> [AddAnn] -> [AddAnn]
-> SrcSpan -> SrcSpan
-> Located RdrName -> Located RdrName
...@@ -950,13 +952,13 @@ checkFunBind :: SDoc ...@@ -950,13 +952,13 @@ checkFunBind :: SDoc
-> Maybe (LHsType RdrName) -> Maybe (LHsType RdrName)
-> Located (GRHSs RdrName (LHsExpr RdrName)) -> Located (GRHSs RdrName (LHsExpr RdrName))
-> P ([AddAnn],HsBind RdrName) -> P ([AddAnn],HsBind RdrName)
checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
= do ps <- checkPatterns msg pats = do ps <- checkPatterns msg pats
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 return (ann, makeFunBind fun
[L match_span (Match { m_ctxt = FunRhs fun is_infix [L match_span (Match { m_ctxt = FunRhs fun is_infix strictness
, m_pats = ps , m_pats = ps
, m_type = opt_sig , m_type = opt_sig
, m_grhss = grhss })]) , m_grhss = grhss })])
......
...@@ -482,7 +482,7 @@ rnBind sig_fn bind@(FunBind { fun_id = name ...@@ -482,7 +482,7 @@ rnBind sig_fn bind@(FunBind { fun_id = name
; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-- bindSigTyVars tests for LangExt.ScopedTyVars -- bindSigTyVars tests for LangExt.ScopedTyVars
rnMatchGroup (FunRhs name Prefix) rnMatchGroup (mkPrefixFunRhs name)
rnLExpr matches rnLExpr matches
; let is_infix = isInfixFunBind bind ; let is_infix = isInfixFunBind bind
; when is_infix $ checkPrecMatch plain_name matches' ; when is_infix $ checkPrecMatch plain_name matches'
...@@ -667,7 +667,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name ...@@ -667,7 +667,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
ExplicitBidirectional mg -> ExplicitBidirectional mg ->
do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $ do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $
rnMatchGroup (FunRhs (L l name) Prefix) rnMatchGroup (mkPrefixFunRhs (L l name))
rnLExpr mg rnLExpr mg
; return (ExplicitBidirectional mg', fvs) } ; return (ExplicitBidirectional mg', fvs) }
...@@ -1148,8 +1148,8 @@ rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats ...@@ -1148,8 +1148,8 @@ rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
; rnPats ctxt pats $ \ pats' -> do ; rnPats ctxt pats $ \ pats' -> do
{ (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
; let mf' = case (ctxt,mf) of ; let mf' = case (ctxt,mf) of
(FunRhs (L _ funid) _,FunRhs (L lf _) _) (FunRhs (L _ funid) _ _,FunRhs (L lf _) _ _)
-> FunRhs (L lf funid) fixity -> FunRhs (L lf funid) fixity NoSrcStrict -- TODO: Is this right?
_ -> ctxt _ -> ctxt
; return (Match { m_ctxt = mf', m_pats = pats' ; return (Match { m_ctxt = mf', m_pats = pats'
, m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }} , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
......
...@@ -1510,7 +1510,7 @@ makeG_d. ...@@ -1510,7 +1510,7 @@ makeG_d.
gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Lift_binds loc tycon gen_Lift_binds loc tycon
| null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR) | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
[mkMatch (FunRhs (L loc lift_RDR) Prefix) [mkMatch (mkPrefixFunRhs (L loc lift_RDR))
[nlWildPat] errorMsg_Expr [nlWildPat] errorMsg_Expr
(noLoc emptyLocalBinds)]) (noLoc emptyLocalBinds)])
, emptyBag) , emptyBag)
...@@ -1655,7 +1655,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty ...@@ -1655,7 +1655,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
mk_bind :: Id -> LHsBind RdrName mk_bind :: Id -> LHsBind RdrName
mk_bind meth_id mk_bind meth_id
= mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
(FunRhs (L loc meth_RDR) Prefix) (mkPrefixFunRhs (L loc meth_RDR))
[] rhs_expr] [] rhs_expr]
where where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
...@@ -1844,7 +1844,7 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName ...@@ -1844,7 +1844,7 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
mkFunBindSE arity loc fun pats_and_exprs mkFunBindSE arity loc fun pats_and_exprs
= mkRdrFunBindSE arity (L loc fun) matches = mkRdrFunBindSE arity (L loc fun) matches
where where
matches = [mkMatch (FunRhs (L loc fun) Prefix) p e matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e
(noLoc emptyLocalBinds) (noLoc emptyLocalBinds)
| (p,e) <-pats_and_exprs] | (p,e) <-pats_and_exprs]
...@@ -1874,7 +1874,7 @@ mkRdrFunBindEC arity catch_all ...@@ -1874,7 +1874,7 @@ mkRdrFunBindEC arity catch_all
-- which can happen with -XEmptyDataDecls -- which can happen with -XEmptyDataDecls
-- See Trac #4302 -- See Trac #4302
matches' = if null matches matches' = if null matches
then [mkMatch (FunRhs fun Prefix) then [mkMatch (mkPrefixFunRhs fun)
(replicate (arity - 1) nlWildPat ++ [z_Pat]) (replicate (arity - 1) nlWildPat ++ [z_Pat])
(catch_all $ nlHsCase z_Expr []) (catch_all $ nlHsCase z_Expr [])
(noLoc emptyLocalBinds)] (noLoc emptyLocalBinds)]
...@@ -1894,7 +1894,7 @@ mkRdrFunBindSE arity ...@@ -1894,7 +1894,7 @@ mkRdrFunBindSE arity
-- which can happen with -XEmptyDataDecls -- which can happen with -XEmptyDataDecls
-- See Trac #4302 -- See Trac #4302
matches' = if null matches matches' = if null matches
then [mkMatch (FunRhs fun Prefix) then [mkMatch (mkPrefixFunRhs fun)
(replicate arity nlWildPat) (replicate arity nlWildPat)
(error_Expr str) (noLoc emptyLocalBinds)] (error_Expr str) (noLoc emptyLocalBinds)]
else matches else matches
......
...@@ -15,7 +15,6 @@ module TcGenFunctor ( ...@@ -15,7 +15,6 @@ module TcGenFunctor (
gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds
) where ) where
import BasicTypes ( LexicalFixity(..) )
import Bag import Bag
import DataCon import DataCon
import FastString import FastString
...@@ -137,7 +136,7 @@ gen_Functor_binds loc tycon ...@@ -137,7 +136,7 @@ gen_Functor_binds loc tycon
fmap_eqns = [mkSimpleMatch fmap_match_ctxt fmap_eqns = [mkSimpleMatch fmap_match_ctxt
[nlWildPat] [nlWildPat]
coerce_Expr] coerce_Expr]