git.iko.soy/ghcide
on debug help sign in
ghcide/src/Development/IDE/Core/Preprocessor.hs
222 lines 9.0 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 GhcMonad
12import StringBuffer as SB
14import Data.List.Extra
15import System.FilePath
16import System.IO.Extra
17import Data.Char
18import DynFlags
19import qualified HeaderInfo as Hdr
20import Development.IDE.Types.Diagnostics
21import Development.IDE.Types.Location
22import Development.IDE.GHC.Error
23import SysTools (Option (..), runUnlit, runPp)
24import Control.Monad.Trans.Except
25import qualified GHC.LanguageExtensions as LangExt
26import Data.Maybe
27import Control.Exception.Safe (catch, throw)
28import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
29import Data.Text (Text)
30import qualified Data.Text as T
31import Outputable (showSDoc)
34-- | Given a file and some contents, apply any necessary preprocessors,
35-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
36preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
37preprocessor filename mbContents = do
38 -- Perform unlit
39 (isOnDisk, contents) <-
40 if isLiterate filename then do
41 dflags <- getDynFlags
42 newcontent <- liftIO $ runLhs dflags filename mbContents
43 return (False, newcontent)
44 else do
45 contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
46 let isOnDisk = isNothing mbContents
47 return (isOnDisk, contents)
49 -- Perform cpp
50 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
51 (isOnDisk, contents, dflags) <-
52 if not $ xopt LangExt.Cpp dflags then
53 return (isOnDisk, contents, dflags)
54 else do
55 cppLogs <- liftIO $ newIORef []
56 contents <- ExceptT
57 $ liftIO
58 $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename
59 $ if isOnDisk then Nothing else Just contents))
60 `catch`
61 ( \(e :: GhcException) -> do
62 logs <- readIORef cppLogs
63 case diagsFromCPPLogs filename (reverse logs) of
64 [] -> throw e
65 diags -> return $ Left diags
66 )
67 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
68 return (False, contents, dflags)
70 -- Perform preprocessor
71 if not $ gopt Opt_Pp dflags then
72 return (contents, dflags)
73 else do
74 contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents
75 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
76 return (contents, dflags)
77 where
78 logAction :: IORef [CPPLog] -> LogAction
79 logAction cppLogs dflags _reason severity srcSpan _style msg = do
80 let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg
81 modifyIORef cppLogs (log :)
84data CPPLog = CPPLog Severity SrcSpan Text
85 deriving (Show)
88data CPPDiag
89 = CPPDiag
90 { cdRange :: Range,
91 cdSeverity :: Maybe DiagnosticSeverity,
92 cdMessage :: [Text]
93 }
94 deriving (Show)
97diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
98diagsFromCPPLogs filename logs =
99 map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $
100 go [] logs
101 where
102 -- On errors, CPP calls logAction with a real span for the initial log and
103 -- then additional informational logs with `UnhelpfulSpan`. Collect those
104 -- informational log messages and attaches them to the initial log message.
105 go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]
106 go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc
107 go acc (CPPLog sev span@(RealSrcSpan _) msg : logs) =
108 let diag = CPPDiag (srcSpanToRange span) (toDSeverity sev) [msg]
109 in go (diag : acc) logs
110 go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =
111 go (diag {cdMessage = msg : cdMessage diag} : diags) logs
112 go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs
113 cppDiagToDiagnostic :: CPPDiag -> Diagnostic
114 cppDiagToDiagnostic d =
115 Diagnostic
116 { _range = cdRange d,
117 _severity = cdSeverity d,
118 _code = Nothing,
119 _source = Just "CPP",
120 _message = T.unlines $ cdMessage d,
121 _relatedInformation = Nothing,
122 _tags = Nothing
123 }
126isLiterate :: FilePath -> Bool
127isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
130-- | This reads the pragma information directly from the provided buffer.
131parsePragmasIntoDynFlags
132 :: GhcMonad m
133 => FilePath
134 -> SB.StringBuffer
135 -> m (Either [FileDiagnostic] DynFlags)
136parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
137 dflags0 <- getSessionDynFlags
138 let opts = Hdr.getOptions dflags0 contents fp
139 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
140 return dflags
143-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
144runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
145runLhs dflags filename contents = withTempDir $ \dir -> do
146 let fout = dir </> takeFileName filename <.> "unlit"
147 filesrc <- case contents of
148 Nothing -> return filename
149 Just cnts -> do
150 let fsrc = dir </> takeFileName filename <.> "literate"
151 withBinaryFile fsrc WriteMode $ \h ->
152 hPutStringBuffer h cnts
153 return fsrc
154 unlit filesrc fout
155 SB.hGetStringBuffer fout
156 where
157 unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
158 args filein fileout = [
159 SysTools.Option "-h"
160 , SysTools.Option (escape filename) -- name this file
161 , SysTools.FileOption "" filein -- input file
162 , SysTools.FileOption "" fileout ] -- output file
163 -- taken from ghc's DriverPipeline.hs
164 escape ('\\':cs) = '\\':'\\': escape cs
165 escape ('\"':cs) = '\\':'\"': escape cs
166 escape ('\'':cs) = '\\':'\'': escape cs
167 escape (c:cs) = c : escape cs
168 escape [] = []
170-- | Run CPP on a file
171runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
172runCpp dflags filename contents = withTempDir $ \dir -> do
173 let out = dir </> takeFileName filename <.> "out"
174 dflags <- pure $ addOptP "-D__GHCIDE__" dflags
176 case contents of
177 Nothing -> do
178 -- Happy case, file is not modified, so run CPP on it in-place
179 -- which also makes things like relative #include files work
180 -- and means location information is correct
181 doCpp dflags True filename out
182 liftIO $ SB.hGetStringBuffer out
184 Just contents -> do
185 -- Sad path, we have to create a version of the path in a temp dir
186 -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
188 -- Relative includes aren't going to work, so we fix that by adding to the include path.
189 dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
191 -- Location information is wrong, so we fix that by patching it afterwards.
192 let inp = dir </> "___GHCIDE_MAGIC___"
193 withBinaryFile inp WriteMode $ \h ->
194 hPutStringBuffer h contents
195 doCpp dflags True inp out
197 -- Fix up the filename in lines like:
198 -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
199 let tweak x
200 | Just x <- stripPrefix "# " x
201 , "___GHCIDE_MAGIC___" `isInfixOf` x
202 , let num = takeWhile (not . isSpace) x
203 -- important to use /, and never \ for paths, even on Windows, since then C escapes them
204 -- and GHC gets all confused
205 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
206 | otherwise = x
207 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
210-- | Run a preprocessor on a file
211runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
212runPreprocessor dflags filename contents = withTempDir $ \dir -> do
213 let out = dir </> takeFileName filename <.> "out"
214 inp <- case contents of
215 Nothing -> return filename
216 Just contents -> do
217 let inp = dir </> takeFileName filename <.> "hs"
218 withBinaryFile inp WriteMode $ \h ->
219 hPutStringBuffer h contents
220 return inp
221 runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out]
222 SB.hGetStringBuffer out