Skip to content

Commit 4aa1821

Browse files
cocreaturecocreature
authored
Merge pull request #41 from ndmitchell/add-preprocessor-module
Add preprocessor module
2 parents 8a71bfa + 963cb7f commit 4aa1821

File tree

4 files changed

+156
-118
lines changed

4 files changed

+156
-118
lines changed

‎ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -99,6 +99,7 @@ library
9999
other-modules:
100100
Development.IDE.Core.Debouncer
101101
Development.IDE.Core.Compile
102+
Development.IDE.Core.Preprocessor
102103
Development.IDE.GHC.Compat
103104
Development.IDE.GHC.CPP
104105
Development.IDE.GHC.Error

‎src/Development/IDE/Core/Compile.hs

Lines changed: 4 additions & 118 deletions
Original file line numberDiff line numberDiff line change
@@ -16,13 +16,12 @@ module Development.IDE.Core.Compile
1616
) where
1717

1818
import Development.IDE.Core.RuleTypes
19-
import Development.IDE.GHC.CPP
19+
import Development.IDE.Core.Preprocessor
2020
import Development.IDE.GHC.Error
2121
import Development.IDE.GHC.Warnings
2222
import Development.IDE.Types.Diagnostics
2323
import Development.IDE.GHC.Orphans()
2424
import Development.IDE.GHC.Util
25-
import Development.IDE.GHC.Compat
2625
import qualified GHC.LanguageExtensions.Type as GHC
2726
import Development.IDE.Types.Options
2827
import Development.IDE.Types.Location
@@ -33,14 +32,12 @@ import Lexer
3332
import ErrUtils
3433

3534
import qualified GHC
36-
import Panic
3735
import GhcMonad
3836
import GhcPlugins as GHC hiding (fst3, (<>))
3937
import qualified HeaderInfo as Hdr
4038
import MkIface
4139
import StringBuffer as SB
4240
import TidyPgm
43-
import qualified GHC.LanguageExtensions as LangExt
4441

4542
import Control.Monad.Extra
4643
import Control.Monad.Except
@@ -54,10 +51,6 @@ import Data.Maybe
5451
import Data.Tuple.Extra
5552
import qualified Data.Map.Strict as Map
5653
import 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

‎src/Development/IDE/Core/Preprocessor.hs

Lines changed: 134 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -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

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module Development.IDE.GHC.Error
88
, diagFromString
99
, diagFromStrings
1010
, diagFromGhcException
11+
, catchSrcErrors
1112

1213
-- * utilities working with spans
1314
, srcSpanToLocation
@@ -23,6 +24,9 @@ import Development.IDE.GHC.Orphans()
2324
import qualified FastString as FS
2425
import GHC
2526
import Bag
27+
import DynFlags
28+
import HscTypes
29+
import Panic
2630
import ErrUtils
2731
import SrcLoc
2832
import qualified Outputable as Out
@@ -111,6 +115,19 @@ realSpan = \case
111115
UnhelpfulSpan _ -> Nothing
112116

113117

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+
114131
diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]
115132
diagFromGhcException diagSource dflags exc = diagFromString diagSource (noSpan "<Internal>") (showGHCE dflags exc)
116133

0 commit comments

Comments
 (0)