Lower precedence for {-# UNPACK #-}

Test Plan: Validate

Reviewers: goldfire, bgamari

Subscribers: osa1, mpickering, rwbarton, carter

Differential Revision: https://phabricator.haskell.org/D5221

17 files changed, 177 insertions, 45 deletions

diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 9917d960f8..0da9747575 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -1408,23 +1408,36 @@ mergeOps (L l1 (TyElOpd t) : xs)
   = addAnns >> return t'
 mergeOps all_xs = go (0 :: Int) [] id all_xs
   where
-    -- clause (err.1):
-    -- we do not expect to encounter any (NO)UNPACK pragmas
-    go k acc ops_acc (L l (TyElUnpackedness (_, unpkSrc, unpk)):_) =
-      if not (null acc) && (k > 1 || length acc > 1)
-      then failOpUnpackednessCompound (L l unpkSDoc) (ops_acc (mergeAcc acc))
-      else failOpUnpackednessPosition (L l unpkSDoc)
+    -- NB. When modifying clauses in 'go', make sure that the reasoning in
+    -- Note [Non-empty 'acc' in mergeOps clause [end]] is still correct.
+
+    -- clause [unpk]:
+    -- handle (NO)UNPACK pragmas
+    go k acc ops_acc (L l (TyElUnpackedness (anns, unpkSrc, unpk)):xs) =
+      if not (null acc) && null xs
+      then do { let a = ops_acc (mergeAcc acc)
+                    strictMark = HsSrcBang unpkSrc unpk NoSrcStrict
+                    bl = combineSrcSpans l (getLoc a)
+                    bt = HsBangTy noExt strictMark a
+              ; addAnnsAt bl anns
+              ; return (L bl bt) }
+      else parseErrorSDoc l unpkError
       where
         unpkSDoc = case unpkSrc of
           NoSourceText -> ppr unpk
           SourceText str -> text str <> text " #-}"
-
-    -- clause (err.2):
+        unpkError
+          | not (null xs) = unpkSDoc <+> text "cannot appear inside a type."
+          | null acc && k == 0 = unpkSDoc <+> text "must be applied to a type."
+          | otherwise =
+              -- See Note [Impossible case in mergeOps clause [unpk]]
+              panic "mergeOps.UNPACK: impossible position"
+
+    -- clause [doc]:
     -- we do not expect to encounter any docs
     go _ _ _ (L l (TyElDocPrev _):_) =
       failOpDocPrev l
 
-    -- clause (err.3):
     -- to improve error messages, we do a bit of guesswork to determine if the
     -- user intended a '!' or a '~' as a strictness annotation
     go k acc ops_acc (L l x : xs)
@@ -1441,45 +1454,94 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
         then failOpStrictnessCompound (L l str) (ops_acc (mergeAcc acc))
         else failOpStrictnessPosition (L l str)
 
-    -- clause (a):
+    -- clause [opr]:
     -- when we encounter an operator, we must have accumulated
     -- something for its rhs, and there must be something left
     -- to build its lhs.
     go k acc ops_acc (L l (TyElOpr op):xs) =
-      if null acc || null xs
+      if null acc || null (filter isTyElOpd xs)
         then failOpFewArgs (L l op)
         else do { let a = mergeAcc acc
                 ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs }
+      where
+        isTyElOpd (L _ (TyElOpd _)) = True
+        isTyElOpd _ = False
 
-    -- clause (a.1): interpret 'TyElTilde' as an operator
+    -- clause [opr.1]: interpret 'TyElTilde' as an operator
     go k acc ops_acc (L l TyElTilde:xs) =
       let op = eqTyCon_RDR
       in go k acc ops_acc (L l (TyElOpr op):xs)
 
-    -- clause (a.2): interpret 'TyElBang' as an operator
+    -- clause [opr.2]: interpret 'TyElBang' as an operator
     go k acc ops_acc (L l TyElBang:xs) =
       let op = mkUnqual tcClsName (fsLit "!")
       in go k acc ops_acc (L l (TyElOpr op):xs)
 
-    -- clause (b):
+    -- clause [opd]:
     -- whenever an operand is encountered, it is added to the accumulator
     go k acc ops_acc (L l (TyElOpd a):xs) = go k (L l a:acc) ops_acc xs
 
-    -- clause (c):
-    -- at this point we know that 'acc' is non-empty because
-    -- there are three options when 'acc' can be empty:
-    -- 1. 'mergeOps' was called with an empty list, and this
-    --    should never happen
-    -- 2. 'mergeOps' was called with a list where the head is an
-    --    operator, this is handled by clause (a)
-    -- 3. 'mergeOps' was called with a list where the head is an
-    --    operand, this is handled by clause (b)
+    -- clause [end]:
+    -- See Note [Non-empty 'acc' in mergeOps clause [end]]
     go _ acc ops_acc [] =
       return (ops_acc (mergeAcc acc))
 
     mergeAcc [] = panic "mergeOps.mergeAcc: empty input"
     mergeAcc (x:xs) = mkHsAppTys x xs
 
+
+{- Note [Impossible case in mergeOps clause [unpk]]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This case should never occur. Let us consider all possible
+variations of 'acc', 'xs', and 'k':
+
+  acc          xs        k
+==============================
+  null   |    null       0      -- "must be applied to a type"
+  null   |  not null     0      -- "must be applied to a type"
+not null |    null       0      -- successful parse
+not null |  not null     0      -- "cannot appear inside a type"
+  null   |    null      >0      -- handled in clause [opr]
+  null   |  not null    >0      -- "cannot appear inside a type"
+not null |    null      >0      -- successful parse
+not null |  not null    >0      -- "cannot appear inside a type"
+
+The (null acc && null xs && k>0) case is handled in clause [opr]
+by the following check:
+
+    if ... || null (filter isTyElOpd xs)
+     then failOpFewArgs (L l op)
+
+We know that this check has been performed because k>0, and by
+the time we reach the end of the list (null xs), the only way
+for (null acc) to hold is that there was not a single TyElOpd
+between the operator and the end of the list. But this case is
+caught by the check and reported as 'failOpFewArgs'.
+-}
+
+{- Note [Non-empty 'acc' in mergeOps clause [end]]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In clause [end] we need to know that 'acc' is non-empty to call 'mergeAcc'
+without a check.
+
+Running 'mergeOps' with an empty input list is forbidden, so we do not consider
+this possibility. This means we'll hit at least one other clause before we
+reach clause [end].
+
+* Clauses [unpk] and [doc] do not call 'go' recursively, so we cannot hit
+  clause [end] from there.
+* Clause [opd] makes 'acc' non-empty, so if we hit clause [end] after it, 'acc'
+  will be non-empty.
+* Clause [opr] checks that (filter isTyElOpd xs) is not null - so we are going
+  to hit clause [opd] at least once before we reach clause [end], making 'acc'
+  non-empty.
+* There are no other clauses.
+
+Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause
+[end].
+
+-}
+
 pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
 pInfixSide (L l (TyElOpd t):xs)
   | (True, t', addAnns, xs') <- pBangTy (L l t) xs
@@ -2123,18 +2185,6 @@ failOpStrictnessPosition (L loc _) = parseErrorSDoc loc msg
   where
     msg = text "Strictness annotation cannot appear in this position."
 
-failOpUnpackednessCompound :: Located SDoc -> LHsType GhcPs -> P a
-failOpUnpackednessCompound (L _ unpkSDoc) (L loc ty) = parseErrorSDoc loc msg
-  where
-    msg = unpkSDoc <+> text "applied to a compound type." $$
-          text "Did you mean to add parentheses?" $$
-          nest 2 (unpkSDoc <+> parens (ppr ty))
-
-failOpUnpackednessPosition :: Located SDoc -> P a
-failOpUnpackednessPosition (L loc unpkSDoc) = parseErrorSDoc loc msg
-  where
-    msg = unpkSDoc <+> text "cannot appear in this position."
-
 -----------------------------------------------------------------------------
 -- Misc utils
 
diff --git a/docs/users_guide/8.8.1-notes.rst b/docs/users_guide/8.8.1-notes.rst
index 37bad13b5b..f1a14c75fe 100644
--- a/docs/users_guide/8.8.1-notes.rst
+++ b/docs/users_guide/8.8.1-notes.rst
@@ -50,6 +50,15 @@ Language
     data D1 = forall a b. (a + b) => D1 a b
     data D2 = forall a b.  a + b  => D2 a b -- now allowed
 
+- ``{-# UNPACK #-}`` annotation no longer requires parenthesization: ::
+
+    data T = MkT1 { a :: {-# UNPACK #-} (Maybe Int && Bool) }
+           | MkT2 { a :: {-# UNPACK #-}  Maybe Int && Bool  } -- now allowed
+
+    data G where
+      MkG1 :: {-# UNPACK #-} (Maybe Int && Bool) -> G
+      MkG2 :: {-# UNPACK #-}  Maybe Int && Bool  -> G  -- now allowed
+
 - The requirement that kind signatures always be parenthesized has been relaxed.
   For instance, it is now permissible to write ``Proxy '(a :: A, b :: B)``
   (previous GHC versions required extra parens: ``Proxy '((a :: A), (b :: B))``).
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 4612b78e0f..d5c40c1b16 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -134,3 +134,6 @@ test('typeopsDataCon_A', normal, compile_fail, [''])
 test('typeopsDataCon_B', normal, compile_fail, [''])
 test('strictnessDataCon_A', normal, compile_fail, [''])
 test('strictnessDataCon_B', normal, compile_fail, [''])
+test('unpack_empty_type', normal, compile_fail, [''])
+test('unpack_inside_type', normal, compile_fail, [''])
+test('unpack_before_opr', normal, compile_fail, [''])
diff --git a/testsuite/tests/parser/should_fail/strictnessDataCon_A.hs b/testsuite/tests/parser/should_fail/strictnessDataCon_A.hs
index 43851c9b27..1d4d904b62 100644
--- a/testsuite/tests/parser/should_fail/strictnessDataCon_A.hs
+++ b/testsuite/tests/parser/should_fail/strictnessDataCon_A.hs
@@ -1 +1 @@
-type T = MkT { a :: ! + Int }
+type T = MkT { a :: Int + ! }
diff --git a/testsuite/tests/parser/should_fail/strictnessDataCon_A.stderr b/testsuite/tests/parser/should_fail/strictnessDataCon_A.stderr
index 99d1eb88ec..c02d2ee974 100644
--- a/testsuite/tests/parser/should_fail/strictnessDataCon_A.stderr
+++ b/testsuite/tests/parser/should_fail/strictnessDataCon_A.stderr
@@ -1,3 +1,3 @@
 
-strictnessDataCon_A.hs:1:21: error:
+strictnessDataCon_A.hs:1:27: error:
     Strictness annotation cannot appear in this position.
diff --git a/testsuite/tests/parser/should_fail/strictnessDataCon_B.hs b/testsuite/tests/parser/should_fail/strictnessDataCon_B.hs
index 58ba137bee..994b4bad74 100644
--- a/testsuite/tests/parser/should_fail/strictnessDataCon_B.hs
+++ b/testsuite/tests/parser/should_fail/strictnessDataCon_B.hs
@@ -1 +1 @@
-type T = MkT { a :: {-# UNPACK #-} + Int }
+type T = MkT { a :: Int + {-# UNPACK #-} }
diff --git a/testsuite/tests/parser/should_fail/strictnessDataCon_B.stderr b/testsuite/tests/parser/should_fail/strictnessDataCon_B.stderr
index 7b5e239a53..47f85eae8c 100644
--- a/testsuite/tests/parser/should_fail/strictnessDataCon_B.stderr
+++ b/testsuite/tests/parser/should_fail/strictnessDataCon_B.stderr
@@ -1,3 +1,3 @@
 
-strictnessDataCon_B.hs:1:21: error:
-    {-# UNPACK #-} cannot appear in this position.
+strictnessDataCon_B.hs:1:27: error:
+    {-# UNPACK #-} cannot appear inside a type.
diff --git a/testsuite/tests/parser/should_fail/unpack_before_opr.hs b/testsuite/tests/parser/should_fail/unpack_before_opr.hs
new file mode 100644
index 0000000000..e09d036f01
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/unpack_before_opr.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeOperators #-}
+
+module UnpackBeforeOperator where
+
+data a + b
+data T = T { t :: {-# UNPACK #-} + Int }
diff --git a/testsuite/tests/parser/should_fail/unpack_before_opr.stderr b/testsuite/tests/parser/should_fail/unpack_before_opr.stderr
new file mode 100644
index 0000000000..023803c184
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/unpack_before_opr.stderr
@@ -0,0 +1,3 @@
+
+unpack_before_opr.hs:6:34: error:
+    Operator applied to too few arguments: +
diff --git a/testsuite/tests/parser/should_fail/unpack_empty_type.hs b/testsuite/tests/parser/should_fail/unpack_empty_type.hs
new file mode 100644
index 0000000000..6a4ad8ceca
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/unpack_empty_type.hs
@@ -0,0 +1,3 @@
+module UnpackEmptyType where
+
+data T = T { t :: {-# UNPACK #-} }
diff --git a/testsuite/tests/parser/should_fail/unpack_empty_type.stderr b/testsuite/tests/parser/should_fail/unpack_empty_type.stderr
new file mode 100644
index 0000000000..fe520c9317
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/unpack_empty_type.stderr
@@ -0,0 +1,3 @@
+
+unpack_empty_type.hs:3:19: error:
+    {-# UNPACK #-} must be applied to a type.
diff --git a/testsuite/tests/parser/should_fail/unpack_inside_type.hs b/testsuite/tests/parser/should_fail/unpack_inside_type.hs
new file mode 100644
index 0000000000..07e7a63314
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/unpack_inside_type.hs
@@ -0,0 +1,3 @@
+module UnpackInsideType where
+
+data T = T { t :: Maybe {-# UNPACK #-} Int }
diff --git a/testsuite/tests/parser/should_fail/unpack_inside_type.stderr b/testsuite/tests/parser/should_fail/unpack_inside_type.stderr
new file mode 100644
index 0000000000..0c09e63b71
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/unpack_inside_type.stderr
@@ -0,0 +1,3 @@
+
+unpack_inside_type.hs:3:25: error:
+    {-# UNPACK #-} cannot appear inside a type.
diff --git a/testsuite/tests/typecheck/should_compile/T14761c.hs b/testsuite/tests/typecheck/should_compile/T14761c.hs
new file mode 100644
index 0000000000..36e948f93d
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T14761c.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE StrictData, TypeOperators, GADTs #-}
+{-# LANGUAGE StrictData #-}
+
+-- Enable -Werror to fail in case we get this warning:
+--
+--   UNPACK pragma lacks '!' on the first argument of ‘A’
+--
+-- In this test case we expect not to get this warning and succeed
+-- because of -XStrictData, see T14761a for the opposite.
+{-# OPTIONS -Werror #-}
+
+module T14761c where
+
+data A = A { a :: {-# UNPACK #-} Maybe Int }
+
+data x && y = Pair x y
+
+data B = B { b :: {-# UNPACK #-} Maybe Int && [] Char && Int }
+
+data G where
+  MkG2 :: {-# UNPACK #-} Maybe Int && [] Char && Int -> G
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 36cc4b40df..be7ad3d8c6 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -652,3 +652,4 @@ test('T15499', normal, compile, [''])
 test('T15586', normal, compile, [''])
 test('T15368', normal, compile, ['-fdefer-type-errors'])
 test('T15778', normal, compile, [''])
+test('T14761c', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T14761a.hs b/testsuite/tests/typecheck/should_fail/T14761a.hs
index f195320186..b79b883024 100644
--- a/testsuite/tests/typecheck/should_fail/T14761a.hs
+++ b/testsuite/tests/typecheck/should_fail/T14761a.hs
@@ -1,3 +1,20 @@
+{-# LANGUAGE TypeOperators, GADTs #-}
+
+-- Enable -Werror to fail in case we get this warning:
+--
+--   UNPACK pragma lacks '!' on the first argument of ‘A’
+--
+-- In this test case we expect to get this warning and fail,
+-- see T14761c for the opposite.
+{-# OPTIONS -Werror #-}
+
 module T14761a where
 
-data A = A { a :: {-# UNPACK #-} Maybe Int}
+data A = A { a :: {-# UNPACK #-} Maybe Int }
+
+data x && y = Pair x y
+
+data B = B { b :: {-# UNPACK #-} Maybe Int && [] Char && Int }
+
+data G where
+  MkG2 :: {-# UNPACK #-} Maybe Int && [] Char && Int -> G
diff --git a/testsuite/tests/typecheck/should_fail/T14761a.stderr b/testsuite/tests/typecheck/should_fail/T14761a.stderr
index e0e437e934..867cf6dae6 100644
--- a/testsuite/tests/typecheck/should_fail/T14761a.stderr
+++ b/testsuite/tests/typecheck/should_fail/T14761a.stderr
@@ -1,5 +1,15 @@
 
-T14761a.hs:3:34: error:
-    {-# UNPACK #-} applied to a compound type.
-    Did you mean to add parentheses?
-      {-# UNPACK #-} (Maybe Int)
+T14761a.hs:13:10: error: [-Werror]
+    • UNPACK pragma lacks '!' on the first argument of ‘A’
+    • In the definition of data constructor ‘A’
+      In the data type declaration for ‘A’
+
+T14761a.hs:17:10: error: [-Werror]
+    • UNPACK pragma lacks '!' on the first argument of ‘B’
+    • In the definition of data constructor ‘B’
+      In the data type declaration for ‘B’
+
+T14761a.hs:20:3: error: [-Werror]
+    • UNPACK pragma lacks '!' on the first argument of ‘MkG2’
+    • In the definition of data constructor ‘MkG2’
+      In the data type declaration for ‘G’