Warn for Safe Haskell when -XOverlappingInstances or

-XIncoherentInstances turned on.

11 files changed, 82 insertions, 18 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index eb5bb77ac0..0c6639a048 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -774,6 +774,7 @@ data DynFlags = DynFlags {
   thOnLoc               :: SrcSpan,
   newDerivOnLoc         :: SrcSpan,
   overlapInstLoc        :: SrcSpan,
+  incoherentOnLoc       :: SrcSpan,
   pkgTrustOnLoc         :: SrcSpan,
   warnSafeOnLoc         :: SrcSpan,
   warnUnsafeOnLoc       :: SrcSpan,
@@ -1461,6 +1462,7 @@ defaultDynFlags mySettings =
         thOnLoc = noSrcSpan,
         newDerivOnLoc = noSrcSpan,
         overlapInstLoc = noSrcSpan,
+        incoherentOnLoc = noSrcSpan,
         pkgTrustOnLoc = noSrcSpan,
         warnSafeOnLoc = noSrcSpan,
         warnUnsafeOnLoc = noSrcSpan,
@@ -1791,17 +1793,23 @@ combineSafeFlags a b | a == Sf_None         = return b
 --     * function to turn the flag off
 unsafeFlags, unsafeFlagsForInfer
   :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]
-unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc,
-                   xopt Opt_GeneralizedNewtypeDeriving,
-                   flip xopt_unset Opt_GeneralizedNewtypeDeriving),
-               ("-XTemplateHaskell", thOnLoc,
-                   xopt Opt_TemplateHaskell,
-                   flip xopt_unset Opt_TemplateHaskell)]
+unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc,
+                    xopt Opt_GeneralizedNewtypeDeriving,
+                    flip xopt_unset Opt_GeneralizedNewtypeDeriving)
+              , ("-XTemplateHaskell", thOnLoc,
+                    xopt Opt_TemplateHaskell,
+                    flip xopt_unset Opt_TemplateHaskell)
+              ]
 unsafeFlagsForInfer = unsafeFlags ++
               -- TODO: Can we do better than this for inference?
-              [("-XOverlappingInstances", overlapInstLoc,
+              [ ("-XOverlappingInstances", overlapInstLoc,
                   xopt Opt_OverlappingInstances,
-                  flip xopt_unset Opt_OverlappingInstances)]
+                  flip xopt_unset Opt_OverlappingInstances)
+              , ("-XIncoherentInstances", incoherentOnLoc,
+                  xopt Opt_IncoherentInstances,
+                  flip xopt_unset Opt_IncoherentInstances)
+              ]
+
 
 -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
 getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from
@@ -2881,7 +2889,7 @@ xFlags = [
   ( "ImplicitParams",                   Opt_ImplicitParams, nop ),
   ( "ImplicitPrelude",                  Opt_ImplicitPrelude, nop ),
   ( "ImpredicativeTypes",               Opt_ImpredicativeTypes, nop),
-  ( "IncoherentInstances",              Opt_IncoherentInstances, nop ),
+  ( "IncoherentInstances",              Opt_IncoherentInstances, setIncoherentInsts  ),
   ( "InstanceSigs",                     Opt_InstanceSigs, nop ),
   ( "InterruptibleFFI",                 Opt_InterruptibleFFI, nop ),
   ( "JavaScriptFFI",                    Opt_JavaScriptFFI, nop ),
@@ -2904,9 +2912,7 @@ xFlags = [
   ( "NullaryTypeClasses",               Opt_NullaryTypeClasses,
                         deprecatedForExtension "MultiParamTypeClasses" ),
   ( "NumDecimals",                      Opt_NumDecimals, nop),
-  ( "OverlappingInstances",             Opt_OverlappingInstances,
-        \ turn_on -> when turn_on
-             $ deprecate "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS" ),
+  ( "OverlappingInstances",             Opt_OverlappingInstances, setOverlappingInsts),
   ( "OverloadedLists",                  Opt_OverloadedLists, nop),
   ( "OverloadedStrings",                Opt_OverloadedStrings, nop ),
   ( "PackageImports",                   Opt_PackageImports, nop ),
@@ -3226,6 +3232,19 @@ setGenDeriving :: TurnOnFlag -> DynP ()
 setGenDeriving True  = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })
 setGenDeriving False = return ()
 
