@@ -18,11 +18,17 @@ import Data.Char
1818import DynFlags
1919import qualified HeaderInfo as Hdr
2020import Development.IDE.Types.Diagnostics
21+import Development.IDE.Types.Location
2122import Development.IDE.GHC.Error
2223import SysTools (Option (..), runUnlit, runPp)
2324import Control.Monad.Trans.Except
2425import qualified GHC.LanguageExtensions as LangExt
2526import Data.Maybe
27+import Control.Exception.Safe (catch, throw)
28+import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
29+import Data.Text (Text)
30+import qualified Data.Text as T
31+import Outputable (showSDoc)
2632
2733
2834-- | Given a file and some contents, apply any necessary preprocessors,
@@ -46,7 +52,18 @@ preprocessor filename mbContents = do
4652 if not $ xopt LangExt.Cpp dflags then
4753 return (isOnDisk, contents, dflags)
4854 else do
49− contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents
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+ )
5067 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
5168 return (False, contents, dflags)
5269
@@ -57,6 +74,52 @@ preprocessor filename mbContents = do
5774 contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents
5875 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
5976 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 :)
82+
83+
84+data CPPLog = CPPLog Severity SrcSpan Text
85+ deriving (Show)
86+
87+
88+data CPPDiag
89+ = CPPDiag
90+ { cdRange :: Range,
91+ cdSeverity :: Maybe DiagnosticSeverity,
92+ cdMessage :: [Text]
93+ }
94+ deriving (Show)
95+
96+
97+diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
98+diagsFromCPPLogs 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+ }
60123
61124
62125isLiterate :: FilePath -> Bool