@@ -16,13 +16,12 @@ module Development.IDE.Core.Compile
1616 ) where
1717
1818import Development.IDE.Core.RuleTypes
19−import Development.IDE.GHC.CPP
19+import Development.IDE.Core.Preprocessor
2020import Development.IDE.GHC.Error
2121import Development.IDE.GHC.Warnings
2222import Development.IDE.Types.Diagnostics
2323import Development.IDE.GHC.Orphans()
2424import Development.IDE.GHC.Util
25−import Development.IDE.GHC.Compat
2625import qualified GHC.LanguageExtensions.Type as GHC
2726import Development.IDE.Types.Options
2827import Development.IDE.Types.Location
@@ -33,14 +32,12 @@ import Lexer
3332import ErrUtils
3433
3534import qualified GHC
36−import Panic
3735import GhcMonad
3836import GhcPlugins as GHC hiding (fst3, (<>))
3937import qualified HeaderInfo as Hdr
4038import MkIface
4139import StringBuffer as SB
4240import TidyPgm
43−import qualified GHC.LanguageExtensions as LangExt
4441
4542import Control.Monad.Extra
4643import Control.Monad.Except
@@ -54,10 +51,6 @@ import Data.Maybe
5451import Data.Tuple.Extra
5552import qualified Data.Map.Strict as Map
5653import System.FilePath
57−import System.IO.Extra
58−import Data.Char
59−
60−import SysTools (Option (..), runUnlit)
6154
6255
6356-- | Given a string buffer, return a pre-processed @ParsedModule@.
@@ -270,69 +263,6 @@ getModSummaryFromBuffer fp contents dflags parsed = do
270263 then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
271264 else (HsSrcFile , \newExt -> stem <.> newExt)
272265
273−-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
274−runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
275−runLhs dflags filename contents = withTempDir $ \dir -> do
276− let fout = dir </> takeFileName filename <.> "unlit"
277− filesrc <- case contents of
278− Nothing -> return filename
279− Just cnts -> do
280− let fsrc = dir </> takeFileName filename <.> "literate"
281− withBinaryFile fsrc WriteMode $ \h ->
282− hPutStringBuffer h cnts
283− return fsrc
284− unlit filesrc fout
285− SB.hGetStringBuffer fout
286− where
287− unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
288− args filein fileout = [
289− SysTools.Option "-h"
290− , SysTools.Option (escape filename) -- name this file
291− , SysTools.FileOption "" filein -- input file
292− , SysTools.FileOption "" fileout ] -- output file
293− -- taken from ghc's DriverPipeline.hs
294− escape ('\\':cs) = '\\':'\\': escape cs
295− escape ('\"':cs) = '\\':'\"': escape cs
296− escape ('\'':cs) = '\\':'\'': escape cs
297− escape (c:cs) = c : escape cs
298− escape [] = []
299−
300−-- | Run CPP on a file
301−runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
302−runCpp dflags filename contents = withTempDir $ \dir -> do
303− let out = dir </> takeFileName filename <.> "out"
304− case contents of
305− Nothing -> do
306− -- Happy case, file is not modified, so run CPP on it in-place
307− -- which also makes things like relative #include files work
308− -- and means location information is correct
309− doCpp dflags True filename out
310− liftIO $ SB.hGetStringBuffer out
311−
312− Just contents -> do
313− -- Sad path, we have to create a version of the path in a temp dir
314− -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
315−
316− -- Relative includes aren't going to work, so we fix that by adding to the include path.
317− dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
318−
319− -- Location information is wrong, so we fix that by patching it afterwards.
320− let inp = dir </> "___GHCIDE_MAGIC___"
321− withBinaryFile inp WriteMode $ \h ->
322− hPutStringBuffer h contents
323− doCpp dflags True inp out
324−
325− -- Fix up the filename in lines like:
326− -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
327− let tweak x
328− | Just x <- stripPrefix "# " x
329− , "___GHCIDE_MAGIC___" `isInfixOf` x
330− , let num = takeWhile (not . isSpace) x
331− -- important to use /, and never \ for paths, even on Windows, since then C escapes them
332− -- and GHC gets all confused
333− = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
334− | otherwise = x
335− stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
336266
337267-- | Given a buffer, flags, file path and module summary, produce a
338268-- parsed module (or errors) and any parse warnings.
@@ -342,28 +272,9 @@ parseFileContents
342272 -> FilePath -- ^ the filename (for source locations)
343273 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
344274 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
345−parseFileContents preprocessor filename mbContents = do
275+parseFileContents customPreprocessor filename mbContents = do
276+ (contents, dflags) <- preprocessor filename mbContents
346277 let loc = mkRealSrcLoc (mkFastString filename) 1 1
347− contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
348− let isOnDisk = isNothing mbContents
349−
350− -- unlit content if literate Haskell ending
351− (isOnDisk, contents) <- if ".lhs" `isSuffixOf` filename
352− then do
353− dflags <- getDynFlags
354− newcontent <- liftIO $ runLhs dflags filename mbContents
355− return (False, newcontent)
356− else return (isOnDisk, contents)
357−
358− dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
359− (contents, dflags) <-
360− if not $ xopt LangExt.Cpp dflags then
361− return (contents, dflags)
362− else do
363− contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents
364− dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
365− return (contents, dflags)
366−
367278 case unP Parser.parseModule (mkPState dflags contents loc) of
368279 PFailed _ locErr msgErr ->
369280 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
@@ -388,7 +299,7 @@ parseFileContents preprocessor filename mbContents = do
388299 throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags
389300
390301 -- Ok, we got here. It's safe to continue.
391− let (errs, parsed) = preprocessor rdr_module
302+ let (errs, parsed) = customPreprocessor rdr_module
392303 unless (null errs) $ throwE $ diagFromStrings "parser" errs
393304 ms <- getModSummaryFromBuffer filename contents dflags parsed
394305 let pm =
@@ -400,28 +311,3 @@ parseFileContents preprocessor filename mbContents = do
400311 }
401312 warnings = diagFromErrMsgs "parser" dflags warns
402313 pure (warnings, pm)
403−
404−
405−-- | This reads the pragma information directly from the provided buffer.
406−parsePragmasIntoDynFlags
407− :: GhcMonad m
408− => FilePath
409− -> SB.StringBuffer
410− -> m (Either [FileDiagnostic] DynFlags)
411−parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
412− dflags0 <- getSessionDynFlags
413− let opts = Hdr.getOptions dflags0 contents fp
414− (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
415− return dflags
416−
417−-- | Run something in a Ghc monad and catch the errors (SourceErrors and
418−-- compiler-internal exceptions like Panic or InstallationError).
419−catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
420−catchSrcErrors fromWhere ghcM = do
421− dflags <- getDynFlags
422− handleGhcException (ghcExceptionToDiagnostics dflags) $
423− handleSourceError (sourceErrorToDiagnostics dflags) $
424− Right <$> ghcM
425− where
426− ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags
427− sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages