[commit: ghc] master: Infer safety of modules correctly with new overlapping pragmas. (fbd0586)

[git at git.haskell.org]

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

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

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

commit fbd0586ea55c753f6c81b592ae01e88e22f8f0cd
Author: David Terei <code at davidterei.com>
Date:   Fri Aug 1 18:49:43 2014 -0700

    Infer safety of modules correctly with new overlapping pragmas.


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

fbd0586ea55c753f6c81b592ae01e88e22f8f0cd
 compiler/typecheck/TcInstDcls.lhs                          |  3 +++
 testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.hs | 10 ++++++++++
 testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.hs | 10 ++++++++++
 testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.hs | 10 ++++++++++
 testsuite/tests/safeHaskell/safeInfered/all.T              |  5 ++++-
 5 files changed, 37 insertions(+), 1 deletion(-)

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 6ff8a2b..2b123ff 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -424,6 +424,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        ; when (safeInferOn dflags) $ forM_ local_infos $ \x -> case x of
              _ | typInstCheck x -> recordUnsafeInfer
              _ | genInstCheck x -> recordUnsafeInfer
+             _ | overlapCheck x -> recordUnsafeInfer
              _ -> return ()
 
        ; return ( gbl_env
@@ -450,6 +451,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                          ptext (sLit "Replace the following instance:"))
                      2 (pprInstanceHdr (iSpec i))
 
+    overlapCheck ty = overlapMode (is_flag $ iSpec ty) `elem`
+                        [Overlappable, Overlapping, Overlaps]
     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/UnsafeInfered13.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.hs
new file mode 100644
index 0000000..defc3a5
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
+{-# LANGUAGE FlexibleInstances #-}
+module UnsafeInfered13 where
+
+class C a where
+  f :: a -> String
+
+instance {-# OVERLAPS #-} C a where
+  f _ = "a"
+
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.hs
new file mode 100644
index 0000000..5b9f642
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
+{-# LANGUAGE FlexibleInstances #-}
+module UnsafeInfered14 where
+
+class C a where
+  f :: a -> String
+
+instance {-# OVERLAPPABLE #-} C a where
+  f _ = "a"
+
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.hs
new file mode 100644
index 0000000..427c97b
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
+{-# LANGUAGE FlexibleInstances #-}
+module UnsafeInfered15 where
+
+class C a where
+  f :: a -> String
+
+instance {-# OVERLAPPING #-} C a where
+  f _ = "a"
+
diff --git a/testsuite/tests/safeHaskell/safeInfered/all.T b/testsuite/tests/safeHaskell/safeInfered/all.T
index 47e9656..9fb587b 100644
--- a/testsuite/tests/safeHaskell/safeInfered/all.T
+++ b/testsuite/tests/safeHaskell/safeInfered/all.T
@@ -56,8 +56,11 @@ test('UnsafeInfered11',
      [ extra_clean(['UnsafeInfered11_A.hi', 'UnsafeInfered11_A.o']) ],
      multimod_compile_fail, ['UnsafeInfered11', ''])
 
-# test should fail as unsafe and we made warn unsafe + -Werror
+# Test should fail as unsafe and we made warn unsafe + -Werror
 test('UnsafeInfered12', normal, compile_fail, [''])
+test('UnsafeInfered13', normal, compile_fail, [''])
+test('UnsafeInfered14', normal, compile_fail, [''])
+test('UnsafeInfered15', normal, compile_fail, [''])
 
 # Mixed tests
 test('Mixed01', normal, compile_fail, [''])