Allow using tagetContents for modules needing preprocessing

This allows GHC API clients, most notably tooling such as
Haskell-IDE-Engine, to pass unsaved files to GHC more easily.

Currently when targetContents is used but the module requires preprocessing
'preprocessFile' simply throws an error because the pipeline does not
support passing a buffer.

This change extends `runPipeline` to allow passing the input buffer into
the pipeline. Before proceeding with the actual pipeline loop the input
buffer is immediately written out to a new tempfile.

I briefly considered refactoring the pipeline at large to pass around
in-memory buffers instead of files, but this seems needlessly complicated
since no pipeline stages other than Hsc could really support this at the
moment.

6 files changed, 242 insertions, 40 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 5fe2362973..8dd71d8317 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -52,7 +52,7 @@ import DynFlags
 import Config
 import Panic
 import Util
-import StringBuffer     ( hGetStringBuffer )
+import StringBuffer     ( StringBuffer, hGetStringBuffer, hPutStringBuffer )
 import BasicTypes       ( SuccessFlag(..) )
 import Maybes           ( expectJust )
 import SrcLoc
@@ -87,11 +87,14 @@ import Data.Time        ( UTCTime )
 -- of slurping in the OPTIONS pragmas
 
 preprocess :: HscEnv
-           -> (FilePath, Maybe Phase) -- ^ filename and starting phase
+           -> FilePath -- ^ input filename
+           -> Maybe StringBuffer
+           -- ^ optional buffer to use instead of reading input file
+           -> Maybe Phase -- ^ starting phase
            -> IO (DynFlags, FilePath)
-preprocess hsc_env (filename, mb_phase) =
-  ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
-  runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)
+preprocess hsc_env input_fn mb_input_buf mb_phase =
+  ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
+  runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)
         Nothing
         -- We keep the processed file for the whole session to save on
         -- duplicated work in ghci.
@@ -186,6 +189,7 @@ compileOne' m_tc_result mHscMessage
             -- handled properly
             _ <- runPipeline StopLn hsc_env
                               (output_fn,
+                               Nothing,
                                Just (HscOut src_flavour
                                             mod_name HscUpdateSig))
                               (Just basename)
@@ -223,6 +227,7 @@ compileOne' m_tc_result mHscMessage
             -- We're in --make mode: finish the compilation pipeline.
             _ <- runPipeline StopLn hsc_env
                               (output_fn,
+                               Nothing,
                                Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
                               (Just basename)
                               Persistent
@@ -313,7 +318,7 @@ compileForeign hsc_env lang stub_c = do
               LangAsm    -> As True -- allow CPP
               RawObject  -> panic "compileForeign: should be unreachable"
         (_, stub_o) <- runPipeline StopLn hsc_env
-                       (stub_c, Just (RealPhase phase))
+                       (stub_c, Nothing, Just (RealPhase phase))
                        Nothing (Temporary TFL_GhcSession)
                        Nothing{-no ModLocation-}
                        []
@@ -335,7 +340,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
   let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"
   writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
   _ <- runPipeline StopLn hsc_env
-                  (empty_stub, Nothing)
+                  (empty_stub, Nothing, Nothing)
                   (Just basename)
                   Persistent
                   (Just location)
@@ -525,9 +530,10 @@ compileFile hsc_env stop_phase (src, mb_phase) = do
         stop_phase' = case stop_phase of
                         As _ | split -> SplitAs
                         _            -> stop_phase
-
    ( _, out_file) <- runPipeline stop_phase' hsc_env
-                            (src, fmap RealPhase mb_phase) Nothing output
+                            (src, Nothing, fmap RealPhase mb_phase)
+                            Nothing
+                            output
                             Nothing{-no ModLocation-} []
    return out_file
 
@@ -560,13 +566,15 @@ doLink dflags stop_phase o_files
 runPipeline
   :: Phase                      -- ^ When to stop
   -> HscEnv                     -- ^ Compilation environment
-  -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)
+  -> (FilePath, Maybe StringBuffer, Maybe PhasePlus)
+                                -- ^ Pipeline input file name, optional
+                                -- buffer and maybe -x suffix
   -> Maybe FilePath             -- ^ original basename (if different from ^^^)
   -> PipelineOutput             -- ^ Output filename
   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
   -> [FilePath]                 -- ^ foreign objects
   -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
-runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
+runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)
              mb_basename output maybe_loc foreign_os
 
     = do let
@@ -618,8 +626,22 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
                                       ++ input_fn))
              HscOut {} -> return ()
 
+         -- Write input buffer to temp file if requested
+         input_fn' <- case (start_phase, mb_input_buf) of
+             (RealPhase real_start_phase, Just input_buf) -> do
+                 let suffix = phaseInputExt real_start_phase
+                 fn <- newTempName dflags TFL_CurrentModule suffix
+                 hdl <- openBinaryFile fn WriteMode
+                 -- Add a LINE pragma so reported source locations will
+                 -- mention the real input file, not this temp file.
+                 hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"
+                 hPutStringBuffer hdl input_buf
+                 hClose hdl
+                 return fn
+             (_, _) -> return input_fn
+
          debugTraceMsg dflags 4 (text "Running the pipeline")
