diff options
96 files changed, 950 insertions, 0 deletions
diff --git a/testsuite/tests/ghc-regress/safeHaskell/Makefile b/testsuite/tests/ghc-regress/safeHaskell/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/Check01.hs b/testsuite/tests/ghc-regress/safeHaskell/check/Check01.hs new file mode 100644 index 0000000000..1e82846f3a --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/Check01.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE SafeImports #-} +module Check01 ( main' ) where + +import safe CheckB + +main' = do + let n = mainM 1 + print $ n + diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/Check01_fail.stderr b/testsuite/tests/ghc-regress/safeHaskell/check/Check01_fail.stderr new file mode 100644 index 0000000000..70722f32b8 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/Check01_fail.stderr @@ -0,0 +1,4 @@ +[3 of 3] Compiling Check01 ( Check01.hs, Check01.o ) + +<no location info>: + The package (base) is required to be trusted but it isn't! diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/Check01_succeed.stderr b/testsuite/tests/ghc-regress/safeHaskell/check/Check01_succeed.stderr new file mode 100644 index 0000000000..848fdf6a48 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/Check01_succeed.stderr @@ -0,0 +1 @@ +[3 of 3] Compiling Check01 ( Check01.hs, Check01.o ) diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/Check02.hs b/testsuite/tests/ghc-regress/safeHaskell/check/Check02.hs new file mode 100644 index 0000000000..f2f0bc51fc --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/Check02.hs @@ -0,0 +1,8 @@ +module Check02 where + +import CheckB + +mainN = do + let n = mainM 1 + print $ n + diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/Check02.stderr b/testsuite/tests/ghc-regress/safeHaskell/check/Check02.stderr new file mode 100644 index 0000000000..708541b8ed --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/Check02.stderr @@ -0,0 +1 @@ +[3 of 3] Compiling Check02 ( Check02.hs, Check02.o ) diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/Check03.hs b/testsuite/tests/ghc-regress/safeHaskell/check/Check03.hs new file mode 100644 index 0000000000..20fd042bf9 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/Check03.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE SafeImports #-} +module Main ( main ) where + +import Check01 + +main = main' + diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/Check03.stderr b/testsuite/tests/ghc-regress/safeHaskell/check/Check03.stderr new file mode 100644 index 0000000000..682fa0a7e4 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/Check03.stderr @@ -0,0 +1,2 @@ +[4 of 4] Compiling Main ( Check03.hs, Check03.o ) +Linking Check03 ... diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/CheckA.hs b/testsuite/tests/ghc-regress/safeHaskell/check/CheckA.hs new file mode 100644 index 0000000000..80f9ae4ee0 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/CheckA.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Trustworthy #-} +module CheckA ( + trace + ) where + +import qualified Debug.Trace as D +import qualified Data.ByteString.Lazy.Char8 as BS + +-- | Allowed declasification +trace :: String -> a -> a +trace s = D.trace $ s ++ show a3 + +a3 :: BS.ByteString +a3 = BS.take 3 $ BS.repeat 'a' + diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/CheckB.hs b/testsuite/tests/ghc-regress/safeHaskell/check/CheckB.hs new file mode 100644 index 0000000000..f690aab368 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/CheckB.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Safe #-} + +-- Since Safe we require base package be trusted to compile +module CheckB where + +import CheckA + +mainM :: Int -> Int +mainM n = trace "Allowed Leak" $ n * 2 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/CheckB.stderr b/testsuite/tests/ghc-regress/safeHaskell/check/CheckB.stderr new file mode 100644 index 0000000000..64acb2418b --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/CheckB.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling CheckA ( CheckA.hs, CheckA.o ) +[2 of 2] Compiling CheckB ( CheckB.hs, CheckB.o ) diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/Makefile b/testsuite/tests/ghc-regress/safeHaskell/check/Makefile new file mode 100644 index 0000000000..9ce1411567 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk
\ No newline at end of file diff --git a/testsuite/tests/ghc-regress/safeHaskell/check/all.T b/testsuite/tests/ghc-regress/safeHaskell/check/all.T new file mode 100644 index 0000000000..e08ec3caae --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/check/all.T @@ -0,0 +1,36 @@ +# Just do the normal way, SafeHaskell is all in the frontend +def f( opts ): + opts.only_ways = ['normal'] + +setTestOpts(f) + +test('CheckA', normal, compile, ['']) +test('CheckB', normal, multimod_compile, ['CheckB', '-trust base']) + +# fail as we don't trust base when compiling Check01 +test('Check01_fail', normal, multi_compile_fail, ['Check01', [ + ('CheckA.hs', ''), + ('CheckB.hs', '-trust base') + ], '']) + +# suceed this time since we trust base when we compile AND use CheckB +test('Check01_succeed', normal, multi_compile, ['Check01', [ + ('CheckA.hs', ''), + ('CheckB.hs', '') + ], '-trust base']) + +# suceed as while like Check01_fail we don't import CheckB as a safe +# import this time, so don't require base trusted when used. +test('Check02', normal, multi_compile, ['Check02', [ + ('CheckA.hs', ''), + ('CheckB.hs', '-trust base') + ], '']) + +# Check a slightly larger transitive program. Check01 isn't imported +# safely by Check03 so we don't require base trused at end. +test('Check03', normal, multi_compile, ['Check03', [ + ('CheckA.hs', ''), + ('CheckB.hs', '-trust base'), + ('Check01.hs', '-trust base') + ], '']) + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/Flags01.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/Flags01.hs new file mode 100644 index 0000000000..0e1d120a81 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/Flags01.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} + +-- | CPP should still be allowed +module Main where + +#include "Flags01_A.cpp" + +#define mainn main=putStrLn str + +mainn + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/Flags01_A.cpp b/testsuite/tests/ghc-regress/safeHaskell/flags/Flags01_A.cpp new file mode 100644 index 0000000000..9170664236 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/Flags01_A.cpp @@ -0,0 +1,3 @@ +str :: String +str = "Hello World" + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/Flags02.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/Flags02.hs new file mode 100644 index 0000000000..525064dedf --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/Flags02.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -pgmlc pgmlc, -pgmdll pgmdll, -I., -L., -Uggg, -Dggg, -with-rtsopts full #-} + +-- | These are all flags that should be allowed +module Flags02 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/Makefile b/testsuite/tests/ghc-regress/safeHaskell/flags/Makefile new file mode 100644 index 0000000000..9ce1411567 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk
\ No newline at end of file diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags01.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags01.hs new file mode 100644 index 0000000000..f5790eba64 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags01.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags01 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags02.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags02.hs new file mode 100644 index 0000000000..50a1101bd4 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags02.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Trustworthy #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags02 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags03.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags03.hs new file mode 100644 index 0000000000..ea83a06210 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags03.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE SafeImports #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags03 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags04.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags04.hs new file mode 100644 index 0000000000..b966eba1a0 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags04.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE SafeLanguage #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags04 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags05.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags05.hs new file mode 100644 index 0000000000..0f316d475b --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags05.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe, SafeImports #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags05 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags06.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags06.hs new file mode 100644 index 0000000000..81fd3257ae --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags06.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Trustworthy, SafeImports #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags06 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags07.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags07.hs new file mode 100644 index 0000000000..0339fe362f --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags07.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE SafeLanguage, SafeImports #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags07 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags08.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags08.hs new file mode 100644 index 0000000000..445e591b1e --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags08.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE SafeLanguage, Trustworthy #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags08 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags09.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags09.hs new file mode 100644 index 0000000000..d03b0dacbf --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags09.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE SafeLanguage, Safe #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags09 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags09.stderr b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags09.stderr new file mode 100644 index 0000000000..d4ebb6242b --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags09.stderr @@ -0,0 +1,2 @@ +ghc-stage2: SafeFlags09.hs:1:28-31: Incompatible Safe Haskell flags! (SafeLanguage, Safe) +Usage: For basic information, try the `--help' option. diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags10.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags10.hs new file mode 100644 index 0000000000..43ba5c81cd --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags10.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe, Trustworthy #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags10 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags10.stderr b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags10.stderr new file mode 100644 index 0000000000..86346b77fe --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags10.stderr @@ -0,0 +1,2 @@ +ghc-stage2: SafeFlags10.hs:1:20-30: Incompatible Safe Haskell flags! (Safe, Trustworthy) +Usage: For basic information, try the `--help' option. diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags11.hs b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags11.hs new file mode 100644 index 0000000000..e90b105dde --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/SafeFlags11.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} + +-- | Basic test to see if Safe flags compiles +module SafeFlags11 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/flags/all.T b/testsuite/tests/ghc-regress/safeHaskell/flags/all.T new file mode 100644 index 0000000000..0d5d538b5b --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/flags/all.T @@ -0,0 +1,21 @@ +# Just do the normal way, SafeHaskell is all in the frontend +def f( opts ): + opts.only_ways = ['normal'] + +setTestOpts(f) + +test('SafeFlags01', normal, compile, ['-trust base']) +test('SafeFlags02', normal, compile, ['']) +test('SafeFlags03', normal, compile, ['']) +test('SafeFlags04', normal, compile, ['-trust base']) +test('SafeFlags05', normal, compile, ['-trust base']) +test('SafeFlags06', normal, compile, ['']) +test('SafeFlags07', normal, compile, ['-trust base']) +test('SafeFlags08', normal, compile, ['-trust base']) +test('SafeFlags09', normal, compile_fail, ['']) +test('SafeFlags10', normal, compile_fail, ['']) +test('SafeFlags11', normal, compile, ['-trust base']) + +test('Flags01', normal, compile, ['']) +test('Flags02', normal, compile, ['']) + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/Makefile b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/Makefile new file mode 100644 index 0000000000..9ce1411567 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk
\ No newline at end of file diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang01.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang01.hs new file mode 100644 index 0000000000..5920c03161 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang01.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe, TemplateHaskell #-} + +-- | Test SafeLanguage disables things +module SafeLang01 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang01.stderr b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang01.stderr new file mode 100644 index 0000000000..18320eb727 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang01.stderr @@ -0,0 +1,3 @@ + +SafeLang01.hs:1:20: + Warning: XTemplateHaskell is not allowed in Safe Haskell; ignoring XTemplateHaskell diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang02.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang02.hs new file mode 100644 index 0000000000..9bf1c82a09 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang02.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe, GeneralizedNewtypeDeriving #-} + +-- | Test SafeLanguage disables things +module SafeLang02 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang02.stderr b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang02.stderr new file mode 100644 index 0000000000..6e3546968b --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang02.stderr @@ -0,0 +1,3 @@ + +<no location info>: + Warning: -XGeneralizedNewtypeDeriving is not allowed in Safe Haskell; ignoring -XGeneralizedNewtypeDeriving diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang03.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang03.hs new file mode 100644 index 0000000000..4f3bce7e0a --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang03.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_GHC -fenable-rewrite-rules #-} + +-- | Test SafeLanguage disables things +module SafeLang03 where + +{-# RULES "f" f = undefined #-} +f :: Int +f = 1 + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang03.stderr b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang03.stderr new file mode 100644 index 0000000000..fdcc5997d5 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang03.stderr @@ -0,0 +1,4 @@ + +SafeLang03.hs:7:11: + Rule "f" ignored + User defined rules are disabled under Safe Haskell diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang04.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang04.hs new file mode 100644 index 0000000000..a9ac3619f3 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang04.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_GHC -fenable-rewrite-rules #-} +-- | Check rules work as normal without Safe +module Main where + +data T = T1 | T2 | T3 deriving ( Eq, Ord, Show ) + +lookupx :: Ord key => Show val => [(key,val)] -> key -> Maybe val +lookupx [] _ = Nothing +lookupx ((t,a):xs) t' | t == t' = Just a + | otherwise = lookupx xs t' + +{-# RULES "lookupx/T" lookupx = tLookup #-} +tLookup :: [(T,a)] -> T -> Maybe a +tLookup [] _ = Nothing +tLookup ((t,a):xs) t' | t /= t' = Just a + | otherwise = tLookup xs t' + +space = [(T1,"a"),(T2,"b"),(T3,"c")] +key = T3 + +main = do + putStrLn $ "looking for " ++ show key + putStrLn $ "in space " ++ show space + putStrLn $ "Found: " ++ show (fromMaybe "Not Found!" $ lookupx space key) + let b | Just "c" <- lookupx space key = "YES" + | otherwise = "NO" + putStrLn $ "Rules Disabled: " ++ b + +fromMaybe :: a -> Maybe a -> a +fromMaybe a Nothing = a +fromMaybe _ (Just a) = a + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang04.stdout b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang04.stdout new file mode 100644 index 0000000000..b80e6135bd --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang04.stdout @@ -0,0 +1,4 @@ +looking for T3 +in space [(T1,"a"),(T2,"b"),(T3,"c")] +Found: "a" +Rules Disabled: NO diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang05.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang05.hs new file mode 100644 index 0000000000..1dd9016152 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang05.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_GHC -fenable-rewrite-rules #-} + +-- | Check rules are disabled under Safe +module Main where + +data T = T1 | T2 | T3 deriving ( Eq, Ord, Show ) + +lookupx :: Ord key => Show val => [(key,val)] -> key -> Maybe val +lookupx [] _ = Nothing +lookupx ((t,a):xs) t' | t == t' = Just a + | otherwise = lookupx xs t' + +{-# RULES "lookupx/T" lookupx = tLookup #-} +tLookup :: [(T,a)] -> T -> Maybe a +tLookup [] _ = Nothing +tLookup ((t,a):xs) t' | t /= t' = Just a + | otherwise = tLookup xs t' + +space = [(T1,"a"),(T2,"b"),(T3,"c")] +key = T3 + +main = do + putStrLn $ "looking for " ++ show key + putStrLn $ "in space " ++ show space + putStrLn $ "Found: " ++ show (fromMaybe "Not Found!" $ lookupx space key) + let b | Just "c" <- lookupx space key = "YES" + | otherwise = "NO" + putStrLn $ "Rules Disabled: " ++ b + +fromMaybe :: a -> Maybe a -> a +fromMaybe a Nothing = a +fromMaybe _ (Just a) = a + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang05.stdout b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang05.stdout new file mode 100644 index 0000000000..2334866860 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang05.stdout @@ -0,0 +1,4 @@ +looking for T3 +in space [(T1,"a"),(T2,"b"),(T3,"c")] +Found: "c" +Rules Disabled: YES diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang06.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang06.hs new file mode 100644 index 0000000000..685846f150 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang06.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- Here we allow it to succeed (No 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 SafeLang06_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/ghc-regress/safeHaskell/safeLanguage/SafeLang06.stdout b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang06.stdout new file mode 100644 index 0000000000..ed005737b7 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang06.stdout @@ -0,0 +1,2 @@ +MinList Int :: MinList 1 [9,2,5,3,2,4] +MinList Int :: MinList 1 [-3,-4,0,0,-1,-5,0] diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang06_A.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang06_A.hs new file mode 100644 index 0000000000..07aad17f94 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang06_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 SafeLang06_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/ghc-regress/safeHaskell/safeLanguage/SafeLang07.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang07.hs new file mode 100644 index 0000000000..77213820ca --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang07.hs @@ -0,0 +1,42 @@ +{-# 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 SafeLang06_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/ghc-regress/safeHaskell/safeLanguage/SafeLang07.stderr b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang07.stderr new file mode 100644 index 0000000000..b1e25262af --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang07.stderr @@ -0,0 +1,9 @@ + +<no location info>: + Warning: -XGeneralizedNewtypeDeriving is not allowed in Safe Haskell; ignoring -XGeneralizedNewtypeDeriving + +SafeLang07.hs:23:45: + Can't make a derived instance of `IntIso (Down a)': + `IntIso' is not a derivable class + Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension + In the newtype declaration for `Down' diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang08.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang08.hs new file mode 100644 index 0000000000..7249c8d0ec --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang08.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | Make sure FFI must be IO type +module Main where + +import Foreign.C + +foreign import ccall "SafeLang08_A" c_sin :: CDouble -> CDouble + +sinx :: Double -> Double +sinx d = realToFrac $ c_sin $ realToFrac d + +x :: Double +x = 0.8932 + +main :: IO () +main = do + putStrLn "Hello World" + putStrLn $ "Sin of " ++ (show x) ++ " is " ++ (show $ sinx x) + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang08.stderr b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang08.stderr new file mode 100644 index 0000000000..fc7c7fa00d --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang08.stderr @@ -0,0 +1,7 @@ + +SafeLang08.hs:9:1: + Unacceptable result type in foreign declaration: CDouble + Safe Haskell is on, all FFI imports must be in the IO monad + When checking declaration: + foreign import ccall safe "static SafeLang08_A" c_sin + :: CDouble -> CDouble diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang08_A.c b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang08_A.c new file mode 100644 index 0000000000..d77ebad560 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang08_A.c @@ -0,0 +1,6 @@ +double sinyy (double d) { + double (*y)(double) = 0x0; + return y(d); +} + + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09.hs new file mode 100644 index 0000000000..4e20f177bf --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09.hs @@ -0,0 +1,10 @@ +module Main where + +import SafeLang09_A -- trusted lib +import SafeLang09_B -- untrusted plugin + +main = do + let r = res [(1::Int)] + putStrLn $ "Result: " ++ show r + putStrLn $ "Result: " ++ show function + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09.stderr b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09.stderr new file mode 100644 index 0000000000..27d951e959 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09.stderr @@ -0,0 +1 @@ +SafeLang09: This curry is poisoned! diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09_A.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09_A.hs new file mode 100644 index 0000000000..129c2c4b56 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09_A.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- | Trusted library that unsafe plugins can use +module SafeLang09_A where + +class Pos a where + res :: a -> Bool + +-- Any call to res with a list in out TCB +-- should use this method and never a more +-- specific one provided by an untrusted module +instance Pos [a] where + res _ = True + + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09_B.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09_B.hs new file mode 100644 index 0000000000..76e0fe5a1c --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang09_B.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} + +-- Untrusted plugin! Don't wan't it changing behaviour of our +-- trusted code +module SafeLang09_B where + +import SafeLang09_A + +instance Pos a where + res _ = False + +instance Pos [Int] where + res _ = error "This curry is poisoned!" + +function :: Int +function = 3 + + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10.hs new file mode 100644 index 0000000000..ff5c168cff --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE SafeImports #-} +module Main where + +import safe SafeLang10_A -- trusted lib +import safe SafeLang10_B -- untrusted plugin + +main = do + let r = res [(1::Int)] + putStrLn $ "Result: " ++ show r + putStrLn $ "Result: " ++ show function + + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10.stderr b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10.stderr new file mode 100644 index 0000000000..d9a671b08d --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10.stderr @@ -0,0 +1,20 @@ +[1 of 3] Compiling SafeLang10_A ( SafeLang10_A.hs, SafeLang10_A.o ) +[2 of 3] Compiling SafeLang10_B ( SafeLang10_B.hs, SafeLang10_B.o ) +[3 of 3] Compiling Main ( SafeLang10.hs, SafeLang10.o ) + +SafeLang10.hs:8:13: + Unsafe overlapping instances for Pos [Int] + arising from a use of `res' + The matching instance is: + instance [overlap ok] [safe] Pos [Int] + -- Defined at SafeLang10_B.hs:14:10-18 + It is compiled in a Safe module and as such can only + overlap instances from the same module, however it + overlaps the following instances from different modules: + instance Pos [a] -- Defined at SafeLang10_A.hs:13:10-16 + In the expression: res [(1 :: Int)] + In an equation for `r': r = res [(1 :: Int)] + In the expression: + do { let r = res ...; + putStrLn $ "Result: " ++ show r; + putStrLn $ "Result: " ++ show function } diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10.stdout b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10.stdout new file mode 100644 index 0000000000..32f4c5bbce --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10.stdout @@ -0,0 +1,3 @@ +[1 of 3] Compiling SafeLang10_A ( SafeLang10_A.hs, SafeLang10_A.o ) +[2 of 3] Compiling SafeLang10_B ( SafeLang10_B.hs, SafeLang10_B.o ) +[3 of 3] Compiling Main ( SafeLang10.hs, SafeLang10.o ) diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10_A.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10_A.hs new file mode 100644 index 0000000000..7be17b5ec0 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10_A.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Trustworthy #-} + +-- | Trusted library that unsafe plugins can use +module SafeLang10_A where + +class Pos a where + res :: a -> Bool + +-- Any call to res with a list in out TCB +-- should use this method and never a more +-- specific one provided by an untrusted module +instance Pos [a] where + res _ = True + + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10_B.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10_B.hs new file mode 100644 index 0000000000..5b9954c12e --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang10_B.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE Safe #-} + +-- Untrusted plugin! Don't wan't it changing behaviour of our +-- trusted code +module SafeLang10_B where + +import SafeLang10_A + +instance Pos a where + res _ = False + +instance Pos [Int] where + res _ = error "This curry is poisoned!" + +function :: Int +function = 3 + + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11.hs new file mode 100644 index 0000000000..11b32ec57c --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import SafeLang11_A +import SafeLang11_B + +$(mkSimpleClass ''A) + +main = do + let b = c :: A + putStrLn $ "I have a value of A :: " ++ show b + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11.stdout b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11.stdout new file mode 100644 index 0000000000..34f1bf217a --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11.stdout @@ -0,0 +1 @@ +I have a value of A :: A1 is secret! diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11_A.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11_A.hs new file mode 100644 index 0000000000..7eb818183c --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11_A.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Safe #-} +module SafeLang11_A ( A ) where + +data A = A1 | A2 + +instance Show A where + show A1 = "A1 is secret!" + show A2 = "A2 is secret!" + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11_B.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11_B.hs new file mode 100644 index 0000000000..8d81be6abc --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang11_B.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +module SafeLang11_B ( Class(..), mkSimpleClass ) where + +import Language.Haskell.TH + +class Class a where + c :: a + +mkSimpleClass :: Name -> Q [Dec] +mkSimpleClass name = do + TyConI (DataD [] dname [] cs _) <- reify name + ((NormalC conname []):_) <- return cs + ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class + return [InstanceD [] (AppT (ConT cname) (ConT dname)) [FunD mname + [Clause [] (NormalB (ConE conname)) []]]] + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang12.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang12.hs new file mode 100644 index 0000000000..5817e54095 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang12.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import SafeLang11_A +import SafeLang12_B + +$(mkSimpleClass ''A) + +main = do + let b = c :: A + putStrLn $ "I have a value of A :: " ++ show b + + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang12.stderr b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang12.stderr new file mode 100644 index 0000000000..1466921b07 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang12.stderr @@ -0,0 +1,11 @@ + +SafeLang12.hs:2:14: + Warning: XTemplateHaskell is not allowed in Safe Haskell; ignoring XTemplateHaskell + +SafeLang12_B.hs:2:14: + Warning: XTemplateHaskell is not allowed in Safe Haskell; ignoring XTemplateHaskell + +SafeLang12_B.hs:3:8: + File name does not match module name: + Saw: `SafeLang11_B' + Expected: `SafeLang12_B' diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang12_B.hs b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang12_B.hs new file mode 100644 index 0000000000..f6ce559448 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/SafeLang12_B.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE TemplateHaskell #-} +module SafeLang11_B ( Class(..), mkSimpleClass ) where + +import Language.Haskell.TH + +class Class a where + c :: a + +mkSimpleClass :: Name -> Q [Dec] +mkSimpleClass name = do + TyConI (DataD [] dname [] cs _) <- reify name + ((NormalC conname []):_) <- return cs + ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class + return [InstanceD [] (AppT (ConT cname) (ConT dname)) [FunD mname + [Clause [] (NormalB (ConE conname)) []]]] + + diff --git a/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/all.T b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/all.T new file mode 100644 index 0000000000..4b2209bca9 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/safeLanguage/all.T @@ -0,0 +1,19 @@ +# Just do the normal way, SafeHaskell is all in the frontend +def f( opts ): + opts.only_ways = ['normal'] + +setTestOpts(f) + +test('SafeLang01', normal, compile, ['-trust base']) +test('SafeLang02', normal, compile, ['-trust base']) +test('SafeLang03', normal, compile, ['-trust base']) +test('SafeLang04', normal, compile_and_run, ['']) +test('SafeLang05', normal, compile_and_run, ['-trust base']) +test('SafeLang06', normal, compile_and_run, ['']) +test('SafeLang07', normal, compile_fail, ['']) +test('SafeLang08', normal, compile_fail, ['']) +test('SafeLang09', exit_code(1), compile_and_run, ['']) +test('SafeLang10', normal, compile_fail, ['--make -trust base']) +test('SafeLang11', normal, compile_and_run, ['--make -trust base']) +test('SafeLang12', normal, compile_fail, ['--make -trust base']) + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport01.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport01.hs new file mode 100644 index 0000000000..ae72dd6cd3 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport01.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Safe #-} +module Main where + +import System.IO.Unsafe + +f :: Int +f = unsafePerformIO $ putStrLn "What kind of swallow?" >> return 2 + +main :: IO () +main = putStrLn $ "X is: " ++ show f + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport01.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport01.stderr new file mode 100644 index 0000000000..983e043591 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport01.stderr @@ -0,0 +1,3 @@ + +BadImport01.hs:4:1: + base:System.IO.Unsafe can't be safely imported! The module itself isn't safe. diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport02.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport02.hs new file mode 100644 index 0000000000..e9d5ca7577 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport02.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-} + +-- | Here we used typeable to produce an illegal value +module Main where + +import Data.Typeable + +import BadImport02_A + +deriving instance Typeable Nat + +data NInt = NInt Int deriving Show + +instance Typeable NInt where + typeOf _ = typeOf (undefined::Nat) + +main = do + let a = succ' $ zero + Just n@(NInt z) = (cast a) :: Maybe NInt + n' = NInt (-z) + Just m = (cast n') :: Maybe Nat + + putStrLn $ showNat a + putStrLn $ show n + putStrLn $ showNat m + return () + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport02.stdout b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport02.stdout new file mode 100644 index 0000000000..c0f565d07c --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport02.stdout @@ -0,0 +1,3 @@ +Nat 1 +NInt 1 +Nat -1 diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport02_A.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport02_A.hs new file mode 100644 index 0000000000..2ca43343eb --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport02_A.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Trustworthy #-} +module BadImport02_A ( + Nat, zero, succ', showNat + ) where + +data Nat = NatC Int + +zero :: Nat +zero = NatC 0 + +succ' :: Nat -> Nat +succ' (NatC n) = NatC $ n + 1 + +showNat :: Nat -> String +showNat (NatC n) = "Nat " ++ show n + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport03.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport03.hs new file mode 100644 index 0000000000..835009a276 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport03.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-} + +-- | Here we used typeable to produce an illegal value +-- Now using SAFE though so will fail +module Main where + +import Data.Typeable + +import BadImport02_A + +deriving instance Typeable Nat + +data NInt = NInt Int deriving Show + +instance Typeable NInt where + typeOf _ = typeOf (undefined::Nat) + +main = do + let a = succ' $ zero + Just n@(NInt z) = (cast a) :: Maybe NInt + n' = NInt (-z) + Just m = (cast n') :: Maybe Nat + + putStrLn $ showNat a + putStrLn $ show n + putStrLn $ showNat m + return () + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport03.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport03.stderr new file mode 100644 index 0000000000..b1fcc3ca09 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/BadImport03.stderr @@ -0,0 +1,5 @@ +[1 of 2] Compiling BadImport02_A ( BadImport02_A.hs, BadImport02_A.o ) +[2 of 2] Compiling Main ( BadImport03.hs, BadImport03.o ) + +BadImport03.hs:8:1: + base:Data.Typeable can't be safely imported! The module itself isn't safe. diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep01.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep01.hs new file mode 100644 index 0000000000..5ee1cd0288 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep01.hs @@ -0,0 +1,13 @@ +module Dep01 where + +import Control.Monad +import Control.Monad.ST +import Data.STRef + +sumST :: Num a => [a] -> IO a +sumST xs = unsafeSTToIO $ do + n <- newSTRef 0 + forM_ xs $ \x -> do + modifySTRef n (+x) + readSTRef n + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep01.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep01.stderr new file mode 100644 index 0000000000..a21b4861dd --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep01.stderr @@ -0,0 +1,5 @@ + +Dep01.hs:4:1: + Warning: In the use of `unsafeSTToIO' + (imported from Control.Monad.ST): + Deprecated: "Please import from Control.Monad.ST.Unsafe instead; This will be removed in the next release" diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep02.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep02.hs new file mode 100644 index 0000000000..f9dbb26064 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep02.hs @@ -0,0 +1,16 @@ +module Dep02 where + +import Control.Monad +import Control.Monad.ST.Lazy +import Data.STRef.Lazy + +sumST :: Num a => [a] -> a +sumST xs = runST $ do + n <- newSTRef 0 + forM_ xs $ \x -> do + modifySTRef n (+x) + readSTRef n + +badST :: () +badST = runST $ unsafeIOToST $ putStrLn "Hello World" + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep02.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep02.stderr new file mode 100644 index 0000000000..8ae7621251 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep02.stderr @@ -0,0 +1,5 @@ + +Dep02.hs:4:1: + Warning: In the use of `unsafeIOToST' + (imported from Control.Monad.ST.Lazy): + Deprecated: "Please import from Control.Monad.ST.Lazy.Unsafe instead; This will be removed in the next release" diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep03.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep03.hs new file mode 100644 index 0000000000..b5f39affc7 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep03.hs @@ -0,0 +1,7 @@ +module Dep03 where + +import Foreign + +bad :: IO a -> a +bad = unsafePerformIO + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep03.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep03.stderr new file mode 100644 index 0000000000..51c4d0a850 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep03.stderr @@ -0,0 +1,5 @@ + +Dep03.hs:3:1: + Warning: In the use of `unsafePerformIO' + (imported from Foreign): + Deprecated: "Use System.IO.Unsafe.unsafePerformIO instead; This function will be removed in the next release" diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep04.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep04.hs new file mode 100644 index 0000000000..5ff23ea0ad --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep04.hs @@ -0,0 +1,8 @@ +module Dep04 where + +import Foreign.Ptr +import Foreign.ForeignPtr + +bad :: ForeignPtr a -> Ptr a +bad = unsafeForeignPtrToPtr + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep04.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep04.stderr new file mode 100644 index 0000000000..ef81bf4212 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep04.stderr @@ -0,0 +1,5 @@ + +Dep04.hs:4:1: + Warning: In the use of `unsafeForeignPtrToPtr' + (imported from Foreign.ForeignPtr): + Deprecated: "Use Foreign.ForeignPtr.Unsafe.unsafeForeignPtrToPtr instead; This function will be removed in the next release" diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep05.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep05.hs new file mode 100644 index 0000000000..da25c1a52a --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep05.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module Dep05 where + +import GHC.Arr + +bad1 = unsafeArray + +bad2 = fill + +bad3 = done + +bad4 = unsafeThawSTArray + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep05.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep05.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep05.stderr diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep06.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep06.hs new file mode 100644 index 0000000000..0a5811d02b --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep06.hs @@ -0,0 +1,6 @@ +module Dep06 where + +import GHC.Conc + +bad1 = unsafeIOToSTM + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep06.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep06.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep06.stderr diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep07.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep07.hs new file mode 100644 index 0000000000..6f0df7af11 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep07.hs @@ -0,0 +1,6 @@ +module Dep07 where + +import GHC.ForeignPtr + +bad1 = unsafeForeignPtrToPtr + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep07.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep07.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep07.stderr diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep08.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep08.hs new file mode 100644 index 0000000000..a3fbc7be61 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep08.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module Dep08 where + +import GHC.IOArray + +bad1 = unsafeReadIOArray + +bad2 = unsafeWriteIOArray + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep08.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep08.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep08.stderr diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep09.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep09.hs new file mode 100644 index 0000000000..beeb7ffe95 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep09.hs @@ -0,0 +1,6 @@ +module Dep09 where + +import GHC.Ptr + +bad1 = castFunPtrToPtr + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep09.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep09.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep09.stderr diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep10.hs b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep10.hs new file mode 100644 index 0000000000..70d660ed1c --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep10.hs @@ -0,0 +1,8 @@ +module Dep10 where + +import GHC.ST + +bad1 = liftST + +bad2 = unsafeInterleaveST + diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep10.stderr b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep10.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Dep10.stderr diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Makefile b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Makefile new file mode 100644 index 0000000000..9ce1411567 --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/Makefile @@ -0,0 +1,3 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk
\ No newline at end of file diff --git a/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/all.T b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/all.T new file mode 100644 index 0000000000..c985b65c3c --- /dev/null +++ b/testsuite/tests/ghc-regress/safeHaskell/unsafeLibs/all.T @@ -0,0 +1,21 @@ +# Just do the normal way, SafeHaskell is all in the frontend +def f( opts ): + opts.only_ways = ['normal'] + +setTestOpts(f) + +test('Dep01', normal, compile, ['']) +test('Dep02', normal, compile, ['']) +test('Dep03', normal, compile, ['']) +test('Dep04', normal, compile, ['']) +test('Dep05', normal, compile, ['']) +test('Dep06', normal, compile, ['']) +test('Dep07', normal, compile, ['']) +test('Dep08', normal, compile, ['']) +test('Dep09', normal, compile, ['']) +test('Dep10', normal, compile, ['']) + +test('BadImport01', normal, compile_fail, ['']) +test('BadImport02', normal, compile_and_run, ['--make']) +test('BadImport03', normal, compile_fail, ['--make']) + |