git.iko.soy/ghcide
on debugging help sign in
ghcide/src/Development/IDE/Core/Preprocessor.hs
220 lines 8.9 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 }
125isLiterate :: FilePath -> Bool
126isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
129-- | This reads the pragma information directly from the provided buffer.
130parsePragmasIntoDynFlags
131 :: GhcMonad m
132 => FilePath
133 -> SB.StringBuffer
134 -> m (Either [FileDiagnostic] DynFlags)
135parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
136 dflags0 <- getSessionDynFlags
137 let opts = Hdr.getOptions dflags0 contents fp
138 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
139 return dflags
142-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
143runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
144runLhs dflags filename contents = withTempDir $ \dir -> do
145 let fout = dir </> takeFileName filename <.> "unlit"
146 filesrc <- case contents of
147 Nothing -> return filename
148 Just cnts -> do
149 let fsrc = dir </> takeFileName filename <.> "literate"
150 withBinaryFile fsrc WriteMode $ \h ->
151 hPutStringBuffer h cnts
152 return fsrc
153 unlit filesrc fout
154 SB.hGetStringBuffer fout
155 where
156 unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
157 args filein fileout = [
158 SysTools.Option "-h"
159 , SysTools.Option (escape filename) -- name this file
160 , SysTools.FileOption "" filein -- input file
161 , SysTools.FileOption "" fileout ] -- output file
162 -- taken from ghc's DriverPipeline.hs
163 escape ('\\':cs) = '\\':'\\': escape cs
164 escape ('\"':cs) = '\\':'\"': escape cs
165 escape ('\'':cs) = '\\':'\'': escape cs
166 escape (c:cs) = c : escape cs
167 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 case contents of
175 Nothing -> do
176 -- Happy case, file is not modified, so run CPP on it in-place
177 -- which also makes things like relative #include files work
178 -- and means location information is correct
179 doCpp dflags True filename out
180 liftIO $ SB.hGetStringBuffer out
182 Just contents -> do
183 -- Sad path, we have to create a version of the path in a temp dir
184 -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
186 -- Relative includes aren't going to work, so we fix that by adding to the include path.
187 dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
189 -- Location information is wrong, so we fix that by patching it afterwards.
190 let inp = dir </> "___GHCIDE_MAGIC___"
191 withBinaryFile inp WriteMode $ \h ->
192 hPutStringBuffer h contents
193 doCpp dflags True inp out
195 -- Fix up the filename in lines like:
196 -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
197 let tweak x
198 | Just x <- stripPrefix "# " x
199 , "___GHCIDE_MAGIC___" `isInfixOf` x
200 , let num = takeWhile (not . isSpace) x
201 -- important to use /, and never \ for paths, even on Windows, since then C escapes them
202 -- and GHC gets all confused
203 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
204 | otherwise = x
205 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
208-- | Run a preprocessor on a file
209runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
210runPreprocessor dflags filename contents = withTempDir $ \dir -> do
211 let out = dir </> takeFileName filename <.> "out"
212 inp <- case contents of
213 Nothing -> return filename
214 Just contents -> do
215 let inp = dir </> takeFileName filename <.> "hs"
216 withBinaryFile inp WriteMode $ \h ->
217 hPutStringBuffer h contents
218 return inp
219 runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out]
220 SB.hGetStringBuffer out