@@ -30,7 +30,7 @@ module Development.IDE.Core.Rules(
30
30
import Fingerprint
31
31
32
32
import Data.Binary hiding (get , put )
33
- import Data.Bifunctor ( first , second )
33
+ import Data.Tuple.Extra
34
34
import Control.Monad.Extra
35
35
import Control.Monad.Trans.Class
36
36
import Control.Monad.Trans.Maybe
@@ -42,7 +42,7 @@ import Development.IDE.Import.DependencyInformation
42
42
import Development.IDE.Import.FindImports
43
43
import Development.IDE.Core.FileExists
44
44
import Development.IDE.Core.FileStore (getFileContents )
45
- import Development.IDE.Types.Diagnostics
45
+ import Development.IDE.Types.Diagnostics as Diag
46
46
import Development.IDE.Types.Location
47
47
import Development.IDE.GHC.Compat hiding (parseModule , typecheckModule )
48
48
import Development.IDE.GHC.Util
@@ -219,19 +219,36 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
219
219
then
220
220
liftIO mainParse
221
221
else do
222
- let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock }
223
- haddockParse = do
222
+ let haddockParse = do
224
223
(_, (! diagsHaddock, _)) <-
225
- getParsedModuleDefinition hscHaddock opt comp_pkgs file contents
224
+ getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file contents
226
225
return diagsHaddock
227
226
228
227
((fingerPrint, (diags, res)), diagsHaddock) <-
229
228
-- parse twice, with and without Haddocks, concurrently
230
- -- we cannot ignore Haddock parse errors because files of
231
- -- non-interest are always parsed with Haddocks
229
+ -- we want warnings if parsing with Haddock fails
230
+ -- but if we parse with Haddock we lose annotations
232
231
liftIO $ concurrently mainParse haddockParse
233
232
234
- return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))
233
+ return (fingerPrint, (mergeParseErrorsHaddock diags diagsHaddock, res))
234
+
235
+
236
+ withOptHaddock :: HscEnv -> HscEnv
237
+ withOptHaddock hsc = hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock }
238
+
239
+
240
+ -- | Given some normal parse errors (first) and some from Haddock (second), merge them.
241
+ -- Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings.
242
+ mergeParseErrorsHaddock :: [FileDiagnostic ] -> [FileDiagnostic ] -> [FileDiagnostic ]
243
+ mergeParseErrorsHaddock normal haddock = normal ++
244
+ [ (a,b,c{_severity = Just DsWarning , _message = fixMessage $ _message c})
245
+ | (a,b,c) <- haddock, Diag. _range c `Set.notMember` locations]
246
+ where
247
+ locations = Set. fromList $ map (Diag. _range . thd3) normal
248
+
249
+ fixMessage x | " parse error " `T.isPrefixOf` x = " Haddock " <> x
250
+ | otherwise = " Haddock: " <> x
251
+
235
252
236
253
getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName ] -> NormalizedFilePath -> Maybe T. Text -> IO (Maybe ByteString , ([FileDiagnostic ], Maybe ParsedModule ))
237
254
getParsedModuleDefinition packageState opt comp_pkgs file contents = do
@@ -640,8 +657,13 @@ getModIfaceRule = define $ \GetModIface f -> do
640
657
opt <- getIdeOptions
641
658
(_, contents) <- getFileContents f
642
659
-- Embed --haddocks in the interface file
643
- hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock }
644
- (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents
660
+ (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs f contents
661
+ (diags, mb_pm) <- case mb_pm of
662
+ Just _ -> return (diags, mb_pm)
663
+ Nothing -> do
664
+ -- if parsing fails, try parsing again with Haddock turned off
665
+ (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents
666
+ return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm)
645
667
case mb_pm of
646
668
Nothing -> return (diags, Nothing )
647
669
Just pm -> do
0 commit comments