Skip to content

Commit b87bdb9

Browse files
noughtmaredylan-thinnessoulomoonfendorjeukshi
authored
Support structured diagnostics 2 (#4433)
* Change FileDiagnostic type synonym to a datatype * Make `ideErrorWithSource` produce FileDiagnostic by adding filepath arg * Supply structured error wherever we easily can - TODOs for hard parts We're leaving the TODOs for either later in this PR or in another PR * Fix UnitTests for new FileDiagnostic struct * Remove explicit uses of FileDiagnostic, add codes to LSP diagnostics * Add field for expected error codes in ghcide tests * Expect GHC-83865 for "type error" test - basic test * Return structured warnings in TcModuleResult by copying from Driver * Store FileDiagnostic instead of LSP Diagnostic in Shake store * Add expected error codes for diagnostics that have them * Dispatch TODOs, amend remaining TODOs as future work * Add scary comments all over copied code in Compat.Driver * Update all remaining diagnostics that could use an expected error code * Add _code to pretty printing for FileDiagnostic * Use case instead of `maybe` for StructuredMessage match * Use CPP to prevent setting _code before structured errors * Swap modifier for lenses, document StructuredMessage type * Add link to Issue & MR to Compat.Driver * Drop attachReason logic from withWarnings, technically incorrect * Revert "Drop attachReason logic", needed by pragmas-plugin This reverts commit 4fed987. * Fix plugins where necessary for new diagnostic structure * Fix build issues with other tests from `expectDiagnostics` * Improve comment on metadata fdStructuredMessage in FileDiagnostic * Add note to withWarnings explaining the current state of things * Attach reasons into data field of LSP Diagnostic instead of code field Had to move `attachReason` between modules to achieve this, which is fine because it was never exported from its own module. * Fix up mistakes from merge, TODO fix merge issues for 9.3.0 * Set CodeDescription from HaskellErrorIndex when available * Remove debugging print, fix expectation for preprocessor tests * Fix CPP for using Show instance on DiagnosticCode * Remove diagFromErrMsgs for GHC version < 9.6.1 using CPP * CPP fix * More stylish-haskell, more CPP fix * Fix all stylish-haskell errors triggering * Fix more CPP * Only override the LSP diagnostic code when not already set * Fixes for stylish-haskell stylish-haskell does not handle CPP pragmas very well, is this a regression? * Qualify s, t for FuzzySearch * Ignore use of unsafePerformIO in FuzzySearch * Properly split GHC.Types.Error import in Diagnostics for stylish-haskell * Force type signature of annotation on FuzzySearch.dictionary * DRY up definition of closure_errs From review #4311 (comment) * Remove unused imports * Post-rebase fixes * stylish-haskell formatting * Fix issue with GHC 9.4 * Please stylish-haskell * Ignore error codes when testing GHC 9.4 * Workaround darwin GHC bug in hls-hlint-plugin * Put the workaround in the right place * Revert "Set CodeDescription from HaskellErrorIndex when available" This reverts commit 14d6697. * Resolve fendor's feedback * Apply stylish-haskell formatting * Apply more stylish-haskell formatting * Resolve some of soulomoon's feedback * Fix small issues * Remove unused imports * Remove StructuredDiagnostic * Revert "Remove StructuredDiagnostic" This reverts commit 0776c65. * Remove the unused parameter from 'ideErrorText' * Add documentation to diagnostic helpers * Add action to query active diagnostics for a given Range Implement 'rangesOverlap' function which checks whether two 'Range's overlap in any way. Implement two new plugin utility functions which allow to conveniently get all currently displayed diagnostics for a given 'Range'. * Use lens for updating Diagnostic * Add GHC Structured Error compatibility module Add compatibility module for GHC's structured error messages. Introduce 'Prism's and 'Lens's to easily access nested structures. Expand documentation for 'StructuredMessage' * Remove unused imports * Don't suggest -Wno-deferred-out-of-scope-variables (#4441) Fixes #4440 Fixes test for disabling deferred-type-errors. * Build HLS with GHC 9.8.3 (#4444) * ci(mergify): upgrade configuration to current format (#4454) Co-authored-by: Mergify <37929162+mergify[bot]@users.noreply.github.com> * More tests and better docs for cabal-add (#4455) * new tests * change codeAction title * more tests and docs --------- Co-authored-by: fendor <[email protected]> * Fix compatibility with GHC 9.4 and rename function * Use GHC Note syntax and reference Note in docs Allows HLS to 'Goto Definition' for Note references. * Add doc comment for 'tmrWarnings' * Push CPP statements to compatibility module * Fix formatting in Development.IDE.GHC.Compat.Error --------- Co-authored-by: Dylan Thinnes <[email protected]> Co-authored-by: soulomoon <[email protected]> Co-authored-by: Fendor <[email protected]> Co-authored-by: jeukshi <[email protected]> Co-authored-by: fendor <[email protected]> Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com> Co-authored-by: Georgii Gerasev <[email protected]>
1 parent f09500b commit b87bdb9

File tree

46 files changed

+982
-358
lines changed

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

46 files changed

+982
-358
lines changed

‎ghcide-bench/src/Experiments.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -266,7 +266,7 @@ experiments =
266266
flip allM docs $ \DocumentPositions{..} -> do
267267
bottom <- pred . length . T.lines <$> documentContents doc
268268
diags <- getCurrentDiagnostics doc
269-
case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Nothing) of
269+
case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Just "GHC-88464", Nothing) of
270270
Nothing -> pure True
271271
Just _err -> pure False
272272
),

