#573, make haddock errors warnings with the word Haddock in front

src/Development/IDE/Core/Rules.hs

@@ -29,7 +29,7 @@ module Development.IDE.Core.Rules(
 import Fingerprint
 
 import Data.Binary hiding (get, put)
-import Data.Bifunctor (first, second)
+import Data.Tuple.Extra
 import Control.Monad.Extra
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
@@ -41,7 +41,7 @@ import Development.IDE.Import.DependencyInformation
 import Development.IDE.Import.FindImports
 import           Development.IDE.Core.FileExists
 import           Development.IDE.Core.FileStore        (getFileContents)
-import           Development.IDE.Types.Diagnostics
+import           Development.IDE.Types.Diagnostics as Diag
 import Development.IDE.Types.Location
 import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
 import Development.IDE.GHC.Util
@@ -208,19 +208,36 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
         then
             liftIO mainParse
         else do
-            let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}
-                haddockParse = do
+            let haddockParse = do
                     (_, (!diagsHaddock, _)) <-
-                        getParsedModuleDefinition hscHaddock opt comp_pkgs file contents
+                        getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file contents
                     return diagsHaddock
 
             ((fingerPrint, (diags, res)), diagsHaddock) <-
                 -- parse twice, with and without Haddocks, concurrently
-                -- we cannot ignore Haddock parse errors because files of
-                -- non-interest are always parsed with Haddocks
+                -- we want warnings if parsing with Haddock fails
+                -- but if we parse with Haddock we lose annotations
                 liftIO $ concurrently mainParse haddockParse
 
-            return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))
+            return (fingerPrint, (mergeParseErrorsHaddock diags diagsHaddock, res))
+
+
+withOptHaddock :: HscEnv -> HscEnv
+withOptHaddock hsc = hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}
+
+
+-- | Given some normal parse errors (first) and some from Haddock (second), merge them.
+--   Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings.
+mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
+mergeParseErrorsHaddock normal haddock = normal ++
+    [ (a,b,c{_severity = Just DsWarning, _message = fixMessage $ _message c})
+    | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations]
+  where
+    locations = Set.fromList $ map (Diag._range . thd3) normal
+
+    fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x
+                 | otherwise = "Haddock: " <> x
+
 
 getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
 getParsedModuleDefinition packageState opt comp_pkgs file contents = do
@@ -631,8 +648,13 @@ getModIfaceRule = define $ \GetModIface f -> do
             opt <- getIdeOptions
             (_, contents) <- getFileContents f
             -- Embed --haddocks in the interface file
-            hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}
-            (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents
+            (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs f contents
+            (diags, mb_pm) <- case mb_pm of
+                Just _ -> return (diags, mb_pm)
+                Nothing -> do
+                    -- if parsing fails, try parsing again with Haddock turned off
+                    (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents
+                    return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm)
             case mb_pm of
                 Nothing -> return (diags, Nothing)
                 Just pm -> do

src/Development/IDE/GHC/Error.hs

@@ -9,7 +9,6 @@ module Development.IDE.GHC.Error
   , diagFromStrings
   , diagFromGhcException
   , catchSrcErrors
-  , mergeDiagnostics
 
   -- * utilities working with spans
   , srcSpanToLocation
@@ -64,26 +63,6 @@ diagFromErrMsg diagSource dflags e =
 diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
 diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
 
--- | Merges two sorted lists of diagnostics, removing duplicates.
---   Assumes all the diagnostics are for the same file.
-mergeDiagnostics :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
-mergeDiagnostics aa [] = aa
-mergeDiagnostics [] bb = bb
-mergeDiagnostics (a@(_,_,ad@Diagnostic{_range = ar}):aa) (b@(_,_,bd@Diagnostic{_range=br}):bb)
-  | ar < br
-  = a : mergeDiagnostics aa (b:bb)
-  | br < ar
-  = b : mergeDiagnostics (a:aa) bb
-  | _severity ad == _severity bd
-  && _source ad == _source bd
-  && _message ad == _message bd
-  && _code ad == _code bd
-  && _relatedInformation ad == _relatedInformation bd
-  && _tags ad == _tags bd
-  = a : mergeDiagnostics aa bb
-  | otherwise
-  = a : b : mergeDiagnostics aa bb
-
 -- | Convert a GHC SrcSpan to a DAML compiler Range
 srcSpanToRange :: SrcSpan -> Range
 srcSpanToRange (UnhelpfulSpan _)  = noRange

test/exe/Main.hs

@@ -433,7 +433,7 @@ diagnosticTests = testGroup "diagnostics"
       _ <- createDoc "Foo.hs" "haskell" fooContent
       expectDiagnostics
         [ ( "Foo.hs"
-          , [(DsError, (2, 8), "Parse error on input")
+          , [(DsWarning, (2, 8), "Haddock parse error on input")
             ]
           )
         ]