[commit: ghc] master: Improve error message for UNPACK/strictness annotations. (fc33f8b)

[git at git.haskell.org]

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

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

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

commit fc33f8b31b9c23cc12f02a028bbaeab06ba8fe96
Author: HE, Tao <sighingnow at gmail.com>
Date:   Sun Feb 18 11:10:37 2018 -0500

    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 at 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


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

fc33f8b31b9c23cc12f02a028bbaeab06ba8fe96
 compiler/typecheck/TcHsType.hs                       | 13 ++++++++++---
 testsuite/tests/typecheck/should_fail/T14761a.hs     |  3 +++
 testsuite/tests/typecheck/should_fail/T14761a.stderr |  7 +++++++
 testsuite/tests/typecheck/should_fail/T14761b.hs     |  5 +++++
 testsuite/tests/typecheck/should_fail/T14761b.stderr |  7 +++++++
 testsuite/tests/typecheck/should_fail/T7210.stderr   |  1 +
 testsuite/tests/typecheck/should_fail/all.T          |  2 ++
 7 files changed, 35 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 08dc56d..a8b9fe8 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 0000000..f195320
--- /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 0000000..8eb4580
--- /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 0000000..cd51962
--- /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 0000000..8357187
--- /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 a7ee2af..314ffa7 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 b8c3c4c..20ed5a4 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, [''])