Support adding objects from TH

The user facing TH interface changes are:

  * 'addForeignFile' is renamed to 'addForeignSource'
  * 'qAddForeignFile'/'addForeignFile' now expect 'FilePath's
  * 'RawObject' is now a constructor for 'ForeignSrcLang'
  * 'qAddTempFile'/'addTempFile' let you request a temporary file
    from the compiler.

Test Plan: unsure about this, added a TH test

Reviewers: goldfire, bgamari, angerman

Reviewed By: bgamari, angerman

Subscribers: hsyl20, mboes, carter, simonmar, bitonic, ljli, rwbarton, thomie

GHC Trac Issues: #14298

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

4 files changed, 64 insertions, 26 deletions

diff --git a/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs
index f6c1a2e47a..4841de89c7 100644
--- a/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs
+++ b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs
@@ -6,5 +6,5 @@ module GHC.ForeignSrcLang.Type
 import GHC.Generics (Generic)
 
 data ForeignSrcLang
-  = LangC | LangCxx | LangObjc | LangObjcxx
+  = LangC | LangCxx | LangObjc | LangObjcxx | RawObject
   deriving (Eq, Show, Generic)
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 380edf6057..f69fff29ff 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -235,10 +235,11 @@ data THMessage a where
   ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])
 
   AddDependentFile :: FilePath -> THMessage (THResult ())
+  AddTempFile :: String -> THMessage (THResult FilePath)
   AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
   AddCorePlugin :: String -> THMessage (THResult ())
   AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
-  AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())
+  AddForeignFilePath :: ForeignSrcLang -> FilePath -> THMessage (THResult ())
   IsExtEnabled :: Extension -> THMessage (THResult Bool)
   ExtsEnabled :: THMessage (THResult [Extension])
 
@@ -268,14 +269,15 @@ getTHMessage = do
     8  -> THMsg <$> ReifyModule <$> get
     9  -> THMsg <$> ReifyConStrictness <$> get
     10 -> THMsg <$> AddDependentFile <$> get
-    11 -> THMsg <$> AddTopDecls <$> get
-    12 -> THMsg <$> (IsExtEnabled <$> get)
-    13 -> THMsg <$> return ExtsEnabled
-    14 -> THMsg <$> return StartRecover
-    15 -> THMsg <$> EndRecover <$> get
-    16 -> return (THMsg RunTHDone)
-    17 -> THMsg <$> AddModFinalizer <$> get
-    18 -> THMsg <$> (AddForeignFile <$> get <*> get)
+    11 -> THMsg <$> AddTempFile <$> get
+    12 -> THMsg <$> AddTopDecls <$> get
+    13 -> THMsg <$> (IsExtEnabled <$> get)
+    14 -> THMsg <$> return ExtsEnabled
+    15 -> THMsg <$> return StartRecover
+    16 -> THMsg <$> EndRecover <$> get
+    17 -> return (THMsg RunTHDone)
+    18 -> THMsg <$> AddModFinalizer <$> get
+    19 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
     _  -> THMsg <$> AddCorePlugin <$> get
 
 putTHMessage :: THMessage a -> Put
@@ -291,15 +293,16 @@ putTHMessage m = case m of
   ReifyModule a               -> putWord8 8  >> put a
   ReifyConStrictness a        -> putWord8 9  >> put a
   AddDependentFile a          -> putWord8 10 >> put a
-  AddTopDecls a               -> putWord8 11 >> put a
-  IsExtEnabled a              -> putWord8 12 >> put a
-  ExtsEnabled                 -> putWord8 13
-  StartRecover                -> putWord8 14
-  EndRecover a                -> putWord8 15 >> put a
-  RunTHDone                   -> putWord8 16
-  AddModFinalizer a           -> putWord8 17 >> put a
-  AddForeignFile lang a       -> putWord8 18 >> put lang >> put a
-  AddCorePlugin a             -> putWord8 19 >> put a
+  AddTempFile a               -> putWord8 11 >> put a
+  AddTopDecls a               -> putWord8 12 >> put a
+  IsExtEnabled a              -> putWord8 13 >> put a
+  ExtsEnabled                 -> putWord8 14
+  StartRecover                -> putWord8 15
+  EndRecover a                -> putWord8 16 >> put a
+  RunTHDone                   -> putWord8 17
+  AddModFinalizer a           -> putWord8 18 >> put a
+  AddForeignFilePath lang a   -> putWord8 19 >> put lang >> put a
+  AddCorePlugin a             -> putWord8 20 >> put a
 
 
 data EvalOpts = EvalOpts
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index 905e003c1a..aebc32c03a 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -195,8 +195,9 @@ instance TH.Quasi GHCiQ where
   qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
   qLocation = fromMaybe noLoc . qsLocation <$> getState
   qAddDependentFile file = ghcCmd (AddDependentFile file)
