Improve error message for UNPACK/strictness annotations.

Print different error message for improper UNPACK and strictness
annotations.  Fix Trac #14761.

Signed-off-by: HE, Tao <sighingnow@gmail.com>

Test Plan: make test TEST="T7210 T14761a T14761b"

Reviewers: goldfire, bgamari, RyanGlScott, simonpj

Reviewed By: RyanGlScott, simonpj

Subscribers: simonpj, goldfire, rwbarton, thomie, carter

GHC Trac Issues: #14761

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

7 files changed, 35 insertions, 3 deletions

diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 08dc56d18c..a8b9fe8c93 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -559,11 +559,18 @@ tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
 
 tc_hs_type mode (HsParTy ty)   exp_kind = tc_lhs_type mode ty exp_kind
 tc_hs_type mode (HsDocTy ty _) exp_kind = tc_lhs_type mode ty exp_kind
-tc_hs_type _ ty@(HsBangTy {}) _
+tc_hs_type _ ty@(HsBangTy bang _) _
     -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
     -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
-    -- bangs are invalid, so fail. (#7210)
-    = failWithTc (text "Unexpected strictness annotation:" <+> ppr ty)
+    -- bangs are invalid, so fail. (#7210, #14761)
+    = do { let bangError err = failWith $
+                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$
+                 text err <+> text "annotation cannot appear nested inside a type"
+         ; case bang of
+             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"
+             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"
+             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"
+             HsSrcBang _ _ _                   -> bangError "strictness" }
 tc_hs_type _ ty@(HsRecTy _)      _
       -- Record types (which only show up temporarily in constructor
       -- signatures) should have been removed by now
diff --git a/testsuite/tests/typecheck/should_fail/T14761a.hs b/testsuite/tests/typecheck/should_fail/T14761a.hs
new file mode 100644
index 0000000000..f195320186
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14761a.hs
@@ -0,0 +1,3 @@
+module T14761a where
+
+data A = A { a :: {-# UNPACK #-} Maybe Int}
diff --git a/testsuite/tests/typecheck/should_fail/T14761a.stderr b/testsuite/tests/typecheck/should_fail/T14761a.stderr
new file mode 100644
index 0000000000..8eb4580db4
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14761a.stderr
@@ -0,0 +1,7 @@
+
+T14761a.hs:3:19:
+     Unexpected UNPACK annotation: {-# UNPACK #-}Maybe
+      UNPACK annotation cannot appear nested inside a type
+     In the type ‘{-# UNPACK #-}Maybe Int’
+     In the definition of data constructor ‘A’
+     In the data declaration for ‘A’
diff --git a/testsuite/tests/typecheck/should_fail/T14761b.hs b/testsuite/tests/typecheck/should_fail/T14761b.hs
new file mode 100644
index 0000000000..cd5196259f
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14761b.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE BangPatterns #-}
+
+module T14761b where
+
+data A = A { a :: ! Maybe Int}
diff --git a/testsuite/tests/typecheck/should_fail/T14761b.stderr b/testsuite/tests/typecheck/should_fail/T14761b.stderr
new file mode 100644
index 0000000000..8357187928
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T14761b.stderr
@@ -0,0 +1,7 @@
+
+T14761b.hs:5:19:
+     Unexpected strictness annotation: !Maybe
+      strictness annotation cannot appear nested inside a type
+     In the type ‘!Maybe Int’
+     In the definition of data constructor ‘A’
+     In the data declaration for ‘A’
diff --git a/testsuite/tests/typecheck/should_fail/T7210.stderr b/testsuite/tests/typecheck/should_fail/T7210.stderr
index a7ee2afc85..314ffa70e7 100644
--- a/testsuite/tests/typecheck/should_fail/T7210.stderr
+++ b/testsuite/tests/typecheck/should_fail/T7210.stderr
@@ -1,6 +1,7 @@
 
 T7210.hs:5:19:
     Unexpected strictness annotation: !IntMap
+     strictness annotation cannot appear nested inside a type
     In the type ‘!IntMap Int’
     In the definition of data constructor ‘C’
     In the data declaration for ‘T’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index b8c3c4c1eb..20ed5a4ade 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -465,3 +465,5 @@ test('MissingExportList03', normal, compile_fail, [''])
 test('T14618', normal, compile_fail, [''])
 test('T14607', normal, compile, [''])
 test('T14605', normal, compile_fail, [''])
+test('T14761a', normal, compile_fail, [''])
+test('T14761b', normal, compile_fail, [''])