git.iko.soy/ghcide
on package-debug help sign in
ghcide/src/Development/IDE/Core/Preprocessor.hs
134 lines 5.4 kB history raw
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4module Development.IDE.Core.Preprocessor
5 ( preprocessor
6 ) where
8import Development.IDE.GHC.CPP
9import Development.IDE.GHC.Orphans()
10import Development.IDE.GHC.Compat
11import GHC
12import GhcMonad
13import StringBuffer as SB
15import Data.List.Extra
16import System.FilePath
17import System.IO.Extra
18import Data.Char
19import DynFlags
20import qualified HeaderInfo as Hdr
21import Development.IDE.Types.Diagnostics
22import Development.IDE.GHC.Error
23import SysTools (Option (..), runUnlit)
24import Control.Monad.Trans.Except
25import qualified GHC.LanguageExtensions as LangExt
26import Data.Maybe
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.
31preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
32preprocessor 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)
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)
54isLiterate :: FilePath -> Bool
55isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
58-- | This reads the pragma information directly from the provided buffer.
59parsePragmasIntoDynFlags
60 :: GhcMonad m
61 => FilePath
62 -> SB.StringBuffer
63 -> m (Either [FileDiagnostic] DynFlags)
64parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
65 dflags0 <- getSessionDynFlags
66 let opts = Hdr.getOptions dflags0 contents fp
67 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
68 return dflags
71-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
72runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
73runLhs 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 [] = []
99-- | Run CPP on a file
100runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
101runCpp 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
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)
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
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
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