summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDaniel Gröber <dxld@darkboxed.org>2019-05-20 11:58:55 +0200
committerBen Gamari <ben@well-typed.com>2019-06-03 23:42:11 -0400
commit0f9ec9d1ff703628fefd991f76cd6f594c1b1e87 (patch)
tree363805eb2f371be17f8990d0024da60b8a1c42ec
parent551c40243dd91a7ee106b71dc5e0877b57ba7807 (diff)
downloadhaskell-0f9ec9d1ff703628fefd991f76cd6f594c1b1e87.tar.gz
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.
-rw-r--r--compiler/main/DriverPipeline.hs48
-rw-r--r--compiler/main/GhcMake.hs29
-rw-r--r--compiler/main/HscTypes.hs6
-rw-r--r--testsuite/tests/ghc-api/target-contents/TargetContents.hs150
-rw-r--r--testsuite/tests/ghc-api/target-contents/TargetContents.stderr45
-rw-r--r--testsuite/tests/ghc-api/target-contents/all.T4
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'])