Move tests from tests/ghc-regress/* to just tests/*

21 files changed, 345 insertions, 0 deletions

diff --git a/testsuite/tests/ffi/should_compile/1357.hs b/testsuite/tests/ffi/should_compile/1357.hs
new file mode 100644
index 0000000000..1f5479bc1c
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/1357.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module T where
+
+import Foreign
+foreign import ccall "f" f :: FunPtr (Int -> IO ())
diff --git a/testsuite/tests/ffi/should_compile/1357.stderr b/testsuite/tests/ffi/should_compile/1357.stderr
new file mode 100644
index 0000000000..cd1cb7031a
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/1357.stderr
@@ -0,0 +1,3 @@
+
+1357.hs:5:1:
+    Warning: possible missing & in foreign import of FunPtr
diff --git a/testsuite/tests/ffi/should_compile/3624.hs b/testsuite/tests/ffi/should_compile/3624.hs
new file mode 100644
index 0000000000..8f42efc055
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/3624.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Test where
+
+foreign import ccall "path/to/foo.h foo" foo :: Int -> IO Float
diff --git a/testsuite/tests/ffi/should_compile/3742.hs b/testsuite/tests/ffi/should_compile/3742.hs
new file mode 100644
index 0000000000..c16b6009eb
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/3742.hs
@@ -0,0 +1,12 @@
+module ShouldCompile where
+
+import Foreign
+import Foreign.C
+
+-- extra space before the function name:
+foreign import ccall unsafe " g_get_application_name"
+  g_get_application_name :: (IO (Ptr CChar))
+
+-- and after:
+foreign import ccall unsafe "g_get_application_name "
+  g_get_application_name' :: (IO (Ptr CChar))
diff --git a/testsuite/tests/ffi/should_compile/Makefile b/testsuite/tests/ffi/should_compile/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ffi/should_compile/all.T b/testsuite/tests/ffi/should_compile/all.T
new file mode 100644
index 0000000000..ff8bc64b5d
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/all.T
@@ -0,0 +1,38 @@
+
+def ffi( opts ):
+  opts.extra_hc_opts = '-XForeignFunctionInterface -optc-Wno-implicit'
+
+setTestOpts(ffi)
+
+test('cc001', normal, compile, [''])
+
+# Non-static C call
+# cc004 test also uses stdcall, so it only works on i386.
+if config.platform.startswith('i386-'):
+	ways = expect_fail_for(['extcore','optextcore'])
+else:
+	ways = expect_fail
+test('cc004', ways, compile, [''])
+
+# foreign label
+test('cc005', expect_fail_for(['extcore','optextcore']), compile, [''])
+
+# Missing:
+# test('cc006', normal, compile, [''])
+
+test('cc007', normal, compile, [''])
+# foreign label
+test('cc008', expect_fail_for(['extcore','optextcore']), compile, [''])
+# foreign label
+test('cc009', expect_fail_for(['extcore','optextcore']), compile, [''])
+# Non-static C call
+test('cc010', expect_fail_for(['extcore','optextcore']), compile, [''])
+test('cc011', normal, compile, [''])
+test('cc012', normal, compile, [''])
+test('cc013', normal, compile, [''])
+test('cc014', normal, compile, [''])
+test('ffi-deriv1', normal, compile, [''])
+
+test('1357', normal, compile, [''])
+test('3624', normal, compile, [''])
+test('3742', normal, compile, [''])
diff --git a/testsuite/tests/ffi/should_compile/cc001.hs b/testsuite/tests/ffi/should_compile/cc001.hs
new file mode 100644
index 0000000000..cd7318d000
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc001.hs
@@ -0,0 +1,21 @@
+-- !!! cc001 -- ccall with standard boxed arguments and results
+
+module ShouldCompile where
+
+-- simple functions
+
+foreign import ccall unsafe "a" a :: IO Int
+
+foreign import ccall unsafe "b" b :: Int -> IO Int
+
+foreign import ccall unsafe "c" 
+  c :: Int -> Char -> Float -> Double -> IO Float
+
+-- simple monadic code
+
+d =	a		>>= \ x ->
+	b x		>>= \ y ->
+	c y 'f' 1.0 2.0
+
+
+	
diff --git a/testsuite/tests/ffi/should_compile/cc001.stderr b/testsuite/tests/ffi/should_compile/cc001.stderr
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc001.stderr
diff --git a/testsuite/tests/ffi/should_compile/cc004.hs b/testsuite/tests/ffi/should_compile/cc004.hs
new file mode 100644
index 0000000000..fb754223b2
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc004.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE MagicHash, UnliftedFFITypes #-}
+-- !!! cc004 -- foreign declarations
+module ShouldCompile where
+
+import Foreign
+import GHC.Exts
+import Data.Int
+import Data.Word
+
+-- importing functions
+
+-- We can't import the same function using both stdcall and ccall
+-- calling conventions in the same file when compiling via C (this is a
+-- restriction in the C backend caused by the need to emit a prototype
+-- for stdcall functions).
+foreign import stdcall        "p" m_stdcall :: StablePtr a -> IO (StablePtr b)
+foreign import ccall   unsafe "q" m_ccall   :: ByteArray# -> IO Int
+
+-- We can't redefine the calling conventions of certain functions (those from
+-- math.h).
+foreign import stdcall "my_sin" my_sin :: Double -> IO Double
+foreign import stdcall "my_cos" my_cos :: Double -> IO Double
+
+foreign import stdcall "m1" m8  :: IO Int8
+foreign import stdcall "m2" m16 :: IO Int16
+foreign import stdcall "m3" m32 :: IO Int32
+foreign import stdcall "m4" m64 :: IO Int64
+
+foreign import stdcall "dynamic" d8  :: Ptr a -> IO Int8
+foreign import stdcall "dynamic" d16 :: Ptr a -> IO Int16
+foreign import stdcall "dynamic" d32 :: Ptr a -> IO Int32
+foreign import stdcall "dynamic" d64 :: Ptr a -> IO Int64
+
+foreign import ccall unsafe "kitchen"
+   sink :: Ptr a
+        -> ByteArray#
+	-> MutableByteArray# RealWorld
+	-> Int
+	-> Int8
+	-> Int16
+	-> Int32
+	-> Int64
+	-> Word8
+	-> Word16
+	-> Word32
+	-> Word64
+	-> Float
+	-> Double
+	-> IO ()
+
+
+foreign import ccall unsafe "dynamic"
+  sink2 :: Ptr a
+        -> (Ptr b
+        -> ByteArray#
+	-> MutableByteArray# RealWorld
+	-> Int
+	-> Int8
+	-> Int16
+	-> Int32
+	-> Word8
+	-> Word16
+	-> Word32
+	-> Float
+	-> Double
+	-> IO ())
+
diff --git a/testsuite/tests/ffi/should_compile/cc005.hs b/testsuite/tests/ffi/should_compile/cc005.hs
new file mode 100644
index 0000000000..e057cfd233
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc005.hs
@@ -0,0 +1,108 @@
+-- !!! cc005 -- foreign export declarations
+module ShouldCompile (d8) where
+
+import Foreign.Ptr   --import Foreign
+                 --import GlaExts
+                 --import Int
+                 --import Word
+type Addr = Ptr ()
+foreign import ccall "wrapper" d8  :: (Int -> IO ())  -> IO Addr
+
+-- exporting functions
+{-
+m_stdcall :: Int -> IO Int
+m_stdcall x = return x
+
+x = putChar
+
+foreign export ccall "m1" doo :: Int -> IO Int
+
+doo :: Eq a => a -> IO Int
+doo _ = return 2
+
+foreign export ccall "listAppend" plusplus :: StablePtr [a] -> StablePtr [a] -> IO (StablePtr [a])
+
+plusplus :: StablePtr [a] -> StablePtr [a] -> IO (StablePtr [a])
+plusplus x y = do
+  l1 <- deRefStablePtr x
+  l2 <- deRefStablePtr y
+  makeStablePtr (l1 ++ l2)
+
+foreign export ccall "m11" m_stdcall :: Int -> IO Int
+
+m_ccall :: Int -> Int -> IO Int
+m_ccall x y = return (x-y)
+
+foreign export ccall   "m2" m_ccall   :: Int -> Int -> IO Int
+
+foreign export ccall   "putcha" putChar :: Char -> IO ()
+
+foreign export stdcall "Math" "sin" my_sin :: Double -> IO Double
+foreign export stdcall "Math" "cos" my_cos :: Double -> IO Double
+
+my_sin = undefined
+my_cos = undefined
+
+foreign export stdcall "m111" m8  :: IO Int8
+foreign export stdcall "m22" m16 :: IO Int16
+foreign export stdcall "m3" m32 :: IO Int32
+foreign export stdcall "m4" m64 :: IO Int64
+
+m8 = undefined
+m16 = undefined
+m32 = undefined
+m64 = undefined
+
+foreign export stdcall dynamic d8  :: (Addr -> IO Int8)  -> IO Addr
+foreign export stdcall dynamic d16 :: (Addr -> IO Int16) -> IO Addr
+foreign export stdcall dynamic d32 :: (Addr -> IO Int32) -> IO Addr
+foreign export stdcall dynamic d64 :: (Addr -> IO Int64) -> IO Addr
+
+
+d8 = undefined
+d16 = undefined
+d32 = undefined
+d64 = undefined
+
+
+foreign export ccall "kitchen"
+   sink :: --ForeignObj 
+--        -> ByteArray Int 
+--	-> MutableByteArray Int RealWorld
+	   Int
+	-> Int8
+	-> Int16
+	-> Int32
+	-> Int64
+	-> Word8
+	-> Word16
+	-> Word32
+	-> Word64
+	-> Float
+	-> Double
+	-> IO Int
+
+sink  = undefined
+sink2 = undefined
+
+foreign export ccall dynamic
+  sink2 :: (--ForeignObj 
+--        -> ByteArray Int 
+--	-> MutableByteArray Int RealWorld
+	   StablePtr a
+	-> Int
+	-> Int8
+	-> Int16
+	-> Int32
+	-> Int64
+	-> Word8
+	-> Word16
+	-> Word32
+	-> Word64
+	-> Float
+	-> Double
+	-> IO ())
+	-> IO Addr
+
+
+-}
diff --git a/testsuite/tests/ffi/should_compile/cc007.hs b/testsuite/tests/ffi/should_compile/cc007.hs
new file mode 100644
index 0000000000..99337cc37f
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc007.hs
@@ -0,0 +1,4 @@
+-- !!! cc007 -- foreign import with external name equal to Haskell name.
+module ShouldCompile where
+
+foreign import ccall sine :: Double -> Double
diff --git a/testsuite/tests/ffi/should_compile/cc008.hs b/testsuite/tests/ffi/should_compile/cc008.hs
new file mode 100644
index 0000000000..2dd0bc99eb
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc008.hs
@@ -0,0 +1,8 @@
+-- !!! cc008 -- foreign export dynamic returning newtype of Addr
+module ShouldCompile where
+
+import Foreign
+type Addr = Ptr ()
+newtype NPtr a = NPtr Addr
+
+foreign import ccall "wrapper" mkFoo :: IO () -> IO (NPtr Int)
diff --git a/testsuite/tests/ffi/should_compile/cc009.hs b/testsuite/tests/ffi/should_compile/cc009.hs
new file mode 100644
index 0000000000..3ece3a9a24
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc009.hs
@@ -0,0 +1,8 @@
+-- !!! cc009 -- foreign label returning newtype of Addr
+module ShouldCompile where
+
+import Foreign
+type Addr = Ptr ()
+newtype NPtr a = NPtr Addr
+
+foreign import ccall "&" foo :: NPtr Int
diff --git a/testsuite/tests/ffi/should_compile/cc009_inc.h b/testsuite/tests/ffi/should_compile/cc009_inc.h
new file mode 100644
index 0000000000..be2f5392f8
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc009_inc.h
@@ -0,0 +1 @@
+extern void *foo;
diff --git a/testsuite/tests/ffi/should_compile/cc010.hs b/testsuite/tests/ffi/should_compile/cc010.hs
new file mode 100644
index 0000000000..dd34730d42
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc010.hs
@@ -0,0 +1,5 @@
+module ShouldCompile where
+import Foreign
+foreign import ccall "dynamic" imp :: Ptr () -> Int
+f1 a = imp a + 1
+f2 a = imp a + 2
diff --git a/testsuite/tests/ffi/should_compile/cc011.hs b/testsuite/tests/ffi/should_compile/cc011.hs
new file mode 100644
index 0000000000..25cce84bd3
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc011.hs
@@ -0,0 +1,9 @@
+module ShouldCompile where
+
+import Foreign
+
+-- !!! test that a recursive newtype can be used as an argument or result
+-- type of a foreign import. 
+
+newtype T = T (Ptr T)
+foreign import ccall foo :: T -> IO T
diff --git a/testsuite/tests/ffi/should_compile/cc011.stderr-hugs b/testsuite/tests/ffi/should_compile/cc011.stderr-hugs
new file mode 100644
index 0000000000..d6f9e1788c
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc011.stderr-hugs
@@ -0,0 +1,2 @@
+cc011.c: In function `hugsprim_foo_0':
+cc011.c:16: warning: assignment makes pointer from integer without a cast
diff --git a/testsuite/tests/ffi/should_compile/cc012.hs b/testsuite/tests/ffi/should_compile/cc012.hs
new file mode 100644
index 0000000000..288f9acd02
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc012.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-- !!! test that infix operators can be exported with foreign export,
+-- and that we can export something which isn't defined in this module.
+module ShouldCompile where
+foreign export ccall "plusInt" (+) :: Int -> Int -> Int
+
diff --git a/testsuite/tests/ffi/should_compile/cc013.hs b/testsuite/tests/ffi/should_compile/cc013.hs
new file mode 100644
index 0000000000..09dd2ef2ef
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc013.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-- !!! test that exporting the same thing multiple times works.
+module ShouldCompile where
+
+import Data.Int
+
+foreign export ccall "addByte" (+) :: Int8  -> Int8  -> Int8
+foreign export ccall "addInt"  (+) :: Int16 -> Int16 -> Int16
+foreign export ccall "addLong" (+) :: Int32 -> Int32 -> Int32
+
+foreign export ccall "divByte" div :: Int8  -> Int8  -> Int8
+foreign export ccall "divInt"  div :: Int16 -> Int16 -> Int16
+foreign export ccall "divLong" div :: Int32 -> Int32 -> Int32
+
diff --git a/testsuite/tests/ffi/should_compile/cc014.hs b/testsuite/tests/ffi/should_compile/cc014.hs
new file mode 100644
index 0000000000..bbf2d765ed
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/cc014.hs
@@ -0,0 +1,4 @@
+module Blah ( foo ) where
+import Foreign.Ptr ( FunPtr )
+type Bar = Int -> Double -> Double -> Double -> IO ()
+foreign import ccall unsafe "dynamic" foo :: FunPtr Bar -> Bar
diff --git a/testsuite/tests/ffi/should_compile/ffi-deriv1.hs b/testsuite/tests/ffi/should_compile/ffi-deriv1.hs
new file mode 100644
index 0000000000..94d0df2fa4
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/ffi-deriv1.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+

+-- Tests newtype unwrapping for the IO monad itself

+-- Notice the RenderM monad, which is used in the

+-- type of the callback function

+

+module ShouldCompile where

+

+import Foreign.Ptr

+newtype RenderM a = RenderM (IO a) deriving (Functor, Monad)

+

+type RenderCallback = Int -> Int -> RenderM ()

+

+foreign import ccall duma_onRender :: FunPtr RenderCallback -> RenderM ()

+

+foreign import ccall "wrapper" mkRenderCallback

+     :: RenderCallback -> RenderM (FunPtr RenderCallback)

+

+onRender :: RenderCallback -> RenderM ()

+onRender f = mkRenderCallback f >>= duma_onRender

+

+

+