From 46cfa8ebd3f7a9b93afcf5e0e9b7e4a5a973a25d Mon Sep 17 00:00:00 2001
From: Austin Seipp <austin@well-typed.com>
Date: Sun, 23 Mar 2014 23:45:22 -0500
Subject: [PATCH] Revert "Fix #8745 - GND is now -XSafe compatible."
See #8827 - for now, we're making GND unsafe again.
This also fixes the tests since they were originally not using the new
unicode quote style we're using.
This reverts commit a8a01e742434df11b830ab99af12d9045dfcbc4b.
(cherry picked from commit 8f7303774237a8b0787d98c5ab6f605e3e897f19)
---
compiler/main/DynFlags.hs | 5 ++-
testsuite/tests/safeHaskell/ghci/p1.stderr | 3 ++
testsuite/tests/safeHaskell/ghci/p16.stderr | 15 +++++++
testsuite/tests/safeHaskell/ghci/p16.stdout | 1 -
.../safeInfered/UnsafeInfered03_A.hs | 2 +-
.../safeHaskell/safeLanguage/SafeLang02.hs | 2 +-
.../safeLanguage/SafeLang02.stderr | 2 +-
.../safeHaskell/safeLanguage/SafeLang07.hs | 41 +++++++++++++++++++
.../safeLanguage/SafeLang07.stderr | 7 ++++
.../safeHaskell/safeLanguage/SafeLang07_A.hs | 24 +++++++++++
.../tests/safeHaskell/safeLanguage/all.T | 7 ++--
11 files changed, 101 insertions(+), 8 deletions(-)
create mode 100644 testsuite/tests/safeHaskell/safeLanguage/SafeLang07.hs
create mode 100644 testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr
create mode 100644 testsuite/tests/safeHaskell/safeLanguage/SafeLang07_A.hs
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 53a55335106d..053026bab0e4 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1732,7 +1732,10 @@ combineSafeFlags a b | a == Sf_SafeInferred = return b
-- * function to test if the flag is on
-- * function to turn the flag off
unsafeFlags :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]
-unsafeFlags = [("-XTemplateHaskell", thOnLoc,
+unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc,
+ xopt Opt_GeneralizedNewtypeDeriving,
+ flip xopt_unset Opt_GeneralizedNewtypeDeriving),
+ ("-XTemplateHaskell", thOnLoc,
xopt Opt_TemplateHaskell,
flip xopt_unset Opt_TemplateHaskell)]
diff --git a/testsuite/tests/safeHaskell/ghci/p1.stderr b/testsuite/tests/safeHaskell/ghci/p1.stderr
index 6ebe783322e2..9446e1df160c 100644
--- a/testsuite/tests/safeHaskell/ghci/p1.stderr
+++ b/testsuite/tests/safeHaskell/ghci/p1.stderr
@@ -1,3 +1,6 @@
<no location info>: Warning:
-XTemplateHaskell is not allowed in Safe Haskell; ignoring -XTemplateHaskell
+
+<no location info>: Warning:
+ -XGeneralizedNewtypeDeriving is not allowed in Safe Haskell; ignoring -XGeneralizedNewtypeDeriving
diff --git a/testsuite/tests/safeHaskell/ghci/p16.stderr b/testsuite/tests/safeHaskell/ghci/p16.stderr
index e69de29bb2d1..a5dab96c1ee2 100644
--- a/testsuite/tests/safeHaskell/ghci/p16.stderr
+++ b/testsuite/tests/safeHaskell/ghci/p16.stderr
@@ -0,0 +1,15 @@
+
+<no location info>: Warning:
+ -XGeneralizedNewtypeDeriving is not allowed in Safe Haskell; ignoring -XGeneralizedNewtypeDeriving
+
+<interactive>:16:29:
+ Can't make a derived instance of ‘Op T2’:
+ ‘Op’ is not a derivable class
+ Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension
+ In the newtype declaration for ‘T2’
+
+<interactive>:19:9:
+ Not in scope: data constructor ‘T2’
+ Perhaps you meant ‘T1’ (line 13)
+
+<interactive>:22:4: Not in scope: ‘y’
diff --git a/testsuite/tests/safeHaskell/ghci/p16.stdout b/testsuite/tests/safeHaskell/ghci/p16.stdout
index 596c87408388..233a1e18c70a 100644
--- a/testsuite/tests/safeHaskell/ghci/p16.stdout
+++ b/testsuite/tests/safeHaskell/ghci/p16.stdout
@@ -1,2 +1 @@
"t1"
-"T"
diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered03_A.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered03_A.hs
index ff6490e915c3..ea3202ed5d70 100644
--- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered03_A.hs
+++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered03_A.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Unsafe as uses GND
module UnsafeInfered03_A where
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang02.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang02.hs
index 8bc3f3cd0042..9bf1c82a096d 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang02.hs
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang02.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE Safe, TemplateHaskell #-}
+{-# LANGUAGE Safe, GeneralizedNewtypeDeriving #-}
-- | Test SafeLanguage disables things
module SafeLang02 where
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang02.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang02.stderr
index e1643ed32b01..069e5be4e924 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang02.stderr
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang02.stderr
@@ -1,3 +1,3 @@
SafeLang02.hs:1:20:
- Warning: -XTemplateHaskell is not allowed in Safe Haskell; ignoring -XTemplateHaskell
+ Warning: -XGeneralizedNewtypeDeriving is not allowed in Safe Haskell; ignoring -XGeneralizedNewtypeDeriving
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.hs
new file mode 100644
index 000000000000..006cd0ea087a
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE Safe #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- Here we stop it succeeding (SAFE)
+
+-- | We use newtype to create an isomorphic type to Int
+-- with a reversed Ord dictionary. We now use the MinList
+-- API of Y1 to create a new MinList. Then we use newtype
+-- deriving to convert the newtype MinList to an Int
+-- MinList. This final result breaks the invariants of
+-- MinList which shouldn't be possible with the exposed
+-- API of Y1.
+module Main where
+
+import SafeLang07_A
+
+class IntIso t where
+ intIso :: c t -> c Int
+
+instance IntIso Int where
+ intIso = id
+
+newtype Down a = Down a deriving (Eq, Show, IntIso)
+
+instance Ord a => Ord (Down a) where
+ compare (Down a) (Down b) = compare b a
+
+forceInt :: MinList Int -> MinList Int
+forceInt = id
+
+a1, a2 :: MinList Int
+a1 = foldl insertMinList (newMinList $ head nums) (tail nums)
+a2 = forceInt $ intIso $ foldl (\x y -> insertMinList x $ Down y) (newMinList $ Down $ head nums) (tail nums)
+
+nums :: [Int]
+nums = [1,4,0,1,-5,2,3,5,-1,2,0,0,-4,-3,9]
+
+main = do
+ printIntMinList a1
+ printIntMinList a2
+
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr
new file mode 100644
index 000000000000..276c723203a0
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr
@@ -0,0 +1,7 @@
+
+SafeLang07.hs:2:14: Warning:
+ -XGeneralizedNewtypeDeriving is not allowed in Safe Haskell; ignoring -XGeneralizedNewtypeDeriving
+
+SafeLang07.hs:15:1:
+ Failed to load interface for ‘SafeLang07_A’
+ Use -v to see a list of the files searched for.
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang07_A.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07_A.hs
new file mode 100644
index 000000000000..6ef49d594621
--- /dev/null
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07_A.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE Trustworthy #-}
+
+-- | Here we expose a MinList API that only allows elements
+-- to be inserted into a list if they are at least greater
+-- than an initial element the list is created with.
+module SafeLang07_A (
+ MinList,
+ newMinList,
+ insertMinList,
+ printIntMinList
+ ) where
+
+data MinList a = MinList a [a]
+
+newMinList :: Ord a => a -> MinList a
+newMinList n = MinList n []
+
+insertMinList :: Ord a => MinList a -> a -> MinList a
+insertMinList s@(MinList m xs) n | n > m = MinList m (n:xs)
+ | otherwise = s
+
+printIntMinList :: MinList Int -> IO ()
+printIntMinList (MinList min xs) = putStrLn $ "MinList Int :: MinList " ++ show min ++ " " ++ show xs
+
diff --git a/testsuite/tests/safeHaskell/safeLanguage/all.T b/testsuite/tests/safeHaskell/safeLanguage/all.T
index dc968917fb5d..59323485949c 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/all.T
+++ b/testsuite/tests/safeHaskell/safeLanguage/all.T
@@ -15,10 +15,11 @@ test('SafeLang03', normal, compile, [''])
test('SafeLang04', normal, compile_and_run, [''])
test('SafeLang05', normal, compile_and_run, [''])
-# SafeLang06 and SafeLang07 wwere tests involving
-# GeneralizedNewtypeDeriving, but the code failed to compile with
-# roles; thus the tests were no longer valid and have been removed
+# SafeLang06 was a test involving GeneralizedNewtypeDeriving, but the code
+# fails to compile with roles; thus the test is no longer valid and has
+# been removed
+test('SafeLang07', normal, compile_fail, [''])
test('SafeLang08', normal, compile_fail, [''])
test('SafeLang09',
[exit_code(1),
--
GitLab