Commit af89d687 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Reject top-level banged bindings

Bizarrely, we were not rejecting
  !x = e

Fix:

* In the test in DsBinds.dsTopLHsBinds, use isBangedHsBind, not
  isBangedPatBind.  (Indeed the latter dies altogther.)

* Implement isBangedHsBind in HsUtils;
  be sure to handle AbsBinds

All this was shown up by Trac #13594
parent 3ab342eb
......@@ -80,7 +80,7 @@ dsTopLHsBinds binds
-- see Note [Strict binds checks]
| not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
= do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds
; mapBagM_ (top_level_err "strict pattern bindings") bang_binds
; mapBagM_ (top_level_err "strict bindings") bang_binds
; return nilOL }
| otherwise
......@@ -94,7 +94,7 @@ dsTopLHsBinds binds
where
unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
bang_binds = filterBag (isBangedPatBind . unLoc) binds
bang_binds = filterBag (isBangedHsBind . unLoc) binds
top_level_err desc (L loc bind)
= putSrcSpanDs loc $
......@@ -152,7 +152,7 @@ dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches
| xopt LangExt.Strict dflags
, matchGroupArity matches == 0 -- no need to force lambdas
= [id]
| isBangedBind b
| isBangedHsBind b
= [id]
| otherwise
= []
......@@ -603,7 +603,7 @@ We define an "unlifted bind" to be any bind that binds an unlifted id. Note that
is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind.
Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind.
Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind.
Define a "strict bind" to be either an unlifted bind or a banged bind.
The restrictions are:
......
......@@ -29,7 +29,7 @@ module HsPat (
mkPrefixConPat, mkCharLitPat, mkNilPat,
looksLazyPatBind,
isBangedLPat, isBangedPatBind,
isBangedLPat,
hsPatNeedsParens,
isIrrefutableHsPat,
......@@ -558,10 +558,6 @@ patterns are treated specially, of course.
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
-}
isBangedPatBind :: HsBind p -> Bool
isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat
isBangedPatBind _ = False
isBangedLPat :: LPat p -> Bool
isBangedLPat (L _ (ParPat p)) = isBangedLPat p
isBangedLPat (L _ (BangPat {})) = True
......
......@@ -72,7 +72,7 @@ module HsUtils(
noRebindableInfo,
-- Collecting binders
isUnliftedHsBind, isBangedBind,
isUnliftedHsBind, isBangedHsBind,
collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
collectHsIdBinders,
......@@ -844,14 +844,18 @@ isUnliftedHsBind bind
where
is_unlifted_id id = isUnliftedType (idType id)
-- | Is a binding a strict variable bind (e.g. @!x = ...@)?
isBangedBind :: HsBind GhcTc -> Bool
isBangedBind b | isBangedPatBind b = True
isBangedBind (FunBind {fun_matches = matches})
-- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?
isBangedHsBind :: HsBind GhcTc -> Bool
isBangedHsBind (AbsBinds { abs_binds = binds })
= anyBag (isBangedHsBind . unLoc) binds
isBangedHsBind (FunBind {fun_matches = matches})
| [L _ match] <- unLoc $ mg_alts matches
, FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
= True
isBangedBind _ = False
isBangedHsBind (PatBind {pat_lhs = pat})
= isBangedLPat pat
isBangedHsBind _
= False
collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL]
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
......
T13594.hs:8:1: error:
Top-level strict bindings aren't allowed: !x = (1, 2)
......@@ -556,7 +556,7 @@ test('T13474', normal, compile, [''])
test('T13524', normal, compile, [''])
test('T13509', normal, compile, [''])
test('T13526', normal, compile, [''])
test('T13594', normal, compile, [''])
test('T13594', normal, compile_fail, [''])
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'])
......
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