+  qAddTempFile suffix = ghcCmd (AddTempFile suffix)
   qAddTopDecls decls = ghcCmd (AddTopDecls decls)
-  qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)
+  qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
   qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
                          ghcCmd . AddModFinalizer
   qAddCorePlugin str = ghcCmd (AddCorePlugin str)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 7589619fed..3a3cf60349 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -84,9 +84,11 @@ class (MonadIO m, Fail.MonadFail m) => Quasi m where
 
   qAddDependentFile :: FilePath -> m ()
 
+  qAddTempFile :: String -> m FilePath
+
   qAddTopDecls :: [Dec] -> m ()
 
-  qAddForeignFile :: ForeignSrcLang -> String -> m ()
+  qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
 
   qAddModFinalizer :: Q () -> m ()
 
@@ -128,8 +130,9 @@ instance Quasi IO where
   qLocation             = badIO "currentLocation"
   qRecover _ _          = badIO "recover" -- Maybe we could fix this?
   qAddDependentFile _   = badIO "addDependentFile"
+  qAddTempFile _        = badIO "addTempFile"
   qAddTopDecls _        = badIO "addTopDecls"
-  qAddForeignFile _ _   = badIO "addForeignFile"
+  qAddForeignFilePath _ _ = badIO "addForeignFilePath"
   qAddModFinalizer _    = badIO "addModFinalizer"
   qAddCorePlugin _      = badIO "addCorePlugin"
   qGetQ                 = badIO "getQ"
@@ -445,11 +448,23 @@ runIO m = Q (qRunIO m)
 addDependentFile :: FilePath -> Q ()
 addDependentFile fp = Q (qAddDependentFile fp)
 
+-- | Obtain a temporary file path with the given suffix. The compiler will
+-- delete this file after compilation.
+addTempFile :: String -> Q FilePath
+addTempFile suffix = Q (qAddTempFile suffix)
+
 -- | Add additional top-level declarations. The added declarations will be type
 -- checked along with the current declaration group.
 addTopDecls :: [Dec] -> Q ()
 addTopDecls ds = Q (qAddTopDecls ds)
 
+-- |
+addForeignFile :: ForeignSrcLang -> String -> Q ()
+addForeignFile = addForeignSource
+{-# DEPRECATED addForeignFile
+               "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"
+  #-} -- deprecated in 8.6
+
 -- | 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
@@ -463,12 +478,30 @@ addTopDecls ds = Q (qAddTopDecls ds)
 --
 -- > {-# LANGUAGE CPP #-}
 -- > ...
--- > addForeignFile LangC $ unlines
+-- > addForeignSource LangC $ unlines
 -- >   [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
 -- >   , ...
 -- >   ]
-addForeignFile :: ForeignSrcLang -> String -> Q ()
-addForeignFile lang str = Q (qAddForeignFile lang str)
+addForeignSource :: ForeignSrcLang -> String -> Q ()
+addForeignSource lang src = do
+  let suffix = case lang of
+                 LangC -> "c"
+                 LangCxx -> "cpp"
+                 LangObjc -> "m"
+                 LangObjcxx -> "mm"
+                 RawObject -> "a"
+  path <- addTempFile suffix
+  runIO $ writeFile path src
+  addForeignFilePath lang path
+
+-- | Same as 'addForeignSource', but expects to recieve a path pointing to the
+-- foreign file instead of a 'String' of its contents. Consider using this in
+-- conjunction with 'addTempFile'.
+--
+-- This is a good alternative to 'addForeignSource' when you are trying to
+-- directly link in an object file.
+addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
+addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
 
 -- | 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.
@@ -524,8 +557,9 @@ instance Quasi Q where
   qLookupName         = lookupName
   qLocation           = location
   qAddDependentFile   = addDependentFile
+  qAddTempFile        = addTempFile
   qAddTopDecls        = addTopDecls
-  qAddForeignFile     = addForeignFile
+  qAddForeignFilePath = addForeignFilePath
   qAddModFinalizer    = addModFinalizer
   qAddCorePlugin      = addCorePlugin
   qGetQ               = getQ