+setOverlappingInsts :: TurnOnFlag -> DynP ()
+setOverlappingInsts False = return ()
+setOverlappingInsts True = do
+  l <- getCurLoc
+  upd (\d -> d { overlapInstLoc = l })
+  deprecate "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS"
+
+setIncoherentInsts :: TurnOnFlag -> DynP ()
+setIncoherentInsts False = return ()
+setIncoherentInsts True = do
+  l <- getCurLoc
+  upd (\d -> d { incoherentOnLoc = l })
+
 checkTemplateHaskellOk :: TurnOnFlag -> DynP ()
 #ifdef GHCI
 checkTemplateHaskellOk turn_on
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index d22938eba2..ddb2e6531a 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -432,8 +432,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
               -- (deriving can't be used there)
       && not (isHsBootOrSig (tcg_src env))
 
-    overlapCheck ty = overlapMode (is_flag $ iSpec ty) `elem`
-                        [Overlappable, Overlapping, Overlaps]
+    overlapCheck ty = overlapMode (is_flag $ iSpec ty) /= NoOverlap
     genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames
     genInstErr i = hang (ptext (sLit $ "Generic instances can only be "
                             ++ "derived in Safe Haskell.") $+$
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.hs
index 2df65765aa..b3e7f34586 100644
--- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.hs
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
 {-# LANGUAGE FlexibleInstances #-}
-module UnsafeInfered15 where
+module UnsafeInfered16 where
 
 class C a where
   f :: a -> String
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr
index 21674c407b..5ac27d3d82 100644
--- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered16.stderr
@@ -1,6 +1,6 @@
 
 UnsafeInfered16.hs:1:16: Warning:
-    ‘UnsafeInfered15’ has been inferred as unsafe!
+    ‘UnsafeInfered16’ has been inferred as unsafe!
     Reason:
         UnsafeInfered16.hs:8:30:
             [overlapping] overlap mode isn't allowed in Safe Haskell
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.hs
index 04591b5f77..7f17a136ff 100644
--- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.hs
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
 {-# LANGUAGE FlexibleInstances #-}
-module UnsafeInfered15 where
+module UnsafeInfered17 where
 
 class C a where
   f :: a -> String
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.stderr
index 415e9a1f37..aa43fbeeed 100644
--- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.stderr
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered17.stderr
@@ -1,6 +1,6 @@
 
 UnsafeInfered17.hs:1:16: Warning:
-    ‘UnsafeInfered15’ has been inferred as unsafe!
+    ‘UnsafeInfered17’ has been inferred as unsafe!
     Reason:
         UnsafeInfered17.hs:8:29:
             [incoherent] overlap mode isn't allowed in Safe Haskell
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.hs
new file mode 100644
index 0000000000..a6dbfe1745
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.hs
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -fwarn-unsafe #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverlappingInstances #-}
+module UnsafeInfered18 where
+
+class C a where
+  f :: a -> String
+
+instance C a where
+  f _ = "a"
+
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.stderr
new file mode 100644
index 0000000000..0896ec500f
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered18.stderr
@@ -0,0 +1,11 @@
+
+UnsafeInfered18.hs:3:14: Warning:
+    -XOverlappingInstances is deprecated: instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS
+
+UnsafeInfered18.hs:1:16: Warning:
+    ‘UnsafeInfered18’ has been inferred as unsafe!
+    Reason:
+        UnsafeInfered18.hs:3:14:
+            -XOverlappingInstances is not allowed in Safe Haskell
+        UnsafeInfered18.hs:9:10:
+            [overlap ok] overlap mode isn't allowed in Safe Haskell
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.hs
new file mode 100644
index 0000000000..587bc4edbf
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.hs
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE IncoherentInstances #-}
+module UnsafeInfered19 where
+
+class C a where
+  f :: a -> String
+
+instance C a where
+  f _ = "a"
+
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.stderr
new file mode 100644
index 0000000000..002c950930
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered19.stderr
@@ -0,0 +1,11 @@
+
+UnsafeInfered19.hs:1:16: Warning:
+    ‘UnsafeInfered19’ has been inferred as unsafe!
+    Reason:
+        UnsafeInfered19.hs:3:14:
+            -XIncoherentInstances is not allowed in Safe Haskell
+        UnsafeInfered19.hs:9:10:
+            [incoherent] 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 4fc9fcecb8..c2222a3549 100644
--- a/testsuite/tests/safeHaskell/safeInfered/all.T
+++ b/testsuite/tests/safeHaskell/safeInfered/all.T
@@ -65,6 +65,8 @@ test('UnsafeInfered14', normal, compile_fail, [''])
 test('UnsafeInfered15', normal, compile_fail, [''])
 test('UnsafeInfered16', normal, compile_fail, [''])
 test('UnsafeInfered17', normal, compile_fail, [''])
+test('UnsafeInfered18', normal, compile, [''])
+test('UnsafeInfered19', normal, compile_fail, [''])
 
 # Mixed tests
 test('Mixed01', normal, compile_fail, [''])