‎ghcide/ghcide.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -85,6 +85,7 @@ library
8585
, hls-plugin-api == 2.9.0.1
8686
, implicit-hie >= 0.1.4.0 && < 0.1.5
8787
, lens
88+
, lens-aeson
8889
, list-t
8990
, lsp ^>=2.7
9091
, lsp-types ^>=2.3
@@ -150,7 +151,9 @@ library
150151
Development.IDE.GHC.Compat
151152
Development.IDE.GHC.Compat.Core
152153
Development.IDE.GHC.Compat.CmdLine
154+
Development.IDE.GHC.Compat.Driver
153155
Development.IDE.GHC.Compat.Env
156+
Development.IDE.GHC.Compat.Error
154157
Development.IDE.GHC.Compat.Iface
155158
Development.IDE.GHC.Compat.Logger
156159
Development.IDE.GHC.Compat.Outputable

‎ghcide/session-loader/Development/IDE/Session.hs‎

Lines changed: 22 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -573,10 +573,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
573573
this_flags = (this_error_env, this_dep_info)
574574
this_error_env = ([this_error], Nothing)
575575
this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp
576-
$ T.unlines
577-
[ "No cradle target found. Is this file listed in the targets of your cradle?"
578-
, "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
579-
]
576+
(T.unlines
577+
[ "No cradle target found. Is this file listed in the targets of your cradle?"
578+
, "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
579+
])
580+
Nothing
580581

581582
void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map
582583
void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets))
@@ -797,10 +798,10 @@ setNameCache nc hsc = hsc { hsc_NC = nc }
797798
-- GHC had an implementation of this function, but it was horribly inefficient
798799
-- We should move back to the GHC implementation on compilers where
799800
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included
800-
checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages]
801+
checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage)
801802
checkHomeUnitsClosed' ue home_id_set
802-
| OS.null bad_unit_ids = []
803-
| otherwise = [singleMessage $ GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)]
803+
| OS.null bad_unit_ids = Nothing
804+
| otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids))
804805
where
805806
bad_unit_ids = upwards_closure OS.\\ home_id_set
806807
rootLoc = mkGeneralSrcSpan (Compat.fsLit "<command line>")
@@ -875,10 +876,19 @@ newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do
875876
hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4
876877
Compat.initUnits dfs hsc_env
877878

878-
let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')
879-
multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs
879+
let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')
880+
closure_err_to_multi_err err =
881+
ideErrorWithSource
882+
(Just "cradle") (Just DiagnosticSeverity_Warning) _cfp
883+
(T.pack (Compat.printWithoutUniques (singleMessage err)))
884+
#if MIN_VERSION_ghc(9,5,0)
885+
(Just (fmap GhcDriverMessage err))
886+
#else
887+
Nothing
888+
#endif
889+
multi_errs = map closure_err_to_multi_err closure_errs
880890
bad_units = OS.fromList $ concat $ do
881-
x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs
891+
x <- map errMsgDiagnostic closure_errs
882892
DriverHomePackagesNotClosed us <- pure x
883893
pure us
884894
isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units
@@ -1223,6 +1233,6 @@ showPackageSetupException PackageSetupException{..} = unwords
12231233
, "failed to load packages:", message <> "."
12241234
, "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."]
12251235

