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