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.

3 files changed, 199 insertions, 0 deletions

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'])