From 91c15d65187c98bf7be5e71a247501f97611867a Mon Sep 17 00:00:00 2001
From: David Terei <code@davidterei.com>
Date: Mon, 4 Aug 2014 12:49:07 -0400
Subject: Better error messages for new per-instance overlap flags and Safe
 Haskell.

---
 compiler/main/HscMain.hs                                 | 10 +++++++++-
 .../tests/safeHaskell/safeInfered/UnsafeInfered13.stderr |  2 ++
 .../tests/safeHaskell/safeInfered/UnsafeInfered14.stderr |  2 ++
 .../tests/safeHaskell/safeInfered/UnsafeInfered15.stderr |  2 ++
 .../tests/safeHaskell/safeInfered/UnsafeInfered16.hs     | 16 ++++++++++++++++
 .../tests/safeHaskell/safeInfered/UnsafeInfered16.stderr | 13 +++++++++++++
 testsuite/tests/safeHaskell/safeInfered/all.T            |  1 +
 7 files changed, 45 insertions(+), 1 deletion(-)
 create mode 100644 testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.hs
 create mode 100644 testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr

diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 3f4af8d78d..bec66f858a 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 c545d40308..30be0ec32c 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 b7c41ac6c3..80d9526194 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 dbf20949f7..44a0202687 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/UnsafeInfered16.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.hs
new file mode 100644
index 0000000000..2df65765aa
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.hs
@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
+{-# LANGUAGE FlexibleInstances #-}
+module UnsafeInfered15 where
+
+class C a where
+  f :: a -> String
+
+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 0000000000..21674c407b
--- /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 887ff683a8..a9600fa1c2 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, [''])
-- 
cgit v1.2.1