Reject top-level banged bindings
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 31 Jul 2017 12:22:38 +0000 (13:22 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 31 Jul 2017 12:36:49 +0000 (13:36 +0100)
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

compiler/deSugar/DsBinds.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsUtils.hs
testsuite/tests/typecheck/should_compile/T13594.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T

index ae23a76..41aeb93 100644 (file)
@@ -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:
index edf2e1b..5caf1a0 100644 (file)
@@ -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
index 5be757f..f409c2a 100644 (file)
@@ -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 (file)
index 0000000..57810cc
--- /dev/null
@@ -0,0 +1,3 @@
+
+T13594.hs:8:1: error:
+    Top-level strict bindings aren't allowed: !x = (1, 2)
index 2ce4e91..c18c73b 100644 (file)
@@ -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'])