diff options
Diffstat (limited to 'testsuite/tests/safeHaskell/safeLanguage')
37 files changed, 501 insertions, 0 deletions
diff --git a/testsuite/tests/safeHaskell/safeLanguage/Makefile b/testsuite/tests/safeHaskell/safeLanguage/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/safeHaskell/safeLanguage/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang01.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang01.hs new file mode 100644 index 0000000000..5920c03161 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang01.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang01.stderr new file mode 100644 index 0000000000..18320eb727 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang02.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang02.hs new file mode 100644 index 0000000000..9bf1c82a09 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang02.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang02.stderr new file mode 100644 index 0000000000..6e3546968b --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang03.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang03.hs new file mode 100644 index 0000000000..4f3bce7e0a --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang03.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang03.stderr new file mode 100644 index 0000000000..fdcc5997d5 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang04.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang04.hs new file mode 100644 index 0000000000..a9ac3619f3 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang04.stdout b/testsuite/tests/safeHaskell/safeLanguage/SafeLang04.stdout new file mode 100644 index 0000000000..b80e6135bd --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang05.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang05.hs new file mode 100644 index 0000000000..1dd9016152 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang05.stdout b/testsuite/tests/safeHaskell/safeLanguage/SafeLang05.stdout new file mode 100644 index 0000000000..2334866860 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang06.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang06.hs new file mode 100644 index 0000000000..685846f150 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang06.stdout b/testsuite/tests/safeHaskell/safeLanguage/SafeLang06.stdout new file mode 100644 index 0000000000..ed005737b7 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang06_A.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang06_A.hs new file mode 100644 index 0000000000..d092ae7a1a --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang07.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.hs new file mode 100644 index 0000000000..006cd0ea08 --- /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 0000000000..1218b29a6d --- /dev/null +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr @@ -0,0 +1,7 @@ + +<no location info>: + 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 0000000000..6ef49d5946 --- /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/SafeLang08.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang08.hs new file mode 100644 index 0000000000..7249c8d0ec --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang08.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang08.stderr new file mode 100644 index 0000000000..fc7c7fa00d --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang08_A.c b/testsuite/tests/safeHaskell/safeLanguage/SafeLang08_A.c new file mode 100644 index 0000000000..d77ebad560 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang09.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang09.hs new file mode 100644 index 0000000000..4e20f177bf --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang09.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang09.stderr new file mode 100644 index 0000000000..27d951e959 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang09.stderr @@ -0,0 +1 @@ +SafeLang09: This curry is poisoned! diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang09_A.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang09_A.hs new file mode 100644 index 0000000000..129c2c4b56 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang09_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang09_B.hs new file mode 100644 index 0000000000..76e0fe5a1c --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang10.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.hs new file mode 100644 index 0000000000..ff5c168cff --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang10.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr new file mode 100644 index 0000000000..d9a671b08d --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang10.stdout b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stdout new file mode 100644 index 0000000000..32f4c5bbce --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang10_A.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10_A.hs new file mode 100644 index 0000000000..7be17b5ec0 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang10_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10_B.hs new file mode 100644 index 0000000000..5b9954c12e --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang11.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11.hs new file mode 100644 index 0000000000..11b32ec57c --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang11.stdout b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11.stdout new file mode 100644 index 0000000000..34f1bf217a --- /dev/null +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11.stdout @@ -0,0 +1 @@ +I have a value of A :: A1 is secret! diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_A.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_A.hs new file mode 100644 index 0000000000..7eb818183c --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang11_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs new file mode 100644 index 0000000000..8d81be6abc --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang12.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.hs new file mode 100644 index 0000000000..5817e54095 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang12.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr new file mode 100644 index 0000000000..1466921b07 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/SafeLang12_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs new file mode 100644 index 0000000000..f6ce559448 --- /dev/null +++ b/testsuite/tests/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/safeHaskell/safeLanguage/all.T b/testsuite/tests/safeHaskell/safeLanguage/all.T new file mode 100644 index 0000000000..7074c0f75c --- /dev/null +++ b/testsuite/tests/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', req_interp, compile_and_run, ['--make -trust base']) +test('SafeLang12', normal, compile_fail, ['--make -trust base']) + |