-         r <- runPipeline' start_phase hsc_env env input_fn
+         r <- runPipeline' start_phase hsc_env env input_fn'
                            maybe_loc foreign_os
 
          -- If we are compiling a Haskell module, and doing
@@ -633,7 +655,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
                    (text "Running the pipeline again for -dynamic-too")
                let dflags' = dynamicTooMkDynamicDynFlags dflags
                hsc_env' <- newHscEnv dflags'
-               _ <- runPipeline' start_phase hsc_env' env input_fn
+               _ <- runPipeline' start_phase hsc_env' env input_fn'
                                  maybe_loc foreign_os
                return ()
          return r
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index d5f58f8f9b..5c76f2856d 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -64,7 +64,6 @@ import TcBackpack
 import Packages
 import UniqSet
 import Util
-import qualified GHC.LanguageExtensions as LangExt
 import NameEnv
 import FileCleanup
 
@@ -2426,35 +2425,13 @@ preprocessFile :: HscEnv
                -> Maybe Phase -- ^ Starting phase
                -> Maybe (StringBuffer,UTCTime)
                -> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile hsc_env src_fn mb_phase Nothing
+preprocessFile hsc_env src_fn mb_phase maybe_buf
   = do
-        (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
+        (dflags', hspp_fn)
+            <- preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
         buf <- hGetStringBuffer hspp_fn
         return (dflags', hspp_fn, buf)
 
-preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
-  = do
-        let dflags = hsc_dflags hsc_env
-        let local_opts = getOptions dflags buf src_fn
-
-        (dflags', leftovers, warns)
-            <- parseDynamicFilePragma dflags local_opts
-        checkProcessArgsResult dflags leftovers
-        handleFlagWarnings dflags' warns
-
-        let needs_preprocessing
-                | Just (Unlit _) <- mb_phase    = True
-                | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
-                  -- note: local_opts is only required if there's no Unlit phase
-                | xopt LangExt.Cpp dflags'      = True
-                | gopt Opt_Pp  dflags'          = True
-                | otherwise                     = False
-
-        when needs_preprocessing $
-           throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled")
-
-        return (dflags', src_fn, buf)
-
 
 -----------------------------------------------------------------------------
 --                      Error messages
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index d17fa5fcef..88edccf5bc 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -500,7 +500,11 @@ data Target
       targetId           :: TargetId, -- ^ module or filename
       targetAllowObjCode :: Bool,     -- ^ object code allowed?
       targetContents     :: Maybe (StringBuffer,UTCTime)
-                                        -- ^ in-memory text buffer?
+      -- ^ Optional in-memory buffer containing the source code GHC should
+      -- use for this target instead of reading it from disk.
+      --
+      -- Since GHC version 8.10 modules which require preprocessors such as
+      -- Literate Haskell or CPP to run are also supported.
     }
 
 data TargetId
diff --git a/testsuite/tests/ghc-api/target-contents/TargetContents.hs b/testsuite/tests/ghc-api/target-contents/TargetContents.hs
new file mode 100644
index 0000000000..db02dbde2b
--- /dev/null
+++ b/testsuite/tests/ghc-api/target-contents/TargetContents.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main where
+
+import DynFlags
+import GHC
+
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Data.List
+import Data.Maybe
+import Data.Time.Calendar
+import Data.Time.Clock
+import Exception
+import HeaderInfo
+import HscTypes
+import Outputable
+import StringBuffer
+import System.Directory
+import System.Environment
+import System.Process
+import System.IO
+import Text.Printf
+
+main :: IO ()
+main = do
+  libdir:args <- getArgs
+  createDirectoryIfMissing False "outdir"
+  runGhc (Just libdir) $ do
+    dflags0 <- getSessionDynFlags
+    (dflags1, xs, warn) <- parseDynamicFlags dflags0 $ map noLoc $
+        [ "-outputdir", "./outdir"
+        , "-fno-diagnostics-show-caret"
+        ] ++ args
+    _ <- setSessionDynFlags dflags1
+
+    -- This test fails on purpose to check if the error message mentions
+    -- the source file and not the intermediary preprocessor input file
+    -- even when no preprocessor is in use. Just a sanity check.
+    go "Error" ["A"]
+    --  ^        ^-- targets
+    --  ^-- test name
+      [("A"           -- this module's name
+       , ""           -- pragmas
+       , []           -- imports/non exported decls
+       , [("x", "z")] -- exported decls
+       , OnDisk       -- write this module to disk?
+       )
+      ]
+
+    forM_ [OnDisk, InMemory] $ \sync ->
+      -- This one fails unless CPP actually preprocessed the source
+      go ("CPP_" ++ ppSync sync) ["A"]
+        [( "A"
+         , "{-# LANGUAGE CPP #-}"
+         , ["#define y 1"]
+         , [("x", "y")]
+         , sync
+         )
+        ]
+
+    -- These check if on-disk modules can import in-memory targets and
+    -- vice-verca.
+    forM_ (words "DD MM DM MD") $ \sync@[a_sync, b_sync] -> do
+      dep <- return $ \y ->
+         [( "A"
+         , "{-# LANGUAGE CPP #-}"
+         , ["import B"]
+         , [("x", "y")]
+         , readSync a_sync
+         ),
+         ( "B"
+         , "{-# LANGUAGE CPP #-}"
+         , []
+         , [("y", y)]
+         , readSync b_sync
+         )
+        ]
+      go ("Dep_" ++ sync ++ "_AB")       ["A", "B"] (dep "()")
+
+      -- This checks if error messages are correctly referring to the real
+      -- source file and not the temp preprocessor input file.
+      go ("Dep_Error_" ++ sync ++ "_AB") ["A", "B"] (dep "z")
+
+      -- Try with only one target, this is expected to fail with a module
+      -- not found error where module B is not OnDisk.
+      go ("Dep_Error_" ++ sync ++ "_A")  ["A"]      (dep "z")
+
+    return ()
+
+data Sync
+    = OnDisk   -- | Write generated module to disk
+    | InMemory -- | Only fill targetContents, place an empty dummy module
+               -- on disk though to make Finder shut up though.
+
+ppSync OnDisk   = "D"
+ppSync InMemory = "M"
+
+readSync 'D' = OnDisk
+readSync 'M' = InMemory
+
+go label targets mods = do
+    liftIO $ createDirectoryIfMissing False "./outdir"
+    setTargets []; _ <- load LoadAllTargets
+
+    liftIO $ hPutStrLn stderr $ "== " ++ label
+    t <- liftIO getCurrentTime
+    setTargets =<< catMaybes <$> mapM (mkTarget t) mods
+    ex <- gtry $ load LoadAllTargets
+    case ex of
+      Left ex -> liftIO $ hPutStrLn stderr $ show (ex :: SourceError)
+      Right _ -> return ()
+
+    mapM_ (liftIO . cleanup) mods
+    liftIO $ removeDirectoryRecursive "./outdir"
+
+  where
+    mkTarget t mod@(name,_,_,_,sync) = do
+      src <- liftIO $ genMod mod
+      return $ if not (name `elem` targets)
+         then Nothing
+         else Just $ Target
+           { targetId = TargetFile (name++".hs") Nothing
+           , targetAllowObjCode = False
+           , targetContents =
+               case sync of
+                 OnDisk -> Nothing
+                 InMemory ->
+                   Just ( stringToStringBuffer src
+                        , t
+                        )
+           }
+
+genMod :: (String, String, [String], [(String, String)], Sync) -> IO String
+genMod (mod, pragmas, internal, binders, sync) = do
+    case sync of
+      OnDisk   -> writeFile (mod++".hs") src
+      InMemory -> return ()
+    return src
+  where
+    exports = intercalate ", " $ map fst binders
+    decls = map (\(b,v) -> b ++ " = " ++ v) binders
+    src = unlines $
+      [ pragmas
+      , "module " ++ mod ++ " ("++ exports ++") where"
+      ] ++ internal ++ decls
+
+cleanup :: (String, String, [String], [(String, String)], Sync) -> IO ()
+cleanup (mod,_,_,_,OnDisk) = removeFile (mod++".hs")
+cleanup _ = return ()
diff --git a/testsuite/tests/ghc-api/target-contents/TargetContents.stderr b/testsuite/tests/ghc-api/target-contents/TargetContents.stderr
new file mode 100644
index 0000000000..b0a363c1e5
--- /dev/null
+++ b/testsuite/tests/ghc-api/target-contents/TargetContents.stderr
@@ -0,0 +1,45 @@
+== Error
+
+A.hs:3:5: error: Variable not in scope: z
+== CPP_D
+== CPP_M
+can't find file: A.hs
+
+== Dep_DD_AB
+== Dep_Error_DD_AB
+
+B.hs:3:5: error: Variable not in scope: z
+== Dep_Error_DD_A
+
+B.hs:3:5: error: Variable not in scope: z
+== Dep_MM_AB
+can't find file: A.hs
+can't find file: B.hs
+
+== Dep_Error_MM_AB
+can't find file: A.hs
+can't find file: B.hs
+
+== Dep_Error_MM_A
+can't find file: A.hs
+
+== Dep_DM_AB
+can't find file: B.hs
+
+== Dep_Error_DM_AB
+can't find file: B.hs
+
+== Dep_Error_DM_A
+
+A.hs:3:1: error:
+    Could not find module ‘B’
+    Use -v (or `:set -v` in ghci) to see a list of the files searched for.
+== Dep_MD_AB
+can't find file: A.hs
+
+== Dep_Error_MD_AB
+can't find file: A.hs
+
+== Dep_Error_MD_A
+can't find file: A.hs
+
diff --git a/testsuite/tests/ghc-api/target-contents/all.T b/testsuite/tests/ghc-api/target-contents/all.T
new file mode 100644
index 0000000000..94cbfce9f0
--- /dev/null
+++ b/testsuite/tests/ghc-api/target-contents/all.T
@@ -0,0 +1,4 @@
+test('TargetContents',
+     [extra_run_opts('"' + config.libdir + '"')]
+     , compile_and_run,
+     ['-package ghc'])