[commit: ghc] master: Reject top-level banged bindings (af89d68)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/af89d6872da2e00be738e1ac541346cd84e6d141/ghc

>---------------------------------------------------------------

commit af89d6872da2e00be738e1ac541346cd84e6d141
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jul 31 13:22:38 2017 +0100

    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


>---------------------------------------------------------------

af89d6872da2e00be738e1ac541346cd84e6d141
 compiler/deSugar/DsBinds.hs                            |  8 ++++----
 compiler/hsSyn/HsPat.hs                                |  6 +-----
 compiler/hsSyn/HsUtils.hs                              | 16 ++++++++++------
 testsuite/tests/typecheck/should_compile/T13594.stderr |  3 +++
 testsuite/tests/typecheck/should_compile/all.T         |  2 +-
 5 files changed, 19 insertions(+), 16 deletions(-)

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index ae23a76..41aeb93 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -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:
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index edf2e1b..5caf1a0 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -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
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 5be757f..f409c2a 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -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
diff --git a/testsuite/tests/typecheck/should_compile/T13594.stderr b/testsuite/tests/typecheck/should_compile/T13594.stderr
new file mode 100644
index 0000000..57810cc
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T13594.stderr
@@ -0,0 +1,3 @@
+
+T13594.hs:8:1: error:
+    Top-level strict bindings aren't allowed: !x = (1, 2)
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 2ce4e91..c18c73b 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', 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'])