Allow compilation of C/C++/ObjC/ObjC++ files with module from TH

The main goal is to easily allow the inline-c project (and
similar projects such as inline-java) to emit C/C++ files to
be compiled and linked with the current module.

Moreover, `addCStub` is removed, since it's quite fragile. Most
notably, the C stubs end up in the file generated by
`CodeOutput.outputForeignStubs`, which is tuned towards
generating a file for stubs coming from `capi` and Haskell-to-C
exports.

Reviewers: simonmar, austin, goldfire, facundominguez, dfeuer, bgamari

Reviewed By: dfeuer, bgamari

Subscribers: snowleopard, rwbarton, dfeuer, thomie, duncan, mboes

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

8 files changed, 46 insertions, 17 deletions

diff --git a/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs
new file mode 100644
index 0000000000..f6c1a2e47a
--- /dev/null
+++ b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DeriveGeneric #-}
+module GHC.ForeignSrcLang.Type
+  ( ForeignSrcLang(..)
+  ) where
+
+import GHC.Generics (Generic)
+
+data ForeignSrcLang
+  = LangC | LangCxx | LangObjc | LangObjcxx
+  deriving (Eq, Show, Generic)
diff --git a/libraries/ghc-boot-th/ghc-boot-th.cabal.in b/libraries/ghc-boot-th/ghc-boot-th.cabal.in
index 50b07db49d..17b25aa432 100644
--- a/libraries/ghc-boot-th/ghc-boot-th.cabal.in
+++ b/libraries/ghc-boot-th/ghc-boot-th.cabal.in
@@ -32,6 +32,7 @@ Library
 
     exposed-modules:
             GHC.LanguageExtensions.Type
+            GHC.ForeignSrcLang.Type
             GHC.Lexeme
 
     build-depends: base       >= 4.7 && < 4.11
diff --git a/libraries/ghc-boot/GHC/ForeignSrcLang.hs b/libraries/ghc-boot/GHC/ForeignSrcLang.hs
new file mode 100644
index 0000000000..9ca4f04cf7
--- /dev/null
+++ b/libraries/ghc-boot/GHC/ForeignSrcLang.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- | See @GHC.LanguageExtensions@ for an explanation
+-- on why this is needed
+module GHC.ForeignSrcLang
+  ( module GHC.ForeignSrcLang.Type
+  ) where
+
+import Data.Binary
+import GHC.ForeignSrcLang.Type
+
+instance Binary ForeignSrcLang
diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in
index 772b92ccdd..11febb4ac0 100644
--- a/libraries/ghc-boot/ghc-boot.cabal.in
+++ b/libraries/ghc-boot/ghc-boot.cabal.in
@@ -39,6 +39,7 @@ Library
             GHC.LanguageExtensions
             GHC.PackageDb
             GHC.Serialized
+            GHC.ForeignSrcLang
 
     build-depends: base       >= 4.7 && < 4.11,
                    binary     == 0.8.*,
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 37db0627e1..81de2fbd21 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -30,6 +30,7 @@ import GHCi.TH.Binary ()
 import GHCi.BreakArray
 
 import GHC.LanguageExtensions
+import GHC.ForeignSrcLang
 import GHC.Fingerprint
 import Control.Concurrent
 import Control.Exception
@@ -244,7 +245,7 @@ data THMessage a where
   AddDependentFile :: FilePath -> THMessage (THResult ())
   AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
   AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
-  AddCStub :: String -> THMessage (THResult ())
+  AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())
   IsExtEnabled :: Extension -> THMessage (THResult Bool)
   ExtsEnabled :: THMessage (THResult [Extension])
 
@@ -281,7 +282,7 @@ getTHMessage = do
     15 -> THMsg <$> EndRecover <$> get
     16 -> return (THMsg RunTHDone)
     17 -> THMsg <$> AddModFinalizer <$> get
-    _  -> THMsg <$> AddCStub <$> get
+    _  -> THMsg <$> (AddForeignFile <$> get <*> get)
 
 putTHMessage :: THMessage a -> Put
 putTHMessage m = case m of
@@ -303,7 +304,7 @@ putTHMessage m = case m of
   EndRecover a                -> putWord8 15 >> put a
   RunTHDone                   -> putWord8 16
   AddModFinalizer a           -> putWord8 17 >> put a
