Add regression test case for old issue #493

5 files changed, 62 insertions, 0 deletions

diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index d9fa58dbdb..737c9f2385 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -694,6 +694,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
 /tests/ffi/should_run/Capi_Ctype_002
 /tests/ffi/should_run/Capi_Ctype_A_001.hs
 /tests/ffi/should_run/Capi_Ctype_A_002.hs
+/tests/ffi/should_run/T493
 /tests/ffi/should_run/T1288
 /tests/ffi/should_run/T1679
 /tests/ffi/should_run/T2276
diff --git a/testsuite/tests/ffi/should_run/T493.hs b/testsuite/tests/ffi/should_run/T493.hs
new file mode 100644
index 0000000000..d0f70c1eb7
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T493.hs
@@ -0,0 +1,41 @@
+import Foreign
+import Foreign.C
+
+-- These newtypes...
+newtype MyFunPtr a = MyFunPtr { getFunPtr :: FunPtr a }
+newtype MyPtr a = MyPtr (Ptr a)
+newtype MyIO a = MyIO { runIO :: IO a }
+-- should be supported by...
+
+-- foreign import dynamics
+foreign import ccall "dynamic"
+    mkFun1 :: MyFunPtr (CInt -> CInt) -> (CInt -> CInt)
+foreign import ccall "dynamic"
+    mkFun2 :: MyPtr (Int32 -> Int32) -> (CInt -> CInt)
+
+-- and foreign import wrappers.
+foreign import ccall "wrapper"
+    mkWrap1 :: (CInt -> CInt) -> MyIO (MyFunPtr (CInt -> CInt))
+foreign import ccall "wrapper"
+    mkWrap2 :: (CInt -> CInt) -> MyIO (MyPtr (Int32 -> Int32))
+
+-- We'll need a dynamic function point to export
+foreign import ccall "getDbl" getDbl :: IO (MyFunPtr (CInt -> CInt))
+-- and a Haskell function to export
+half :: CInt -> CInt
+half = (`div` 2)
+-- and a C function to pass it to.
+foreign import ccall "apply" apply1 :: MyFunPtr (CInt -> CInt) -> Int -> Int
+foreign import ccall "apply" apply2 :: MyPtr (Int32 -> Int32) -> Int -> Int
+
+main :: IO ()
+main = do
+
+  dbl <- getDbl
+  let dbl1 = mkFun1 dbl
+      dbl2 = mkFun2 $ MyPtr $ castFunPtrToPtr $ getFunPtr dbl
+  print (dbl1 21, dbl2 21)
+
+  half1 <- runIO $ mkWrap1 half
+  half2 <- runIO $ mkWrap2 half
+  print (apply1 half1 84, apply2 half2 84)
diff --git a/testsuite/tests/ffi/should_run/T493.stdout b/testsuite/tests/ffi/should_run/T493.stdout
new file mode 100644
index 0000000000..ef363a6b80
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T493.stdout
@@ -0,0 +1,2 @@
+(42,42)
+(42,42)
diff --git a/testsuite/tests/ffi/should_run/T493_c.c b/testsuite/tests/ffi/should_run/T493_c.c
new file mode 100644
index 0000000000..0cfa8648fa
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T493_c.c
@@ -0,0 +1,16 @@
+typedef int (*intfun_p)(int);
+
+int dbl(int x)
+{
+        return x*2;
+}
+
+intfun_p getDbl(void)
+{
+        return dbl;
+}
+
+int apply(intfun_p f, int x)
+{
+        return f(x);
+}
diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T
index d780fb809d..69b0f30c2c 100644
--- a/testsuite/tests/ffi/should_run/all.T
+++ b/testsuite/tests/ffi/should_run/all.T
@@ -198,3 +198,5 @@ test('PrimFFIWord8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord8_c.c'
 test('PrimFFIInt16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt16_c.c'])
 
 test('PrimFFIWord16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord16_c.c'])
+
+test('T493', [], compile_and_run, ['T493_c.c'])