summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/Check.hs6
-rw-r--r--compiler/deSugar/DsBinds.hs29
-rw-r--r--compiler/deSugar/DsUtils.hs14
-rw-r--r--compiler/deSugar/Match.hs9
-rw-r--r--compiler/hsSyn/HsBinds.hs40
-rw-r--r--compiler/hsSyn/HsExpr.hs28
-rw-r--r--compiler/hsSyn/HsUtils.hs15
-rw-r--r--compiler/parser/Parser.y34
-rw-r--r--compiler/parser/RdrHsSyn.hs22
-rw-r--r--compiler/rename/RnBinds.hs4
-rw-r--r--compiler/typecheck/TcMatches.hs9
-rw-r--r--testsuite/tests/ghc-api/annotations/T10358.stdout6
-rw-r--r--testsuite/tests/parser/should_compile/DumpParsedAst.stderr3
-rw-r--r--testsuite/tests/parser/should_compile/DumpRenamedAst.stderr3
-rw-r--r--testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr3
-rw-r--r--testsuite/tests/perf/compiler/all.T4
-rw-r--r--testsuite/tests/typecheck/should_compile/all.T2
-rwxr-xr-xtestsuite/tests/typecheck/should_run/all.T2
18 files changed, 172 insertions, 61 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 19bdba658f..cb9837ed0c 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -1740,9 +1740,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 GhcTc] -> SDoc
ppr_pats kind pats
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 2a0abca5de..f03f586d33 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -140,8 +140,8 @@ dsHsBind dflags
; return (force_var, [core_bind]) }
dsHsBind dflags
- (FunBind { fun_id = L _ fun, fun_matches = matches
- , fun_co_fn = co_fn, fun_tick = tick })
+ b@(FunBind { fun_id = L _ fun, fun_matches = matches
+ , fun_co_fn = co_fn, fun_tick = tick })
= do { (args, body) <- matchWrapper
(mkPrefixFunRhs (noLoc $ idName fun))
Nothing matches
@@ -149,12 +149,16 @@ dsHsBind dflags
; let body' = mkOptTickBox tick body
rhs = core_wrap (mkLams args body')
core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
- force_var =
- if xopt LangExt.Strict dflags
- && matchGroupArity matches == 0 -- no need to force lambdas
- then [id]
- else []
- ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
+ force_var
+ -- Bindings are strict when -XStrict is enabled
+ | xopt LangExt.Strict dflags
+ , matchGroupArity matches == 0 -- no need to force lambdas
+ = [id]
+ | isBangedBind b
+ = [id]
+ | otherwise
+ = []
+ ; --pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun) $$ ppr (mg_alts matches) $$ ppr args $$ ppr core_binds) $
return (force_var, [core_binds]) }
dsHsBind dflags
@@ -182,11 +186,11 @@ dsHsBind dflags
| ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
, not (xopt LangExt.Strict dflags) -- Handle strict binds
- , not (anyBag (isBangedPatBind . unLoc) binds) -- in the next case
+ , not (anyBag (isBangedBind . unLoc) binds) -- in the next case
= -- See Note [AbsBinds wrappers] in HsBinds
addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check
- do { (_, bind_prs) <- dsLHsBinds binds
+ do { (force_vars, bind_prs) <- dsLHsBinds binds
; ds_binds <- dsTcEvBinds_s ev_binds
; core_wrap <- dsHsWrapper wrap -- Usually the identity
@@ -201,7 +205,8 @@ dsHsBind dflags
main_bind = makeCorePair dflags global' (isDefaultMethod prags)
(dictArity dicts) rhs
- ; return ([], main_bind : fromOL spec_binds) }
+ ; ASSERT(null force_vars)
+ return ([], main_bind : fromOL spec_binds) }
-- Another common case: no tyvars, no dicts
-- In this case we can have a much simpler desugaring
@@ -343,6 +348,8 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
| xopt LangExt.Strict dflags
, matchGroupArity matches == 0 -- no need to force lambdas
= [global]
+ | isBangedBind (unLoc bind)
+ = [global]
| otherwise
= []
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index 4ef279faed..a1f3a143f3 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -35,7 +35,7 @@ module DsUtils (
mkSelectorBinds,
selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
- mkOptTickBox, mkBinaryTickBox, decideBangHood
+ mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang
) where
#include "HsVersions.h"
@@ -995,3 +995,15 @@ decideBangHood dflags lpat
LazyPat lp' -> lp'
BangPat _ -> lp
_ -> L l (BangPat lp)
+
+-- | Unconditionally make a 'Pat' strict.
+addBang :: LPat id -- ^ Original pattern
+ -> LPat id -- ^ Banged pattern
+addBang = go
+ where
+ go lp@(L l p)
+ = case p of
+ ParPat p -> L l (ParPat (go p))
+ LazyPat lp' -> L l (BangPat lp')
+ BangPat _ -> lp
+ _ -> L l (BangPat lp)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 19f70363d0..a870c6f9c3 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -749,9 +749,14 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
matchEquations ctxt new_vars eqns_info rhs_ty
; return (new_vars, result_expr) }
where
- mk_eqn_info vars (L _ (Match _ pats _ grhss))
+ mk_eqn_info vars (L _ (Match ctx pats _ grhss))
= do { dflags <- getDynFlags
- ; let upats = map (unLoc . decideBangHood dflags) pats
+ ; let add_bang
+ | FunRhs {mc_strictness=SrcStrict} <- ctx
+ = pprTrace "addBang" empty addBang
+ | otherwise
+ = decideBangHood dflags
+ upats = map (unLoc . add_bang) pats
dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars
; tm_cs <- genCaseTmCs2 mb_scr upats vars
; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index d0c345a9e5..f08a6af700 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -129,12 +129,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'.
--
@@ -145,6 +174,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 [Varieties 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
@@ -185,7 +218,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 [Varieties of binding pattern matches] for details about the
+ -- relationship between FunBind and PatBind.
+
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index cfc9d177bd..016b02fe2f 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1461,8 +1461,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
@@ -1543,7 +1543,10 @@ pprMatch match
ctxt = m_ctxt match
(herald, other_pats)
= case ctxt of
- FunRhs (L _ fun) fixity
+ FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}
+ | strictness == SrcStrict -> ASSERT(null $ m_pats match)
+ (char '!'<>pprPrefixOcc fun, m_pats match)
+ -- a strict variable binding
| fixity == Prefix -> (pprPrefixOcc fun, m_pats match)
-- f x y z = e
-- Not pprBndr; the AbsBinds will
@@ -2353,9 +2356,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 -- Not an extensible tag
- = 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 [Varieties 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
@@ -2376,7 +2387,7 @@ data HsMatchContext id -- Not an extensible tag
deriving instance (Data id) => Data (HsMatchContext id)
instance OutputableBndr id => Outputable (HsMatchContext id) where
- ppr (FunRhs (L _ id) fix) = text "FunRhs" <+> ppr id <+> ppr fix
+ ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
ppr LambdaExpr = text "LambdaExpr"
ppr CaseAlt = text "CaseAlt"
ppr IfAlt = text "IfAlt"
@@ -2462,7 +2473,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"
@@ -2522,7 +2534,7 @@ instance (Outputable p, Outputable (NameOrRdrName p))
-- 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 (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case"
matchContextErrString IfAlt = text "multi-way if"
matchContextErrString PatBindRhs = text "pattern binding"
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index c1a9a2f252..ba001ea7ff 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -72,7 +72,7 @@ module HsUtils(
noRebindableInfo,
-- Collecting binders
- isUnliftedHsBind,
+ isUnliftedHsBind, isBangedBind,
collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
collectHsIdBinders,
@@ -756,9 +756,9 @@ mk_easy_FunBind loc fun pats expr
[mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
(noLoc emptyLocalBinds)]
--- | Make a prefix 'FunRhs' 'HsMatchContext'
+-- | Make a prefix, non-strict function 'HsMatchContext'
mkPrefixFunRhs :: Located id -> HsMatchContext id
-mkPrefixFunRhs n = FunRhs n Prefix
+mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict
------------
mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p
@@ -859,6 +859,15 @@ isUnliftedHsBind bind
-- would get type forall a. Num a => (# a, Bool #)
-- and we want to reject that. See Trac #9140
+-- | Is a binding a strict variable bind (e.g. @!x = ...@)?
+isBangedBind :: HsBind GhcTc -> Bool
+isBangedBind b | isBangedPatBind b = True
+isBangedBind (FunBind {fun_matches = matches})
+ | [L _ match] <- unLoc $ mg_alts matches
+ , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
+ = True
+isBangedBind _ = False
+
collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL]
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
-- No pattern synonyms here
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 02aeb86180..6e4b7740d5 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2181,20 +2181,28 @@ docdecld :: { LDocDecl }
decl_no_th :: { LHsDecl GhcPs }
: 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) ++ [mj AnnBang $1]) ;
+ 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 () ;
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index eb78073b66..f2c8b33000 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -515,9 +515,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
@@ -925,25 +925,27 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
-- Check Equation Syntax
checkValDef :: SDoc
+ -> SrcStrictness
-> LHsExpr GhcPs
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-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
@@ -952,13 +954,13 @@ checkFunBind :: SDoc
-> Maybe (LHsType GhcPs)
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-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 })])
@@ -1072,6 +1074,12 @@ isFunLhs e = go e [] []
go (L _ (HsApp f e)) es ann = go f (e:es) ann
go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
+ -- Things of the form `!x` are also FunBinds
+ -- See Note [Varieties of binding pattern matches]
+ go (L _ (SectionR (L _ (HsVar (L _ bang))) (L l (HsVar (L _ var))))) [] ann
+ | bang == bang_RDR
+ , not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann))
+
-- For infix function defns, there should be only one infix *function*
-- (though there may be infix *datacons* involved too). So we don't
-- need fixity info to figure out which function is being defined.
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 5d6d037e6e..e18068bc2b 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -1168,8 +1168,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 _) _ strict)
+ -> FunRhs (L lf funid) fixity strict
_ -> ctxt
; return (Match { m_ctxt = mf', m_pats = pats'
, m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index c228b53fa3..8207169d41 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -22,6 +22,7 @@ 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 +99,13 @@ 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 = mkPrefixFunRhs fn, mc_body = tcBody }
+ match_ctxt = MC { mc_what = FunRhs fn Prefix strictness, mc_body = tcBody }
+ strictness
+ | [L _ match] <- unLoc $ mg_alts matches
+ , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
+ = SrcStrict
+ | otherwise
+ = NoSrcStrict
{-
@tcMatchesCase@ doesn't do the argument-count check because the
diff --git a/testsuite/tests/ghc-api/annotations/T10358.stdout b/testsuite/tests/ghc-api/annotations/T10358.stdout
index ae1ec8587f..1854b2d116 100644
--- a/testsuite/tests/ghc-api/annotations/T10358.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10358.stdout
@@ -11,12 +11,14 @@
((Test10358.hs:(4,1)-(8,6),AnnSemi), [Test10358.hs:9:1]),
((Test10358.hs:(5,3)-(8,6),AnnIn), [Test10358.hs:8:3-4]),
((Test10358.hs:(5,3)-(8,6),AnnLet), [Test10358.hs:5:3-5]),
-((Test10358.hs:5:7-10,AnnBang), [Test10358.hs:5:7]),
+((Test10358.hs:5:7-16,AnnBang), [Test10358.hs:5:7]),
((Test10358.hs:5:7-16,AnnEqual), [Test10358.hs:5:12]),
+((Test10358.hs:5:7-16,AnnFunId), [Test10358.hs:5:8-10]),
((Test10358.hs:5:7-16,AnnSemi), [Test10358.hs:5:17]),
((Test10358.hs:5:14-16,AnnVal), [Test10358.hs:5:15]),
-((Test10358.hs:5:19-22,AnnBang), [Test10358.hs:5:19]),
+((Test10358.hs:5:19-32,AnnBang), [Test10358.hs:5:19]),
((Test10358.hs:5:19-32,AnnEqual), [Test10358.hs:5:24]),
+((Test10358.hs:5:19-32,AnnFunId), [Test10358.hs:5:20-22]),
((Test10358.hs:5:19-32,AnnSemi), [Test10358.hs:6:7]),
((Test10358.hs:5:26-32,AnnVal), [Test10358.hs:5:29]),
((Test10358.hs:6:7-16,AnnEqual), [Test10358.hs:6:10]),
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index 9f9cf659d4..ad3680e578 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -204,7 +204,8 @@
(FunRhs
({ DumpParsedAst.hs:11:1-4 }
(Unqual {OccName: main}))
- (Prefix))
+ (Prefix)
+ (NoSrcStrict))
[]
(Nothing)
(GRHSs
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index d0b456a2cb..c873ee148b 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -17,7 +17,8 @@
(Match
(FunRhs
({ DumpRenamedAst.hs:11:1-4 }{Name: main:DumpRenamedAst.main{v}})
- (Prefix))
+ (Prefix)
+ (NoSrcStrict))
[]
(Nothing)
(GRHSs
diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
index 4b10222262..663a7d7f2e 100644
--- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
@@ -244,7 +244,8 @@
(Match
(FunRhs
({ DumpTypecheckedAst.hs:11:1-4 }{Name: main:DumpTypecheckedAst.main{v}})
- (Prefix))
+ (Prefix)
+ (NoSrcStrict))
[]
(Nothing)
(GRHSs
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 9c88cdc86c..f53a84c671 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -1131,7 +1131,9 @@ test('MultiLayerModules',
test('T13701',
[ compiler_stats_num_field('bytes allocated',
[(platform('x86_64-apple-darwin'), 2217187888, 10),
- (wordsize(64), 2511285600, 10),
+ (wordsize(64), 2188045288, 10),
+ # initial: 2511285600
+ # 2017-06-23: 2188045288 treat banged variable bindings as FunBinds
]),
pre_cmd('./genT13701'),
extra_files(['genT13701']),
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 72d33c1d1c..dc7bd7b707 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -556,7 +556,7 @@ test('T13474', normal, compile, [''])
test('T13524', normal, compile, [''])
test('T13509', normal, compile, [''])
test('T13526', normal, compile, [''])
-test('T13594', expect_broken(13594), compile, [''])
+test('T13594', normal, compile, [''])
test('T13603', normal, compile, [''])
test('T13333', normal, compile, [''])
test('T13585', [extra_files(['T13585.hs', 'T13585a.hs', 'T13585b.hs'])], run_command, ['$MAKE -s --no-print-directory T13585'])
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index ab5ab4287c..346c312649 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -122,4 +122,4 @@ test('Typeable1', normal, compile_fail, [''])
test('TypeableEq', normal, compile_and_run, [''])
test('T13435', normal, compile_and_run, [''])
test('T11715', exit_code(1), compile_and_run, [''])
-test('T13594a', expect_broken(13594), ghci_script, ['T13594a.script'])
+test('T13594a', normal, ghci_script, ['T13594a.script'])
View Lorry Controller Status