[commit: ghc] master: Better error messages for new per-instance overlap flags and Safe Haskell. (91c15d6)

[git at git.haskell.org]

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

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

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

commit 91c15d65187c98bf7be5e71a247501f97611867a
Author: David Terei <code at davidterei.com>
Date:   Mon Aug 4 12:49:07 2014 -0400

    Better error messages for new per-instance overlap flags and Safe
    Haskell.


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

91c15d65187c98bf7be5e71a247501f97611867a
 compiler/main/HscMain.hs                                    | 10 +++++++++-
 .../tests/safeHaskell/safeInfered/UnsafeInfered13.stderr    |  2 ++
 .../tests/safeHaskell/safeInfered/UnsafeInfered14.stderr    |  2 ++
 .../tests/safeHaskell/safeInfered/UnsafeInfered15.stderr    |  2 ++
 .../safeInfered/{UnsafeInfered15.hs => UnsafeInfered16.hs}  |  6 ++++++
 .../tests/safeHaskell/safeInfered/UnsafeInfered16.stderr    | 13 +++++++++++++
 testsuite/tests/safeHaskell/safeInfered/all.T               |  1 +
 7 files changed, 35 insertions(+), 1 deletion(-)

diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 3f4af8d..bec66f8 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1025,13 +1025,21 @@ markUnsafe tcg_env whyUnsafe = do
     whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
                          , text "Reason:"
                          , nest 4 $ (vcat $ badFlags df) $+$
-                                    (vcat $ pprErrMsgBagWithLoc whyUnsafe)
+                                    (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$
+                                    (vcat $ badInsts $ tcg_insts tcg_env)
                          ]
     badFlags df   = concat $ map (badFlag df) unsafeFlagsForInfer
     badFlag df (str,loc,on,_)
         | on df     = [mkLocMessage SevOutput (loc df) $
                             text str <+> text "is not allowed in Safe Haskell"]
         | otherwise = []
+    badInsts insts = concat $ map badInst insts
+    badInst ins | overlapMode (is_flag ins) /= NoOverlap
+                = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
+                      ppr (overlapMode $ is_flag ins) <+>
+                      text "overlap mode isn't allowed in Safe Haskell"]
+                | otherwise = []
+
 
 -- | Figure out the final correct safe haskell mode
 hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr
index c545d40..30be0ec 100644
--- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr
@@ -2,6 +2,8 @@
 UnsafeInfered13.hs:1:16: Warning:
     ‘UnsafeInfered13’ has been inferred as unsafe!
     Reason:
+        UnsafeInfered13.hs:8:27:
+            [overlap ok] overlap mode isn't allowed in Safe Haskell
 
 <no location info>: 
 Failing due to -Werror.
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr
index b7c41ac..80d9526 100644
--- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr
@@ -2,6 +2,8 @@
 UnsafeInfered14.hs:1:16: Warning:
     ‘UnsafeInfered14’ has been inferred as unsafe!
     Reason:
+        UnsafeInfered14.hs:8:31:
+            [overlappable] overlap mode isn't allowed in Safe Haskell
 
 <no location info>: 
 Failing due to -Werror.
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr
index dbf2094..44a0202 100644
--- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr
@@ -2,6 +2,8 @@
 UnsafeInfered15.hs:1:16: Warning:
     ‘UnsafeInfered15’ has been inferred as unsafe!
     Reason:
+        UnsafeInfered15.hs:8:30:
+            [overlapping] overlap mode isn't allowed in Safe Haskell
 
 <no location info>: 
 Failing due to -Werror.
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.hs
similarity index 63%
copy from testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.hs
copy to testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.hs
index 427c97b..2df6576 100644
--- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.hs
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.hs
@@ -8,3 +8,9 @@ class C a where
 instance {-# OVERLAPPING #-} C a where
   f _ = "a"
 
+instance {-# OVERLAPS #-} C Int where
+  f _ = "Int"
+
+instance {-# OVERLAPPABLE #-} C Bool where
+  f _ = "Bool"
+
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr
new file mode 100644
index 0000000..21674c4
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr
@@ -0,0 +1,13 @@
+
+UnsafeInfered16.hs:1:16: Warning:
+    ‘UnsafeInfered15’ has been inferred as unsafe!
+    Reason:
+        UnsafeInfered16.hs:8:30:
+            [overlapping] overlap mode isn't allowed in Safe Haskell
+        UnsafeInfered16.hs:11:27:
+            [overlap ok] overlap mode isn't allowed in Safe Haskell
+        UnsafeInfered16.hs:14:31:
+            [overlappable] overlap mode isn't allowed in Safe Haskell
+
+<no location info>: 
+Failing due to -Werror.
diff --git a/testsuite/tests/safeHaskell/safeInfered/all.T b/testsuite/tests/safeHaskell/safeInfered/all.T
index 887ff68..a9600fa 100644
--- a/testsuite/tests/safeHaskell/safeInfered/all.T
+++ b/testsuite/tests/safeHaskell/safeInfered/all.T
@@ -63,6 +63,7 @@ test('UnsafeInfered12', normal, compile_fail, [''])
 test('UnsafeInfered13', normal, compile_fail, [''])
 test('UnsafeInfered14', normal, compile_fail, [''])
 test('UnsafeInfered15', normal, compile_fail, [''])
+test('UnsafeInfered16', normal, compile_fail, [''])
 
 # Mixed tests
 test('Mixed01', normal, compile_fail, [''])