1226-
renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
1236+
renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic
12271237
renderPackageSetupException fp e =
1228-
ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e)
1238+
ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) Nothing

‎ghcide/session-loader/Development/IDE/Session/Diagnostics.hs‎

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22

33
module Development.IDE.Session.Diagnostics where
44
import Control.Applicative
5+
import Control.Lens
56
import Control.Monad
67
import qualified Data.Aeson as Aeson
78
import Data.List
@@ -27,11 +28,13 @@ data CradleErrorDetails =
2728
Depicts the cradle error in a user-friendly way.
2829
-}
2930
renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic
30-
renderCradleError (CradleError deps _ec ms) cradle nfp
31-
| HieBios.isCabalCradle cradle =
32-
let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in
33-
(fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}})
34-
| otherwise = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage
31+
renderCradleError (CradleError deps _ec ms) cradle nfp =
32+
let noDetails =
33+
ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing
34+
in
35+
if HieBios.isCabalCradle cradle
36+
then noDetails & fdLspDiagnosticL %~ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}
37+
else noDetails
3538
where
3639
absDeps = fmap (cradleRootDir cradle </>) deps
3740
userFriendlyMessage :: [String]

‎ghcide/src/Development/IDE/Core/Compile.hs‎

Lines changed: 82 additions & 46 deletions
Original file line numberDiff line numberDiff line change
@@ -111,6 +111,7 @@ import qualified Data.Set as Set
111111
import qualified GHC as G
112112
import qualified GHC.Runtime.Loader as Loader
113113
import GHC.Tc.Gen.Splice
114+
import GHC.Types.Error
114115
import GHC.Types.ForeignStubs
115116
import GHC.Types.HpcInfo
116117
import GHC.Types.TypeEnv
@@ -130,6 +131,8 @@ import GHC.Unit.Module.Warnings
130131
import Development.IDE.Core.FileStore (shareFilePath)
131132
#endif
132133

134+
import Development.IDE.GHC.Compat.Driver (hscTypecheckRenameWithDiagnostics)
135+
133136
--Simple constants to make sure the source is consistently named
134137
sourceTypecheck :: T.Text
135138
sourceTypecheck = "typecheck"
@@ -157,8 +160,12 @@ computePackageDeps
157160
-> IO (Either [FileDiagnostic] [UnitId])
158161
computePackageDeps env pkg = do
159162
case lookupUnit env pkg of
160-
Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
161-
T.pack $ "unknown package: " ++ show pkg]
163+
Nothing ->
164+
return $ Left
165+
[ ideErrorText
166+
(toNormalizedFilePath' noFilePath)
167+
(T.pack $ "unknown package: " ++ show pkg)
168+
]
162169
Just pkgInfo -> return $ Right $ unitDepends pkgInfo
163170

164171
newtype TypecheckHelpers
@@ -179,20 +186,24 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do
179186
case initialized of
180187
Left errs -> return (errs, Nothing)
181188
Right hscEnv -> do
182-
(warnings, etcm) <- withWarnings sourceTypecheck $ \tweak ->
189+
etcm <-
183190
let
184-
session = tweak (hscSetFlags dflags hscEnv)
185-
-- TODO: maybe settings ms_hspp_opts is unnecessary?
186-
mod_summary'' = modSummary { ms_hspp_opts = hsc_dflags session}
191+
-- TODO: maybe setting ms_hspp_opts is unnecessary?
192+
mod_summary' = modSummary { ms_hspp_opts = hsc_dflags hscEnv}
187193
in
188194
catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do
189-
tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}
190-
let errorPipeline = unDefer . hideDiag dflags . tagDiag
191-
diags = map errorPipeline warnings
192-
deferredError = any fst diags
195+
tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary'}
193196
case etcm of
194-
Left errs -> return (map snd diags ++ errs, Nothing)
195-
Right tcm -> return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})
197+
Left errs -> return (errs, Nothing)
198+
Right tcm ->
199+
let addReason diag =
200+
map (Just (diagnosticReason (errMsgDiagnostic diag)),) $
201+
diagFromErrMsg sourceTypecheck (hsc_dflags hscEnv) diag
202+
errorPipeline = map (unDefer . hideDiag dflags . tagDiag) . addReason
203+
diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm
204+
deferredError = any fst diags
205+
in
206+
return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})
196207
where
197208
demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
198209

