Allow preprocessors to emit warnings (#176)

* Allow to emit warnings in preprocessor

* preprocessor result type IdePreprocessedSource

src/Development/IDE/Core/Compile.hs

@@ -309,7 +309,7 @@ getModSummaryFromBuffer fp contents dflags parsed = do
 -- parsed module (or errors) and any parse warnings.
 parseFileContents
        :: GhcMonad m
-       => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
+       => (GHC.ParsedSource -> IdePreprocessedSource)
        -> FilePath  -- ^ the filename (for source locations)
        -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
        -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
@@ -340,8 +340,9 @@ parseFileContents customPreprocessor filename mbContents = do
                  throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags
 
                -- Ok, we got here. It's safe to continue.
-               let (errs, parsed) = customPreprocessor rdr_module
-               unless (null errs) $ throwE $ diagFromStrings "parser" errs
+               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
+               unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
+               let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
                ms <- getModSummaryFromBuffer filename contents dflags parsed
                let pm =
                      ParsedModule {
@@ -351,4 +352,4 @@ parseFileContents customPreprocessor filename mbContents = do
                        , pm_annotations = hpm_annotations
                       }
                    warnings = diagFromErrMsgs "parser" dflags warns
-               pure (warnings, pm)
+               pure (warnings ++ preproc_warnings, pm)

src/Development/IDE/GHC/Error.hs

@@ -90,12 +90,12 @@ toDSeverity SevFatal       = Just DsError
 
 -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given
 --   (optional) locations and message strings.
-diagFromStrings :: T.Text -> [(SrcSpan, String)] -> [FileDiagnostic]
-diagFromStrings diagSource = concatMap (uncurry (diagFromString diagSource))
+diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic]
+diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev))
 
 -- | Produce a GHC-style error from a source span and a message.
-diagFromString :: T.Text -> SrcSpan -> String -> [FileDiagnostic]
-diagFromString diagSource sp x = [diagFromText diagSource DsError sp $ T.pack x]
+diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic]
+diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x]
 
 
 -- | Produces an "unhelpful" source span with the given string.
@@ -129,7 +129,7 @@ catchSrcErrors fromWhere ghcM = do
 
 
 diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]
-diagFromGhcException diagSource dflags exc = diagFromString diagSource (noSpan "<Internal>") (showGHCE dflags exc)
+diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "<Internal>") (showGHCE dflags exc)
 
 showGHCE :: DynFlags -> GhcException -> String
 showGHCE dflags exc = case exc of

src/Development/IDE/Import/FindImports.hs

@@ -95,7 +95,7 @@ notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [FileDiagnost
 notFoundErr dfs modName reason =
   mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason
   where
-    mkError' = diagFromString "not found" (getLoc modName)
+    mkError' = diagFromString "not found" DsError (getLoc modName)
     modName0 = unLoc modName
     ppr' = showSDoc dfs
     -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer.

src/Development/IDE/Types/Options.hs

@@ -6,6 +6,7 @@
 -- | Options
 module Development.IDE.Types.Options
   ( IdeOptions(..)
+  , IdePreprocessedSource(..)
   , IdeReportProgress(..)
   , IdeDefer(..)
   , clientSupportsProgress
@@ -21,9 +22,9 @@ import           GhcPlugins                     as GHC hiding (fst3, (<>))
 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
 
 data IdeOptions = IdeOptions
-  { optPreprocessor :: GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource)
+  { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
     -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
-    --   along with a new parse tree.
+    --   and a list of errors, along with a new parse tree.
   , optGhcSession :: IO (FilePath -> Action HscEnvEq)
     -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
     --   The 'IO' will be called once, then the resulting function will be applied once per file.
@@ -53,6 +54,15 @@ data IdeOptions = IdeOptions
     --   the presence of type errors, holes or unbound variables.
   }
 
+data IdePreprocessedSource = IdePreprocessedSource
+  { preprocWarnings :: [(GHC.SrcSpan, String)]
+    -- ^ Warnings emitted by the preprocessor.
+  , preprocErrors :: [(GHC.SrcSpan, String)]
+    -- ^ Errors emitted by the preprocessor.
+  , preprocSource :: GHC.ParsedSource
+    -- ^ New parse tree emitted by the preprocessor.
+  }
+
 newtype IdeReportProgress = IdeReportProgress Bool
 newtype IdeDefer          = IdeDefer          Bool
 
@@ -62,7 +72,7 @@ clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $
 
 defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions
 defaultIdeOptions session = IdeOptions
-    {optPreprocessor = (,) []
+    {optPreprocessor = IdePreprocessedSource [] []
     ,optGhcSession = session
     ,optExtensions = ["hs", "lhs"]
     ,optPkgLocationOpts = defaultIdePkgLocationOptions