[Git][ghc/ghc][master] 3 commits: Add hPutStringBuffer utility
Marge Bot
gitlab at gitlab.haskell.org
Wed May 29 14:41:07 UTC 2019
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
cc0d05a7 by Daniel Gröber at 2019-05-29T14:41:02Z
Add hPutStringBuffer utility
- - - - -
5b90e0a1 by Daniel Gröber at 2019-05-29T14:41:02Z
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.
- - - - -
fb26d467 by Daniel Gröber at 2019-05-29T14:41:02Z
downsweep: Allow TargetFile not to exist when a buffer is given
Currently 'getRootSummary' will fail with an exception if a 'TargetFile' is
given but it does not exist even if an input buffer is passed along for
this target.
In this case it is not necessary for the file to exist since the buffer
will be used as input for the compilation pipeline instead of the file
anyways.
- - - - -
7 changed files:
- compiler/main/DriverPipeline.hs
- compiler/main/GhcMake.hs
- compiler/main/HscTypes.hs
- compiler/utils/StringBuffer.hs
- + testsuite/tests/ghc-api/target-contents/TargetContents.hs
- + testsuite/tests/ghc-api/target-contents/TargetContents.stderr
- + testsuite/tests/ghc-api/target-contents/all.T
Changes:
=====================================
compiler/main/DriverPipeline.hs
=====================================
@@ -51,7 +51,7 @@ import ErrUtils
import DynFlags
import Panic
import Util
-import StringBuffer ( hGetStringBuffer )
+import StringBuffer ( StringBuffer, hGetStringBuffer, hPutStringBuffer )
import BasicTypes ( SuccessFlag(..) )
import Maybes ( expectJust )
import SrcLoc
@@ -86,11 +86,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.
@@ -185,6 +188,7 @@ compileOne' m_tc_result mHscMessage
-- handled properly
_ <- runPipeline StopLn hsc_env
(output_fn,
+ Nothing,
Just (HscOut src_flavour
mod_name HscUpdateSig))
(Just basename)
@@ -222,6 +226,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
@@ -319,7 +324,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-}
[]
@@ -341,7 +346,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)
@@ -528,7 +533,9 @@ compileFile hsc_env stop_phase (src, mb_phase) = do
| otherwise = Persistent
( _, 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
@@ -561,13 +568,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
@@ -619,8 +628,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
@@ -634,7 +657,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
=====================================
compiler/main/GhcMake.hs
=====================================
@@ -1978,7 +1978,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
getRootSummary :: Target -> IO (Either ErrMsg ModSummary)
getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
= do exists <- liftIO $ doesFileExist file
- if exists
+ if exists || isJust maybe_buf
then Right `fmap` summariseFile hsc_env old_summaries file mb_phase
obj_allowed maybe_buf
else return $ Left $ mkPlainErrMsg dflags noSrcSpan $
@@ -2475,35 +2475,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
=====================================
compiler/main/HscTypes.hs
=====================================
@@ -512,7 +512,16 @@ 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.
+ --
+ -- If a corresponding source file does not exist on disk this will
+ -- result in a 'SourceError' exception if @targetId = TargetModule _@
+ -- is used. However together with @targetId = TargetFile _@ GHC will
+ -- not complain about the file missing.
}
data TargetId
=====================================
compiler/utils/StringBuffer.hs
=====================================
@@ -19,6 +19,7 @@ module StringBuffer
-- * Creation\/destruction
hGetStringBuffer,
hGetStringBufferBlock,
+ hPutStringBuffer,
appendStringBuffers,
stringToStringBuffer,
@@ -121,6 +122,11 @@ hGetStringBufferBlock handle wanted
then ioError (userError $ "short read of file: "++show(r,size,size_i,handle))
else newUTF8StringBuffer buf ptr size
+hPutStringBuffer :: Handle -> StringBuffer -> IO ()
+hPutStringBuffer hdl (StringBuffer buf len cur)
+ = do withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
+ hPutBuf hdl ptr len
+
-- | Skip the byte-order mark if there is one (see #1744 and #6016),
-- and return the new position of the handle in bytes.
--
=====================================
testsuite/tests/ghc-api/target-contents/TargetContents.hs
=====================================
@@ -0,0 +1,149 @@
+{-# 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 in targetContents.
+
+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 ()
=====================================
testsuite/tests/ghc-api/target-contents/TargetContents.stderr
=====================================
@@ -0,0 +1,37 @@
+== Error
+
+A.hs:3:5: error: Variable not in scope: z
+== CPP_D
+== CPP_M
+== 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
+== Dep_Error_MM_AB
+
+B.hs:3:5: error: Variable not in scope: z
+== Dep_Error_MM_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_DM_AB
+== Dep_Error_DM_AB
+
+B.hs:3:5: error: Variable not in scope: z
+== 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
+== Dep_Error_MD_AB
+
+B.hs:3:5: error: Variable not in scope: z
+== Dep_Error_MD_A
+
+B.hs:3:5: error: Variable not in scope: z
=====================================
testsuite/tests/ghc-api/target-contents/all.T
=====================================
@@ -0,0 +1,4 @@
+test('TargetContents',
+ [extra_run_opts('"' + config.libdir + '"')]
+ , compile_and_run,
+ ['-package ghc'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/9062b62555ced7403cb97f5fd55cffdd57fbf717...fb26d46754564bfacda98618d86d3ee4eda1fcf2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/9062b62555ced7403cb97f5fd55cffdd57fbf717...fb26d46754564bfacda98618d86d3ee4eda1fcf2
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190529/648dbd85/attachment-0001.html>
More information about the ghc-commits
mailing list