@@ -358,9 +369,9 @@ tcRnModule hsc_env tc_helpers pmod = do
358369
let ms = pm_mod_summary pmod
359370
hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env
360371

361-
((tc_gbl_env', mrn_info), splices, mod_env)
372+
(((tc_gbl_env', mrn_info), warning_messages), splices, mod_env)
362373
<- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp ->
363-
do hscTypecheckRename hscEnvTmp ms $
374+
do hscTypecheckRenameWithDiagnostics hscEnvTmp ms $
364375
HsParsedModule { hpm_module = parsedSource pmod
365376
, hpm_src_files = pm_extra_src_files pmod
366377
}
@@ -372,7 +383,7 @@ tcRnModule hsc_env tc_helpers pmod = do
372383
mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash)
373384
(moduleEnvToList mod_env)
374385
tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }
375-
pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env)
386+
pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env warning_messages)
376387

377388

378389
-- Note [Clearing mi_globals after generating an iface]
@@ -535,8 +546,14 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
535546
source = "compile"
536547
catchErrs x = x `catches`
537548
[ Handler $ return . (,Nothing) . diagFromGhcException source dflags
538-
, Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
539-
. (("Error during " ++ T.unpack source) ++) . show @SomeException
549+
, Handler $ \diag ->
550+
return
551+
( diagFromString
552+
source DiagnosticSeverity_Error (noSpan "<internal>")
553+
("Error during " ++ T.unpack source ++ show @SomeException diag)
554+
Nothing
555+
, Nothing
556+
)
540557
]
541558

542559
-- | Whether we should run the -O0 simplifier when generating core.
@@ -660,15 +677,16 @@ unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True
660677
unDefer ( _ , fd) = (False, fd)
661678

662679
upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
663-
upgradeWarningToError (nfp, sh, fd) =
664-
(nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where
680+
upgradeWarningToError =
681+
fdLspDiagnosticL %~ \diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag}
682+
where
665683
warn2err :: T.Text -> T.Text
666684
warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
667685

668686
hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
669-
hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd))
687+
hideDiag originalFlags (w@(Just (WarningWithFlag warning)), fd)
670688
| not (wopt warning originalFlags)
671-
= (w, (nfp, HideDiag, fd))
689+
= (w, fd { fdShouldShowDiagnostic = HideDiag })
672690
hideDiag _originalFlags t = t
673691

674692
-- | Warnings which lead to a diagnostic tag
@@ -692,18 +710,18 @@ unnecessaryDeprecationWarningFlags
692710
tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
693711

694712
#if MIN_VERSION_ghc(9,7,0)
695-
tagDiag (w@(Just (WarningWithCategory cat)), (nfp, sh, fd))
713+
tagDiag (w@(Just (WarningWithCategory cat)), fd)
696714
| cat == defaultWarningCategory -- default warning category is for deprecations
697-
= (w, (nfp, sh, fd { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags fd) }))
698-
tagDiag (w@(Just (WarningWithFlags warnings)), (nfp, sh, fd))
715+
= (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) })
716+
tagDiag (w@(Just (WarningWithFlags warnings)), fd)
699717
| tags <- mapMaybe requiresTag (toList warnings)
700-
= (w, (nfp, sh, fd { _tags = Just $ tags ++ concat (_tags fd) }))
718+
= (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tags ++ concat (_tags diag) })
701719
#else
702-
tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd))
720+
tagDiag (w@(Just (WarningWithFlag warning)), fd)
703721
| Just tag <- requiresTag warning
704-
= (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))
722+
= (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tag : concat (_tags diag) })
705723
#endif
706-
where
724+
where
707725
requiresTag :: WarningFlag -> Maybe DiagnosticTag
708726
#if !MIN_VERSION_ghc(9,7,0)
709727
-- doesn't exist on 9.8, we use WarningWithCategory instead
@@ -859,16 +877,25 @@ handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
859877
handleGenerationErrors dflags source action =
860878
action >> return [] `catches`
861879
[ Handler $ return . diagFromGhcException source dflags
862-
, Handler $ return . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
863-
. (("Error during " ++ T.unpack source) ++) . show @SomeException
880+
, Handler $ \(exception :: SomeException) -> return $
881+
diagFromString
882+
source DiagnosticSeverity_Error (noSpan "<internal>")
883+
("Error during " ++ T.unpack source ++ show exception)
884+
Nothing
864885
]
865886