-  AddCStub a                  -> putWord8 18 >> put a
+  AddForeignFile lang a       -> putWord8 18 >> put lang >> put a
 
 
 data EvalOpts = EvalOpts
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index 8cb9accc5e..1b08501580 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -193,7 +193,7 @@ instance TH.Quasi GHCiQ where
   qRunIO m = GHCiQ $ \s -> fmap (,s) m
   qAddDependentFile file = ghcCmd (AddDependentFile file)
   qAddTopDecls decls = ghcCmd (AddTopDecls decls)
-  qAddCStub str = ghcCmd (AddCStub str)
+  qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)
   qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
                          ghcCmd . AddModFinalizer
   qGetQ = GHCiQ $ \s ->
diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in
index 631eed7190..d15da5a0f5 100644
--- a/libraries/ghci/ghci.cabal.in
+++ b/libraries/ghci/ghci.cabal.in
@@ -75,6 +75,7 @@ library
         deepseq          == 1.4.*,
         filepath         == 1.4.*,
         ghc-boot         == @ProjectVersionMunged@,
+        ghc-boot-th      == @ProjectVersionMunged@,
         template-haskell == 2.12.*,
         transformers     == 0.5.*
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index c531eeffd7..466834a9a4 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -27,6 +27,7 @@ module Language.Haskell.TH.Syntax
     ( module Language.Haskell.TH.Syntax
       -- * Language extensions
     , module Language.Haskell.TH.LanguageExtensions
+    , ForeignSrcLang(..)
     ) where
 
 import Data.Data hiding (Fixity(..))
@@ -40,6 +41,7 @@ import Data.Word
 import Data.Ratio
 import GHC.Generics     ( Generic )
 import GHC.Lexeme       ( startsVarSym, startsVarId )
+import GHC.ForeignSrcLang.Type
 import Language.Haskell.TH.LanguageExtensions
 import Numeric.Natural
 
@@ -92,7 +94,7 @@ class Monad m => Quasi m where
 
   qAddTopDecls :: [Dec] -> m ()
 
-  qAddCStub :: String -> m ()
+  qAddForeignFile :: ForeignSrcLang -> String -> m ()
 
   qAddModFinalizer :: Q () -> m ()
 
@@ -133,7 +135,7 @@ instance Quasi IO where
   qRecover _ _          = badIO "recover" -- Maybe we could fix this?
   qAddDependentFile _   = badIO "addDependentFile"
   qAddTopDecls _        = badIO "addTopDecls"
-  qAddCStub    _        = badIO "addCStub"
+  qAddForeignFile _ _   = badIO "addForeignFile"
   qAddModFinalizer _    = badIO "addModFinalizer"
   qGetQ                 = badIO "getQ"
   qPutQ _               = badIO "putQ"
@@ -459,24 +461,25 @@ addDependentFile fp = Q (qAddDependentFile fp)
 addTopDecls :: [Dec] -> Q ()
 addTopDecls ds = Q (qAddTopDecls ds)
 
--- | Add an additional C stub. The added stub will be built and included in the
--- object file of the current module.
+-- | Emit a foreign file which will be compiled and linked to the object for
+-- the current module. Currently only languages that can be compiled with
+-- the C compiler are supported, and the flags passed as part of -optc will
+-- be also applied to the C compiler invocation that will compile them.
 --
--- Compilation errors in the given string are reported next to the line of the
--- enclosing splice.
+-- Note that for non-C languages (for example C++) @extern "C"@ directives
+-- must be used to get symbols that we can access from Haskell.
 --
--- The accuracy of the error location can be improved by adding
--- #line pragmas in the argument. e.g.
+-- To get better errors, it is reccomended to use #line pragmas when
+-- emitting C files, e.g.
 --
 -- > {-# LANGUAGE CPP #-}
 -- > ...
--- > addCStub $ unlines
+-- > addForeignFile LangC $ unlines
 -- >   [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
 -- >   , ...
 -- >   ]
---
-addCStub :: String -> Q ()
-addCStub str = Q (qAddCStub str)
+addForeignFile :: ForeignSrcLang -> String -> Q ()
+addForeignFile lang str = Q (qAddForeignFile lang str)
 
 -- | Add a finalizer that will run in the Q monad after the current module has
 -- been type checked. This only makes sense when run within a top-level splice.
@@ -521,7 +524,7 @@ instance Quasi Q where
   qRunIO              = runIO
   qAddDependentFile   = addDependentFile
   qAddTopDecls        = addTopDecls
-  qAddCStub           = addCStub
+  qAddForeignFile     = addForeignFile
   qAddModFinalizer    = addModFinalizer
   qGetQ               = getQ
   qPutQ               = putQ