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
(ppr_match, pref)
= case kind of
FunRhs (L _ fun) _ -> (pprMatchContext kind,
\ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp)
FunRhs (L _ fun) _ _ -> (pprMatchContext kind,
\ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp)
ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
ppr_pats kind pats
......
......@@ -142,7 +142,7 @@ dsHsBind dflags
(FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick })
= do { (args, body) <- matchWrapper
(FunRhs (noLoc $ idName fun) Prefix)
(mkPrefixFunRhs (noLoc $ idName fun))
Nothing matches
; core_wrap <- dsHsWrapper co_fn
; let body' = mkOptTickBox tick body
......@@ -333,7 +333,7 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check
do { (args, body) <- matchWrapper
(FunRhs (noLoc $ idName global) Prefix)
(mkPrefixFunRhs (noLoc $ idName global))
Nothing matches
; core_wrap <- dsHsWrapper co_fn
; let body' = mkOptTickBox tick body
......
......@@ -200,7 +200,7 @@ dsUnliftedBind (FunBind { fun_id = L l fun
, 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 (L l $ idName fun) Prefix)
= do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
Nothing matches
; MASSERT( null args ) -- Functions aren't lifted
; MASSERT( isIdHsWrapper co_fn )
......
......@@ -140,7 +140,7 @@ cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))
cvtDec (TH.ValD pat body ds)
| TH.VarP s <- pat
= 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'] }
| otherwise
......@@ -159,7 +159,7 @@ cvtDec (TH.FunD nm cls)
<+> text "has no equations")
| otherwise
= do { nm' <- vNameL nm
; cls' <- mapM (cvtClause (FunRhs nm' Prefix)) cls
; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
cvtDec (TH.SigD nm typ)
......@@ -375,7 +375,7 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDir _ Unidir = return Unidirectional
cvtDir _ ImplBidir = return ImplicitBidirectional
cvtDir n (ExplBidir cls) =
do { ms <- mapM (cvtClause (FunRhs n Prefix)) cls
do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
cvtDec (TH.PatSynSigD nm ty)
......
......@@ -132,12 +132,41 @@ type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
-- | Located Haskell Binding with separate Left and Right identifier types
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
data HsBindLR idL idR
= -- | Function Binding
= -- | Function-like Binding
--
-- FunBind is used for both functions @f x = e@
-- and variables @f = \x -> e@
-- and strict variables @!x = x + 1@
--
-- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
--
......@@ -148,6 +177,10 @@ data HsBindLR idL idR
-- parses as a pattern binding, just like
-- @(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.AnnFunId', attached to each element of fun_matches
......@@ -188,7 +221,10 @@ data HsBindLR idL idR
-- | Pattern Binding
--
-- 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.AnnEqual','ApiAnnotation.AnnWhere',
......
......@@ -1454,8 +1454,8 @@ Example infix function definition requiring individual API Annotations
isInfixMatch :: Match id body -> Bool
isInfixMatch match = case m_ctxt match of
FunRhs _ Infix -> True
_ -> False
FunRhs {mc_fixity = Infix} -> True
_ -> False
isEmptyMatchGroup :: MatchGroup id body -> Bool
isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
......@@ -1534,7 +1534,7 @@ pprMatch match
ctxt = m_ctxt match
(herald, other_pats)
= case ctxt of
FunRhs (L _ fun) fixity
FunRhs {mc_fun=L _ fun, mc_fixity=fixity}
| fixity == Prefix -> (pprPrefixOcc fun, m_pats match)
-- f x y z = e
-- Not pprBndr; the AbsBinds will
......@@ -2333,9 +2333,17 @@ pp_dotdot = text " .. "
-- | 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
= 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
| CaseAlt -- ^Patterns and guards on a case alternative
| IfAlt -- ^Guards of a multi-way if alternative
......@@ -2356,7 +2364,8 @@ data HsMatchContext id
deriving instance (DataIdPost id) => Data (HsMatchContext id)
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 CaseAlt = text "CaseAlt"
ppr IfAlt = text "IfAlt"
......@@ -2441,7 +2450,8 @@ pprMatchContext ctxt
pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id)
=> HsMatchContext id -> SDoc
pprMatchContextNoun (FunRhs (L _ fun) _) = text "equation for"
pprMatchContextNoun (FunRhs {mc_fun=L _ fun})
= text "equation for"
<+> quotes (ppr fun)
pprMatchContextNoun CaseAlt = text "case alternative"
pprMatchContextNoun IfAlt = text "multi-way if alternative"
......@@ -2501,13 +2511,13 @@ instance (Outputable id, Outputable (NameOrRdrName id))
-- Used to generate the string for a *runtime* error message
matchContextErrString :: Outputable id
=> HsMatchContext id -> SDoc
matchContextErrString (FunRhs (L _ fun) _) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case"
matchContextErrString IfAlt = text "multi-way if"
matchContextErrString PatBindRhs = text "pattern binding"
matchContextErrString RecUpd = text "record update"
matchContextErrString LambdaExpr = text "lambda"
matchContextErrString ProcExpr = text "proc"
matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case"
matchContextErrString IfAlt = text "multi-way if"
matchContextErrString PatBindRhs = text "pattern binding"
matchContextErrString RecUpd = text "record update"
matchContextErrString LambdaExpr = text "lambda"
matchContextErrString ProcExpr = text "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
......
......@@ -22,7 +22,7 @@ module HsUtils(
-- Terms
mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsCaseAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
......@@ -748,9 +748,13 @@ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsExpr RdrName -> LHsBind RdrName
mk_easy_FunBind loc fun pats expr
= L loc $ mkFunBind (L loc fun)
[mkMatch (FunRhs (L loc fun) Prefix) pats expr
[mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
(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
-> Located (HsLocalBinds id) -> LMatch id (LHsExpr id)
......
......@@ -2181,20 +2181,28 @@ docdecld :: { LDocDecl }
decl_no_th :: { LHsDecl RdrName }
: sigdecl { $1 }
| '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) };
pat <- checkPattern empty e;
_ <- ams (sLL $1 $> ())
(fst $ unLoc $3);
return $ sLL $1 $> $ ValD $
PatBind pat (snd $ unLoc $3)
placeHolderType
placeHolderNames
([],[]) } }
-- Turn it all into an expression so that
-- checkPattern can check that bangs are enabled
| infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
| '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)
-- Turn it all into an expression so that
-- checkPattern can check that bangs are enabled
; l = comb2 $1 $> };
(ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
-- 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 {
(FunBind n _ _ _ _) ->
ams (L l ()) [mj AnnFunId n] >> return () ;
(PatBind (L lh _lhs) _rhs _ _ _) ->
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 $> };
-- 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 {
(FunBind n _ _ _ _) ->
ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
......
......@@ -514,9 +514,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
wrongNameBindingErr loc decl
; match <- case details of
PrefixCon pats ->
return $ Match (FunRhs ln Prefix) pats Nothing rhs
return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs
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
; return $ L loc match }
fromDecl (L loc decl) = extraDeclErr loc decl
......@@ -923,25 +923,27 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
-- Check Equation Syntax
checkValDef :: SDoc
-> SrcStrictness
-> LHsExpr RdrName
-> Maybe (LHsType RdrName)
-> Located (a,GRHSs RdrName (LHsExpr 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
= checkPatBind msg (L (combineLocs lhs sig)
(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
; case mb_fun of
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)
Nothing -> checkPatBind msg lhs g }
checkFunBind :: SDoc
-> SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
......@@ -950,13 +952,13 @@ checkFunBind :: SDoc
-> Maybe (LHsType RdrName)
-> Located (GRHSs RdrName (LHsExpr 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
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
[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_type = opt_sig
, m_grhss = grhss })])
......
......@@ -482,7 +482,7 @@ rnBind sig_fn bind@(FunBind { fun_id = name
; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-- bindSigTyVars tests for LangExt.ScopedTyVars
rnMatchGroup (FunRhs name Prefix)
rnMatchGroup (mkPrefixFunRhs name)
rnLExpr matches
; let is_infix = isInfixFunBind bind
; when is_infix $ checkPrecMatch plain_name matches'
......@@ -667,7 +667,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
ExplicitBidirectional mg ->
do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $
rnMatchGroup (FunRhs (L l name) Prefix)
rnMatchGroup (mkPrefixFunRhs (L l name))
rnLExpr mg
; return (ExplicitBidirectional mg', fvs) }
......@@ -1148,8 +1148,8 @@ rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
; rnPats ctxt pats $ \ pats' -> do
{ (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
; let mf' = case (ctxt,mf) of
(FunRhs (L _ funid) _,FunRhs (L lf _) _)
-> FunRhs (L lf funid) fixity
(FunRhs (L _ funid) _ _,FunRhs (L lf _) _ _)
-> FunRhs (L lf funid) fixity NoSrcStrict -- TODO: Is this right?
_ -> ctxt
; return (Match { m_ctxt = mf', m_pats = pats'
, m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
......
......@@ -1510,7 +1510,7 @@ makeG_d.
gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Lift_binds loc tycon
| 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
(noLoc emptyLocalBinds)])
, emptyBag)
......@@ -1655,7 +1655,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
mk_bind :: Id -> LHsBind RdrName
mk_bind meth_id
= mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
(FunRhs (L loc meth_RDR) Prefix)
(mkPrefixFunRhs (L loc meth_RDR))
[] rhs_expr]
where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
......@@ -1844,7 +1844,7 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
mkFunBindSE arity loc fun pats_and_exprs
= mkRdrFunBindSE arity (L loc fun) matches
where
matches = [mkMatch (FunRhs (L loc fun) Prefix) p e
matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e
(noLoc emptyLocalBinds)
| (p,e) <-pats_and_exprs]
......@@ -1874,7 +1874,7 @@ mkRdrFunBindEC arity catch_all
-- which can happen with -XEmptyDataDecls
-- See Trac #4302
matches' = if null matches
then [mkMatch (FunRhs fun Prefix)
then [mkMatch (mkPrefixFunRhs fun)
(replicate (arity - 1) nlWildPat ++ [z_Pat])
(catch_all $ nlHsCase z_Expr [])
(noLoc emptyLocalBinds)]
......@@ -1894,7 +1894,7 @@ mkRdrFunBindSE arity
-- which can happen with -XEmptyDataDecls
-- See Trac #4302
matches' = if null matches
then [mkMatch (FunRhs fun Prefix)
then [mkMatch (mkPrefixFunRhs fun)
(replicate arity nlWildPat)
(error_Expr str) (noLoc emptyLocalBinds)]
else matches
......
......@@ -15,7 +15,6 @@ module TcGenFunctor (
gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds
) where
import BasicTypes ( LexicalFixity(..) )
import Bag
import DataCon
import FastString
......@@ -137,7 +136,7 @@ gen_Functor_binds loc tycon
fmap_eqns = [mkSimpleMatch fmap_match_ctxt
[nlWildPat]
coerce_Expr]
fmap_match_ctxt = FunRhs fmap_name Prefix
fmap_match_ctxt = mkPrefixFunRhs fmap_name
gen_Functor_binds loc tycon
= (listToBag [fmap_bind, replace_bind], emptyBag)
......@@ -147,7 +146,7 @@ gen_Functor_binds loc tycon
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
fmap_match_ctxt = FunRhs fmap_name Prefix
fmap_match_ctxt = mkPrefixFunRhs fmap_name
fmap_eqn con = flip evalState bs_RDRs $
match_for_con fmap_match_ctxt [f_Pat] con =<< parts
......@@ -182,7 +181,7 @@ gen_Functor_binds loc tycon
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
replace_match_ctxt = FunRhs replace_name Prefix
replace_match_ctxt = mkPrefixFunRhs replace_name
replace_eqn con = flip evalState bs_RDRs $
match_for_con replace_match_ctxt [z_Pat] con =<< parts
......@@ -651,7 +650,7 @@ gen_Foldable_binds loc tycon
foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
[nlWildPat, nlWildPat]
mempty_Expr]
foldMap_match_ctxt = FunRhs foldMap_name Prefix
foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
gen_Foldable_binds loc tycon
| null data_cons -- There's no real point producing anything but
......@@ -694,7 +693,7 @@ gen_Foldable_binds loc tycon
go (NullM a) = Just (Just a)
null_name = L loc null_RDR
null_match_ctxt = FunRhs null_name Prefix
null_match_ctxt = mkPrefixFunRhs null_name
null_bind = mkRdrFunBind null_name null_eqns
null_eqns = map null_eqn data_cons
null_eqn con
......@@ -878,7 +877,7 @@ gen_Traversable_binds loc tycon
[mkSimpleMatch traverse_match_ctxt
[nlWildPat, z_Pat]
(nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
traverse_match_ctxt = FunRhs traverse_name Prefix
traverse_match_ctxt = mkPrefixFunRhs traverse_name
gen_Traversable_binds loc tycon
= (unitBag traverse_bind, emptyBag)
......
......@@ -1566,7 +1566,7 @@ mkDefMethBind clas inst_tys sel_id dm_name
, tyConBinderArgFlag tcb /= Inferred ]
rhs = foldl mk_vta (nlHsVar dm_name) visible_inst_tys
bind = noLoc $ mkTopFunBind Generated fn $
[mkSimpleMatch (FunRhs fn Prefix) [] rhs]
[mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
(vcat [ppr clas <+> ppr inst_tys,
......
......@@ -21,7 +21,6 @@ module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambd
import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma
, tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
import BasicTypes ( LexicalFixity(..) )
import HsSyn
import TcRnMonad
import TcEnv
......@@ -98,7 +97,7 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty
arity = matchGroupArity matches
herald = text "The equation(s) for"
<+> quotes (ppr fun_name) <+> text "have"
match_ctxt = MC { mc_what = FunRhs fn Prefix, mc_body = tcBody }
match_ctxt = MC { mc_what = mkPrefixFunRhs fn, mc_body = tcBody }
{-
@tcMatchesCase@ doesn't do the argument-count check because the
......
......@@ -442,7 +442,7 @@ tcPatSynMatcher (L loc name) lpat
, mg_res_ty = res_ty
, mg_origin = Generated
}
match = mkMatch (FunRhs (L loc name) Prefix) []
match = mkMatch (mkPrefixFunRhs (L loc name)) []
(mkHsLams (rr_tv:res_tv:univ_tvs)
req_dicts body')
(noLoc EmptyLocalBinds)
......@@ -563,7 +563,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
mk_mg body = mkMatchGroup Generated [builder_match]
where
builder_args = [L loc (VarPat (L loc n)) | L loc n <- args]
builder_match = mkMatch (FunRhs (L loc name) Prefix)
builder_match = mkMatch (mkPrefixFunRhs (L loc name))
builder_args body
(noLoc EmptyLocalBinds)
......
......@@ -1973,7 +1973,7 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
; uniq <- newUnique
; interPrintName <- getInteractivePrintName
; let fresh_it = itName uniq loc
matches = [mkMatch (FunRhs (L loc fresh_it) Prefix) [] rn_expr
matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr
(noLoc emptyLocalBinds)]
-- [it = expr]
the_bind = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs }
......
......@@ -864,10 +864,10 @@ mkOneRecordSelector all_cons idDetails fl
-- where cons_w_field = [C2,C7]
sel_bind = mkTopFunBind Generated sel_lname alts
where
alts | is_naughty = [mkSimpleMatch (FunRhs sel_lname Prefix)
alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
[] unit_rhs]
| otherwise = map mk_match cons_w_field ++ deflt
mk_match con = mkSimpleMatch (FunRhs sel_lname Prefix)
mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
[L loc (mk_sel_pat con)]
(L loc (HsVar (L loc field_var)))
mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
......
......@@ -204,7 +204,8 @@
(FunRhs
({ DumpParsedAst.hs:11:1-4 }
(Unqual {OccName: main}))
(Prefix))
(Prefix)
(NoSrcStrict))
[]
(Nothing)
(GRHSs
......
......@@ -17,7 +17,8 @@
(Match
(FunRhs
({ DumpRenamedAst.hs:11:1-4 }{Name: main:DumpRenamedAst.main{v}})
(Prefix))
(Prefix)
(NoSrcStrict))
[]
(Nothing)
(GRHSs
......
......@@ -244,7 +244,8 @@
(Match
(FunRhs
({ DumpTypecheckedAst.hs:11:1-4 }{Name: main:DumpTypecheckedAst.main{v}})
(Prefix))
(Prefix)
(NoSrcStrict))
[]
(Nothing)
(GRHSs
......
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Bug where
x :: forall a b. (a ~ Integer, b ~ Integer) => (a, b)
!x = (1, 2)
......@@ -107,3 +107,4 @@ test('T10582', expect_broken(10582), compile, [''])
test('DumpParsedAst', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
test('DumpRenamedAst', normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
test('DumpTypecheckedAst', normal, compile, ['-dsuppress-uniques -ddump-tc-ast'])
test('T13594', normal, compile, [''])
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