866887
handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
867888
handleGenerationErrors' dflags source action =
868889
fmap ([],) action `catches`
869890
[ Handler $ return . (,Nothing) . diagFromGhcException source dflags
870-
, Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
871-
. (("Error during " ++ T.unpack source) ++) . show @SomeException
891+
, Handler $ \(exception :: SomeException) ->
892+
return
893+
( diagFromString
894+
source DiagnosticSeverity_Error (noSpan "<internal>")
895+
("Error during " ++ T.unpack source ++ show exception)
896+
Nothing
897+
, Nothing
898+
)
872899
]
873900

874901

@@ -1048,7 +1075,7 @@ parseHeader dflags filename contents = do
10481075
let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1
10491076
case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of
10501077
PFailedWithErrorMessages msgs ->
1051-
throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags
1078+
throwE $ diagFromGhcErrorMessages sourceParser dflags $ msgs dflags
10521079
POk pst rdr_module -> do
10531080
let (warns, errs) = renderMessages $ getPsMessages pst
10541081

@@ -1062,9 +1089,9 @@ parseHeader dflags filename contents = do
10621089
-- errors are those from which a parse tree just can't
10631090
-- be produced.
10641091
unless (null errs) $
1065-
throwE $ diagFromErrMsgs sourceParser dflags errs
1092+
throwE $ diagFromGhcErrorMessages sourceParser dflags errs
10661093

1067-
let warnings = diagFromErrMsgs sourceParser dflags warns
1094+
let warnings = diagFromGhcErrorMessages sourceParser dflags warns
10681095
return (warnings, rdr_module)
10691096

10701097
-- | Given a buffer, flags, and file path, produce a
@@ -1081,18 +1108,28 @@ parseFileContents env customPreprocessor filename ms = do
10811108
dflags = ms_hspp_opts ms
10821109
contents = fromJust $ ms_hspp_buf ms
10831110
case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of
1084-
PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags
1111+
PFailedWithErrorMessages msgs ->
1112+
throwE $ diagFromGhcErrorMessages sourceParser dflags $ msgs dflags
10851113
POk pst rdr_module ->
10861114
let
10871115
psMessages = getPsMessages pst
10881116
in
10891117
do
1090-
let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
1091-
1092-
unless (null errs) $
1093-
throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs
1094-
1095-
let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns
1118+
let IdePreprocessedSource preproc_warns preproc_errs parsed = customPreprocessor rdr_module
1119+
let attachNoStructuredError (span, msg) = (span, msg, Nothing)
1120+
1121+
unless (null preproc_errs) $
1122+
throwE $
1123+
diagFromStrings
1124+
sourceParser
1125+
DiagnosticSeverity_Error
1126+
(fmap attachNoStructuredError preproc_errs)
1127+
1128+
let preproc_warning_file_diagnostics =
1129+
diagFromStrings
1130+
sourceParser
1131+
DiagnosticSeverity_Warning
1132+
(fmap attachNoStructuredError preproc_warns)
10961133
(parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env ms parsed psMessages
10971134
let (warns, errors) = renderMessages msgs
10981135

@@ -1106,8 +1143,7 @@ parseFileContents env customPreprocessor filename ms = do
11061143
-- errors are those from which a parse tree just can't
11071144
-- be produced.
11081145
unless (null errors) $
1109-
throwE $ diagFromErrMsgs sourceParser dflags errors
1110-
1146+
throwE $ diagFromGhcErrorMessages sourceParser dflags errors
11111147

11121148
-- To get the list of extra source files, we take the list
11131149
-- that the parser gave us,
@@ -1137,8 +1173,8 @@ parseFileContents env customPreprocessor filename ms = do
11371173
srcs2 <- liftIO $ filterM doesFileExist srcs1
11381174

11391175
let pm = ParsedModule ms parsed' srcs2
1140-
warnings = diagFromErrMsgs sourceParser dflags warns
1141-
pure (warnings ++ preproc_warnings, pm)
1176+
warnings = diagFromGhcErrorMessages sourceParser dflags warns
1177+
pure (warnings ++ preproc_warning_file_diagnostics, pm)
11421178

11431179
loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile
11441180
loadHieFile ncu f = do

0 commit comments

Comments
 (0)