Implement addCStub in template-haskell.

Summary:
addCStub allows injecting C code in the current module to be included
in the final object file.

Test Plan: ./validate

Reviewers: simonpj, goldfire, austin, bgamari

Reviewed By: bgamari

Subscribers: bitonic, duncan, mboes, thomie

Differential Revision: https://phabricator.haskell.org/D3106

5 files changed, 55 insertions, 0 deletions

diff --git a/testsuite/tests/th/TH_addCStub1.hs b/testsuite/tests/th/TH_addCStub1.hs
new file mode 100644
index 0000000000..3a2c5c3609
--- /dev/null
+++ b/testsuite/tests/th/TH_addCStub1.hs
@@ -0,0 +1,22 @@
+-- Tests that addCStub includes the C code in the final object file and that
+-- -optc options are passed when building it.
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -optc-DA_MACRO=1 #-}
+
+import Language.Haskell.TH.Syntax
+
+foreign import ccall f :: Int -> IO Int
+
+do addCStub $ unlines
+     [ "#include <stdio.h>"
+     , "int f(int x) {"
+     , "  printf(\"calling f(%d)\\n\",x);"
+     , "  return A_MACRO + x;"
+     , "}"
+     ]
+   return []
+
+main :: IO ()
+main = f 2 >>= print
diff --git a/testsuite/tests/th/TH_addCStub1.stdout b/testsuite/tests/th/TH_addCStub1.stdout
new file mode 100644
index 0000000000..e46825eb2b
--- /dev/null
+++ b/testsuite/tests/th/TH_addCStub1.stdout
@@ -0,0 +1,2 @@
+3
+calling f(2)
diff --git a/testsuite/tests/th/TH_addCStub2.hs b/testsuite/tests/th/TH_addCStub2.hs
new file mode 100644
index 0000000000..10119d9370
--- /dev/null
+++ b/testsuite/tests/th/TH_addCStub2.hs
@@ -0,0 +1,22 @@
+-- Tests that a reasonable error is reported when addCStub is used with
+-- incorrect C code.
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -optc-DA_MACRO=1 #-}
+
+import Language.Haskell.TH.Syntax
+
+foreign import ccall f :: Int -> IO Int
+
+do addCStub $ unlines
+     [ "#include <stdio.h>"
+     , "int f(int x {"
+     , "  printf(\"calling f(%d)\\n\",x);"
+     , "  return A_MACRO + x;"
+     , "}"
+     ]
+   return []
+
+main :: IO ()
+main = f 2 >>= print
diff --git a/testsuite/tests/th/TH_addCStub2.stderr b/testsuite/tests/th/TH_addCStub2.stderr
new file mode 100644
index 0000000000..ba3277b277
--- /dev/null
+++ b/testsuite/tests/th/TH_addCStub2.stderr
@@ -0,0 +1,6 @@
+
+TH_addCStub2.hs:13:13:
+     expected ‘;’, ‘,’ or ‘)’ before ‘{’ token
+          [ "#include <stdio.h>"
+                 ^
+`gcc' failed in phase `C Compiler'. (Exit code: 1)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index f05a634301..9a08b6542c 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -63,6 +63,9 @@ test('TH_reifyDecl2', normal, compile, ['-v0'])
 test('TH_reifyLocalDefs', normal, compile, ['-v0'])
 test('TH_reifyLocalDefs2', normal, compile, ['-v0'])
 
+test('TH_addCStub1', normal, compile_and_run, ['-v0'])
+test('TH_addCStub2', normal, compile_fail, ['-v0'])
+
 test('TH_reifyMkName', normal, compile, ['-v0'])
 
 test('TH_reifyInstances', normal, compile, ['-v0'])