Skip to content

Commit 154e57f

Browse files
authored
#573, make haddock errors warnings with the word Haddock in front (#608)
* #573, make haddock errors warnings with the word Haddock in front * Update Rules.hs * Deal with Haddock failures in getModIfaceRule
1 parent 08e87ad commit 154e57f

File tree

3 files changed

+33
-32
lines changed

3 files changed

+33
-32
lines changed

src/Development/IDE/Core/Rules.hs

Lines changed: 32 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ module Development.IDE.Core.Rules(
3030
import Fingerprint
3131

3232
import Data.Binary hiding (get, put)
33-
import Data.Bifunctor (first, second)
33+
import Data.Tuple.Extra
3434
import Control.Monad.Extra
3535
import Control.Monad.Trans.Class
3636
import Control.Monad.Trans.Maybe
@@ -42,7 +42,7 @@ import Development.IDE.Import.DependencyInformation
4242
import Development.IDE.Import.FindImports
4343
import Development.IDE.Core.FileExists
4444
import Development.IDE.Core.FileStore (getFileContents)
45-
import Development.IDE.Types.Diagnostics
45+
import Development.IDE.Types.Diagnostics as Diag
4646
import Development.IDE.Types.Location
4747
import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
4848
import Development.IDE.GHC.Util
@@ -219,19 +219,36 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
219219
then
220220
liftIO mainParse
221221
else do
222-
let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}
223-
haddockParse = do
222+
let haddockParse = do
224223
(_, (!diagsHaddock, _)) <-
225-
getParsedModuleDefinition hscHaddock opt comp_pkgs file contents
224+
getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file contents
226225
return diagsHaddock
227226

228227
((fingerPrint, (diags, res)), diagsHaddock) <-
229228
-- 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
232231
liftIO $ concurrently mainParse haddockParse
233232

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+
235252

236253
getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
237254
getParsedModuleDefinition packageState opt comp_pkgs file contents = do
@@ -640,8 +657,13 @@ getModIfaceRule = define $ \GetModIface f -> do
640657
opt <- getIdeOptions
641658
(_, contents) <- getFileContents f
642659
-- 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)
645667
case mb_pm of
646668
Nothing -> return (diags, Nothing)
647669
Just pm -> do

src/Development/IDE/GHC/Error.hs

Lines changed: 0 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,6 @@ module Development.IDE.GHC.Error
99
, diagFromStrings
1010
, diagFromGhcException
1111
, catchSrcErrors
12-
, mergeDiagnostics
1312

1413
-- * utilities working with spans
1514
, srcSpanToLocation
@@ -64,26 +63,6 @@ diagFromErrMsg diagSource dflags e =
6463
diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
6564
diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
6665

67-
-- | Merges two sorted lists of diagnostics, removing duplicates.
68-
-- Assumes all the diagnostics are for the same file.
69-
mergeDiagnostics :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
70-
mergeDiagnostics aa [] = aa
71-
mergeDiagnostics [] bb = bb
72-
mergeDiagnostics (a@(_,_,ad@Diagnostic{_range = ar}):aa) (b@(_,_,bd@Diagnostic{_range=br}):bb)
73-
| ar < br
74-
= a : mergeDiagnostics aa (b:bb)
75-
| br < ar
76-
= b : mergeDiagnostics (a:aa) bb
77-
| _severity ad == _severity bd
78-
&& _source ad == _source bd
79-
&& _message ad == _message bd
80-
&& _code ad == _code bd
81-
&& _relatedInformation ad == _relatedInformation bd
82-
&& _tags ad == _tags bd
83-
= a : mergeDiagnostics aa bb
84-
| otherwise
85-
= a : b : mergeDiagnostics aa bb
86-
8766
-- | Convert a GHC SrcSpan to a DAML compiler Range
8867
srcSpanToRange :: SrcSpan -> Range
8968
srcSpanToRange (UnhelpfulSpan _) = noRange

test/exe/Main.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -438,7 +438,7 @@ diagnosticTests = testGroup "diagnostics"
438438
_ <- createDoc "Foo.hs" "haskell" fooContent
439439
expectDiagnostics
440440
[ ( "Foo.hs"
441-
, [(DsError, (2, 8), "Parse error on input")
441+
, [(DsWarning, (2, 8), "Haddock parse error on input")
442442
]
443443
)
444444
]

0 commit comments

Comments
 (0)