git.iko.soy/ghcide
on master help sign in
Merge pull request #41 from ndmitchell/add-preprocessor-module
4aa1821Moritz Kiefer
ghcide.cabal+1
compare with master
unifiedsplit
@@ -99,6 +99,7 @@ library
99 other-modules:
99 other-modules:
100 Development.IDE.Core.Debouncer
100 Development.IDE.Core.Debouncer
101 Development.IDE.Core.Compile
101 Development.IDE.Core.Compile
102+ Development.IDE.Core.Preprocessor
102 Development.IDE.GHC.Compat
103 Development.IDE.GHC.Compat
103 Development.IDE.GHC.CPP
104 Development.IDE.GHC.CPP
104 Development.IDE.GHC.Error
105 Development.IDE.GHC.Error
src/Development/IDE/Core/Compile.hs+4−118
@@ -16,13 +16,12 @@ module Development.IDE.Core.Compile
16 ) where
16 ) where
17
17
18import Development.IDE.Core.RuleTypes
18import Development.IDE.Core.RuleTypes
19−import Development.IDE.GHC.CPP
19+import Development.IDE.Core.Preprocessor
20import Development.IDE.GHC.Error
20import Development.IDE.GHC.Error
21import Development.IDE.GHC.Warnings
21import Development.IDE.GHC.Warnings
22import Development.IDE.Types.Diagnostics
22import Development.IDE.Types.Diagnostics
23import Development.IDE.GHC.Orphans()
23import Development.IDE.GHC.Orphans()
24import Development.IDE.GHC.Util
24import Development.IDE.GHC.Util
25−import Development.IDE.GHC.Compat
26import qualified GHC.LanguageExtensions.Type as GHC
25import qualified GHC.LanguageExtensions.Type as GHC
27import Development.IDE.Types.Options
26import Development.IDE.Types.Options
28import Development.IDE.Types.Location
27import Development.IDE.Types.Location
@@ -33,14 +32,12 @@ import Lexer
33import ErrUtils
32import ErrUtils
34
33
35import qualified GHC
34import qualified GHC
36−import Panic
37import GhcMonad
35import GhcMonad
38import GhcPlugins as GHC hiding (fst3, (<>))
36import GhcPlugins as GHC hiding (fst3, (<>))
39import qualified HeaderInfo as Hdr
37import qualified HeaderInfo as Hdr
40import MkIface
38import MkIface
41import StringBuffer as SB
39import StringBuffer as SB
42import TidyPgm
40import TidyPgm
43−import qualified GHC.LanguageExtensions as LangExt
44
41
45import Control.Monad.Extra
42import Control.Monad.Extra
46import Control.Monad.Except
43import Control.Monad.Except
@@ -54,10 +51,6 @@ import Data.Maybe
54import Data.Tuple.Extra
51import Data.Tuple.Extra
55import qualified Data.Map.Strict as Map
52import qualified Data.Map.Strict as Map
56import System.FilePath
53import System.FilePath
57−import System.IO.Extra
58−import Data.Char
59−
60−import SysTools (Option (..), runUnlit)
61
54
62
55
63-- | Given a string buffer, return a pre-processed @ParsedModule@.
56-- | Given a string buffer, return a pre-processed @ParsedModule@.
@@ -270,69 +263,6 @@ getModSummaryFromBuffer fp contents dflags parsed = do
270 then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
263 then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
271 else (HsSrcFile , \newExt -> stem <.> newExt)
264 else (HsSrcFile , \newExt -> stem <.> newExt)
272
265
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
336
266
337-- | Given a buffer, flags, file path and module summary, produce a
267-- | Given a buffer, flags, file path and module summary, produce a
338-- parsed module (or errors) and any parse warnings.
268-- parsed module (or errors) and any parse warnings.
@@ -342,28 +272,9 @@ parseFileContents
342 -> FilePath -- ^ the filename (for source locations)
272 -> FilePath -- ^ the filename (for source locations)
343 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
273 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
344 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
274 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
345−parseFileContents preprocessor filename mbContents = do
275+parseFileContents customPreprocessor filename mbContents = do
276+ (contents, dflags) <- preprocessor filename mbContents
346 let loc = mkRealSrcLoc (mkFastString filename) 1 1
277 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−
367 case unP Parser.parseModule (mkPState dflags contents loc) of
278 case unP Parser.parseModule (mkPState dflags contents loc) of
368 PFailed _ locErr msgErr ->
279 PFailed _ locErr msgErr ->
369 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
280 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
@@ -388,7 +299,7 @@ parseFileContents preprocessor filename mbContents = do
388 throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags
299 throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags
389
300
390 -- Ok, we got here. It's safe to continue.
301 -- Ok, we got here. It's safe to continue.
391− let (errs, parsed) = preprocessor rdr_module
302+ let (errs, parsed) = customPreprocessor rdr_module
392 unless (null errs) $ throwE $ diagFromStrings "parser" errs
303 unless (null errs) $ throwE $ diagFromStrings "parser" errs
393 ms <- getModSummaryFromBuffer filename contents dflags parsed
304 ms <- getModSummaryFromBuffer filename contents dflags parsed
394 let pm =
305 let pm =
@@ -400,28 +311,3 @@ parseFileContents preprocessor filename mbContents = do
400 }
311 }
401 warnings = diagFromErrMsgs "parser" dflags warns
312 warnings = diagFromErrMsgs "parser" dflags warns
402 pure (warnings, pm)
313 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
src/Development/IDE/Core/Preprocessor.hsnew file+134
@@ -0,0 +1,134 @@
1+-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2+-- SPDX-License-Identifier: Apache-2.0
3+
4+module Development.IDE.Core.Preprocessor
5+ ( preprocessor
6+ ) where
7+
8+import Development.IDE.GHC.CPP
9+import Development.IDE.GHC.Orphans()
10+import Development.IDE.GHC.Compat
11+import GHC
12+import GhcMonad
13+import StringBuffer as SB
14+
15+import Data.List.Extra
16+import System.FilePath
17+import System.IO.Extra
18+import Data.Char
19+import DynFlags
20+import qualified HeaderInfo as Hdr
21+import Development.IDE.Types.Diagnostics
22+import Development.IDE.GHC.Error
23+import SysTools (Option (..), runUnlit)
24+import Control.Monad.Trans.Except
25+import qualified GHC.LanguageExtensions as LangExt
26+import Data.Maybe
27+
28+
29+-- | Given a file and some contents, apply any necessary preprocessors,
30+-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
31+preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
32+preprocessor filename mbContents = do
33+ -- Perform unlit
34+ (isOnDisk, contents) <-
35+ if isLiterate filename then do
36+ dflags <- getDynFlags
37+ newcontent <- liftIO $ runLhs dflags filename mbContents
38+ return (False, newcontent)
39+ else do
40+ contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
41+ let isOnDisk = isNothing mbContents
42+ return (isOnDisk, contents)
43+
44+ -- Perform cpp
45+ dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
46+ if not $ xopt LangExt.Cpp dflags then
47+ return (contents, dflags)
48+ else do
49+ contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents
50+ dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
51+ return (contents, dflags)
52+
53+
54+isLiterate :: FilePath -> Bool
55+isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
56+
57+
58+-- | This reads the pragma information directly from the provided buffer.
59+parsePragmasIntoDynFlags
60+ :: GhcMonad m
61+ => FilePath
62+ -> SB.StringBuffer
63+ -> m (Either [FileDiagnostic] DynFlags)
64+parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
65+ dflags0 <- getSessionDynFlags
66+ let opts = Hdr.getOptions dflags0 contents fp
67+ (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
68+ return dflags
69+
70+
71+-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
72+runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
73+runLhs dflags filename contents = withTempDir $ \dir -> do
74+ let fout = dir </> takeFileName filename <.> "unlit"
75+ filesrc <- case contents of
76+ Nothing -> return filename
77+ Just cnts -> do
78+ let fsrc = dir </> takeFileName filename <.> "literate"
79+ withBinaryFile fsrc WriteMode $ \h ->
80+ hPutStringBuffer h cnts
81+ return fsrc
82+ unlit filesrc fout
83+ SB.hGetStringBuffer fout
84+ where
85+ unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
86+ args filein fileout = [
87+ SysTools.Option "-h"
88+ , SysTools.Option (escape filename) -- name this file
89+ , SysTools.FileOption "" filein -- input file
90+ , SysTools.FileOption "" fileout ] -- output file
91+ -- taken from ghc's DriverPipeline.hs
92+ escape ('\\':cs) = '\\':'\\': escape cs
93+ escape ('\"':cs) = '\\':'\"': escape cs
94+ escape ('\'':cs) = '\\':'\'': escape cs
95+ escape (c:cs) = c : escape cs
96+ escape [] = []
97+
98+
99+-- | Run CPP on a file
100+runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
101+runCpp dflags filename contents = withTempDir $ \dir -> do
102+ let out = dir </> takeFileName filename <.> "out"
103+ case contents of
104+ Nothing -> do
105+ -- Happy case, file is not modified, so run CPP on it in-place
106+ -- which also makes things like relative #include files work
107+ -- and means location information is correct
108+ doCpp dflags True filename out
109+ liftIO $ SB.hGetStringBuffer out
110+
111+ Just contents -> do
112+ -- Sad path, we have to create a version of the path in a temp dir
113+ -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
114+
115+ -- Relative includes aren't going to work, so we fix that by adding to the include path.
116+ dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
117+
118+ -- Location information is wrong, so we fix that by patching it afterwards.
119+ let inp = dir </> "___GHCIDE_MAGIC___"
120+ withBinaryFile inp WriteMode $ \h ->
121+ hPutStringBuffer h contents
122+ doCpp dflags True inp out
123+
124+ -- Fix up the filename in lines like:
125+ -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
126+ let tweak x
127+ | Just x <- stripPrefix "# " x
128+ , "___GHCIDE_MAGIC___" `isInfixOf` x
129+ , let num = takeWhile (not . isSpace) x
130+ -- important to use /, and never \ for paths, even on Windows, since then C escapes them
131+ -- and GHC gets all confused
132+ = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
133+ | otherwise = x
134+ stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
src/Development/IDE/GHC/Error.hs+17
@@ -8,6 +8,7 @@ module Development.IDE.GHC.Error
8 , diagFromString
8 , diagFromString
9 , diagFromStrings
9 , diagFromStrings
10 , diagFromGhcException
10 , diagFromGhcException
11+ , catchSrcErrors
11
12
12 -- * utilities working with spans
13 -- * utilities working with spans
13 , srcSpanToLocation
14 , srcSpanToLocation
@@ -23,6 +24,9 @@ import Development.IDE.GHC.Orphans()
23import qualified FastString as FS
24import qualified FastString as FS
24import GHC
25import GHC
25import Bag
26import Bag
27+import DynFlags
28+import HscTypes
29+import Panic
26import ErrUtils
30import ErrUtils
27import SrcLoc
31import SrcLoc
28import qualified Outputable as Out
32import qualified Outputable as Out
@@ -111,6 +115,19 @@ realSpan = \case
111 UnhelpfulSpan _ -> Nothing
115 UnhelpfulSpan _ -> Nothing
112
116
113
117
118+-- | Run something in a Ghc monad and catch the errors (SourceErrors and
119+-- compiler-internal exceptions like Panic or InstallationError).
120+catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
121+catchSrcErrors fromWhere ghcM = do
122+ dflags <- getDynFlags
123+ handleGhcException (ghcExceptionToDiagnostics dflags) $
124+ handleSourceError (sourceErrorToDiagnostics dflags) $
125+ Right <$> ghcM
126+ where
127+ ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags
128+ sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages
129+
130+
114diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]
131diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]
115diagFromGhcException diagSource dflags exc = diagFromString diagSource (noSpan "<Internal>") (showGHCE dflags exc)
132diagFromGhcException diagSource dflags exc = diagFromString diagSource (noSpan "<Internal>") (showGHCE dflags exc)
116
133