From 44cf722b8a9b4bc187cbcbea15bab58db9febfc4 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sat, 8 Jun 2024 13:48:52 +0100 Subject: [PATCH 01/44] Change FileDiagnostic type synonym to a datatype --- .../session-loader/Development/IDE/Session.hs | 10 +++--- .../Development/IDE/Session/Diagnostics.hs | 8 +++-- ghcide/src/Development/IDE/Core/Compile.hs | 20 +++++------ .../src/Development/IDE/Core/Preprocessor.hs | 2 +- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- ghcide/src/Development/IDE/Core/Shake.hs | 18 +++++----- ghcide/src/Development/IDE/GHC/Error.hs | 27 ++++++++------ ghcide/src/Development/IDE/GHC/Warnings.hs | 5 +-- .../src/Development/IDE/Plugin/TypeLenses.hs | 4 +-- .../src/Development/IDE/Types/Diagnostics.hs | 35 ++++++++++++++----- 10 files changed, 77 insertions(+), 54 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a1d778ab0e..0e723afc9f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -572,7 +572,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] this_flags = (this_error_env, this_dep_info) this_error_env = ([this_error], Nothing) - this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp + this_error = uncurry (FileDiagnostic _cfp) $ ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) $ T.unlines [ "No cradle target found. Is this file listed in the targets of your cradle?" , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" @@ -876,7 +876,7 @@ newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do Compat.initUnits dfs hsc_env let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs + multi_errs = map (uncurry (FileDiagnostic _cfp) . ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) . T.pack . Compat.printWithoutUniques) closure_errs bad_units = OS.fromList $ concat $ do x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs DriverHomePackagesNotClosed us <- pure x @@ -1223,6 +1223,8 @@ showPackageSetupException PackageSetupException{..} = unwords , "failed to load packages:", message <> "." , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."] -renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) +renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic renderPackageSetupException fp e = - ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) + let (showDiag, lspDiag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (T.pack $ showPackageSetupException e) + in + FileDiagnostic (toNormalizedFilePath' fp) showDiag lspDiag diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index a8e35e5965..09e94935a8 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -29,9 +29,11 @@ data CradleErrorDetails = renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic renderCradleError (CradleError deps _ec ms) cradle nfp | HieBios.isCabalCradle cradle = - let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in - (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}) - | otherwise = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage + let (showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) $ T.unlines $ map T.pack userFriendlyMessage + in FileDiagnostic nfp showDiag diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}} + | otherwise = + let (showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) $ T.unlines $ map T.pack userFriendlyMessage + in FileDiagnostic nfp showDiag diag where absDeps = fmap (cradleRootDir cradle ) deps userFriendlyMessage :: [String] diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index cb960dd2c9..922f794dc0 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -660,15 +660,15 @@ unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True unDefer ( _ , fd) = (False, fd) upgradeWarningToError :: FileDiagnostic -> FileDiagnostic -upgradeWarningToError (nfp, sh, fd) = - (nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where +upgradeWarningToError fd = + modifyFdLspDiagnostic (\diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag}) fd where warn2err :: T.Text -> T.Text warn2err = T.intercalate ": error:" . T.splitOn ": warning:" hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) -hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd)) +hideDiag originalFlags (w@(Just (WarningWithFlag warning)), fd) | not (wopt warning originalFlags) - = (w, (nfp, HideDiag, fd)) + = (w, fd { fdShouldShowDiagnostic = HideDiag }) hideDiag _originalFlags t = t -- | Warnings which lead to a diagnostic tag @@ -692,16 +692,16 @@ unnecessaryDeprecationWarningFlags tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) #if MIN_VERSION_ghc(9,7,0) -tagDiag (w@(Just (WarningWithCategory cat)), (nfp, sh, fd)) +tagDiag (w@(Just (WarningWithCategory cat)), fd) | cat == defaultWarningCategory -- default warning category is for deprecations - = (w, (nfp, sh, fd { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags fd) })) -tagDiag (w@(Just (WarningWithFlags warnings)), (nfp, sh, fd)) + = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) }) fd) +tagDiag (w@(Just (WarningWithFlags warnings)), fd) | tags <- mapMaybe requiresTag (toList warnings) - = (w, (nfp, sh, fd { _tags = Just $ tags ++ concat (_tags fd) })) + = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tags ++ concat (_tags diag) }) fd) #else -tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd)) +tagDiag (w@(Just (WarningWithFlag warning)), fd) | Just tag <- requiresTag warning - = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) })) + = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tag : concat (_tags diag) }) fd) #endif where requiresTag :: WarningFlag -> Maybe DiagnosticTag diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index 46fb03f191..c382784e03 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -104,7 +104,7 @@ data CPPDiag diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] diagsFromCPPLogs filename logs = - map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $ + map (\d -> FileDiagnostic (toNormalizedFilePath' filename) ShowDiag (cppDiagToDiagnostic d)) $ go [] logs where -- On errors, CPP calls logAction with a real span for the initial log and diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 4f80b2e635..1b2901d07f 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -486,7 +486,7 @@ reportImportCyclesRule recorder = where cycleErrorInFile f (PartOfCycle imp fs) | f `elem` fs = Just (imp, fs) cycleErrorInFile _ _ = Nothing - toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic + toDiag imp mods = FileDiagnostic fp ShowDiag $ Diagnostic { _range = rng , _severity = Just DiagnosticSeverity_Error , _source = Just "Import cycle detection" diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 1c25fa9ee0..32c254fce4 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1173,7 +1173,7 @@ defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file ver (newKey key) extras diags defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do let diagnostics _ver diags = do @@ -1192,7 +1192,7 @@ defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (o extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file ver (newKey key) extras diags defineEarlyCutoff' diagnostics (==) key file old mode $ op key file defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () @@ -1329,26 +1329,26 @@ updateFileDiagnostics :: MonadIO m -> Maybe Int32 -> Key -> ShakeExtras - -> [(ShowDiagnostic,Diagnostic)] -- ^ current results + -> [FileDiagnostic] -- ^ current results -> m () updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do addTag "key" (show k) - let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current + let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current uri = filePathToUri' fp addTagUnsafe :: String -> String -> String -> a -> a addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic] update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store - current = second diagsFromRule <$> current0 + current = map (modifyFdLspDiagnostic diagsFromRule) current0 addTag "version" (show ver) mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always -- published. Otherwise, we might never publish certain diagnostics if -- an exception strikes between modifyVar but before -- publishDiagnosticsNotification. - newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map snd currentShown) diagnostics - _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map snd currentHidden) hiddenDiagnostics + newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map fdLspDiagnostic currentShown) diagnostics + _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map fdLspDiagnostic currentHidden) hiddenDiagnostics let uri' = filePathToUri' fp let delay = if null newDiags then 0.1 else 0 registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do @@ -1356,7 +1356,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. - logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags) + logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (FileDiagnostic fp ShowDiag) newDiags) Just env -> LSP.runLspT env $ do liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) @@ -1423,7 +1423,7 @@ getAllDiagnostics :: STMDiagnosticStore -> STM [FileDiagnostic] getAllDiagnostics = - fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT + fmap (concatMap (\(k,v) -> map (FileDiagnostic (fromUri k) ShowDiag) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index 651fa5a34d..4c20944105 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -52,17 +52,22 @@ import Language.LSP.VFS (CodePointPosition (CodePoint diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic -diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,) - Diagnostic - { _range = fromMaybe noRange $ srcSpanToRange loc - , _severity = Just sev - , _source = Just diagSource -- not shown in the IDE, but useful for ghcide developers - , _message = msg - , _code = Nothing - , _relatedInformation = Nothing - , _tags = Nothing - , _codeDescription = Nothing - , _data_ = Nothing +diagFromText diagSource sev loc msg = + FileDiagnostic + { fdFilePath = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc + , fdShouldShowDiagnostic = ShowDiag + , fdLspDiagnostic = + Diagnostic + { _range = fromMaybe noRange $ srcSpanToRange loc + , _severity = Just sev + , _source = Just diagSource -- not shown in the IDE, but useful for ghcide developers + , _message = msg + , _code = Nothing + , _relatedInformation = Nothing + , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing + } } -- | Produce a GHC-style error from a source span and a message. diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 5e0d9b1d46..f32b345c3e 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -29,15 +29,12 @@ withWarnings diagSource action = do warnings <- newVar [] let newAction :: DynFlags -> LogActionCompat newAction dynFlags logFlags wr _ loc prUnqual msg = do - let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags wr logFlags loc prUnqual msg + let wr_d = map ((wr,) . modifyFdLspDiagnostic (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags wr logFlags loc prUnqual msg modifyVar_ warnings $ return . (wr_d:) newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env) res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res) - where - third3 :: (c -> d) -> (a, b, c) -> (a, b, d) - third3 f (a, b, c) = (a, b, f c) attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic attachReason Nothing d = d diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 51d25e995b..6ab66f5554 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -30,7 +30,7 @@ import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), RuleResult, Rules, Uri, define, srcSpanToRange, - usePropertyAction) + usePropertyAction, FileDiagnostic (..)) import Development.IDE.Core.Compile (TcModuleResult (..)) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, @@ -126,7 +126,7 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif -- We don't actually pass any data to resolve, however we need this -- dummy type to make sure HLS resolves our lens [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve) - | (dFile, _, diag@Diagnostic{_range}) <- diags + | FileDiagnostic dFile _ diag@Diagnostic{_range} <- diags , dFile == nfp , isGlobalDiagnostic diag] -- The second option is to generate lenses from the GlobalBindingTypeSig diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 8189ff89c1..536be609a6 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -1,11 +1,13 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DeriveGeneric #-} module Development.IDE.Types.Diagnostics ( LSP.Diagnostic(..), ShowDiagnostic(..), - FileDiagnostic, + FileDiagnostic(..), + modifyFdLspDiagnostic, IdeResult, LSP.DiagnosticSeverity(..), DiagnosticStore, @@ -20,6 +22,7 @@ import Data.ByteString (ByteString) import Data.Maybe as Maybe import qualified Data.Text as T import Development.IDE.Types.Location +import GHC.Generics import Language.LSP.Diagnostics import Language.LSP.Protocol.Types as LSP (Diagnostic (..), DiagnosticSeverity (..)) @@ -45,15 +48,18 @@ type IdeResult v = ([FileDiagnostic], Maybe v) type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v) ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic -ideErrorText = ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) +ideErrorText fdFilePath msg = + let (fdShouldShowDiagnostic, fdLspDiagnostic) = + ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) msg + in + FileDiagnostic{..} ideErrorWithSource :: Maybe T.Text -> Maybe DiagnosticSeverity - -> a -> T.Text - -> (a, ShowDiagnostic, Diagnostic) -ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic { + -> (ShowDiagnostic, Diagnostic) +ideErrorWithSource source sev msg = (ShowDiag, LSP.Diagnostic { _range = noRange, _severity = sev, _code = Nothing, @@ -86,7 +92,18 @@ instance NFData ShowDiagnostic where -- along with the related source location so that we can display the error -- on either the console or in the IDE at the right source location. -- -type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic) +data FileDiagnostic = FileDiagnostic + { fdFilePath :: NormalizedFilePath + , fdShouldShowDiagnostic :: ShowDiagnostic + , fdLspDiagnostic :: Diagnostic + } + deriving (Eq, Ord, Show, Generic) + +instance NFData FileDiagnostic + +modifyFdLspDiagnostic :: (Diagnostic -> Diagnostic) -> FileDiagnostic -> FileDiagnostic +modifyFdLspDiagnostic f diag = + diag { fdLspDiagnostic = f (fdLspDiagnostic diag) } prettyRange :: Range -> Doc Terminal.AnsiStyle prettyRange Range{..} = f _start <> "-" <> f _end @@ -106,10 +123,10 @@ prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle prettyDiagnostics = vcat . map prettyDiagnostic prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle -prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) = +prettyDiagnostic FileDiagnostic { fdFilePath, fdShouldShowDiagnostic, fdLspDiagnostic = LSP.Diagnostic{..} } = vcat - [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp) - , slabel_ "Hidden: " $ if sh == ShowDiag then "no" else "yes" + [ slabel_ "File: " $ pretty (fromNormalizedFilePath fdFilePath) + , slabel_ "Hidden: " $ if fdShouldShowDiagnostic == ShowDiag then "no" else "yes" , slabel_ "Range: " $ prettyRange _range , slabel_ "Source: " $ pretty _source , slabel_ "Severity:" $ pretty $ show sev From 789977dd8e282dc003247d5413a877e27f62d4b1 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sat, 8 Jun 2024 14:26:02 +0100 Subject: [PATCH 02/44] Make `ideErrorWithSource` produce FileDiagnostic by adding filepath arg --- ghcide/session-loader/Development/IDE/Session.hs | 8 +++----- .../Development/IDE/Session/Diagnostics.hs | 14 +++++++------- ghcide/src/Development/IDE/Types/Diagnostics.hs | 12 +++++------- 3 files changed, 15 insertions(+), 19 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 0e723afc9f..98d78fe1c1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -572,7 +572,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] this_flags = (this_error_env, this_dep_info) this_error_env = ([this_error], Nothing) - this_error = uncurry (FileDiagnostic _cfp) $ ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) + this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp $ T.unlines [ "No cradle target found. Is this file listed in the targets of your cradle?" , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" @@ -876,7 +876,7 @@ newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do Compat.initUnits dfs hsc_env let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - multi_errs = map (uncurry (FileDiagnostic _cfp) . ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) . T.pack . Compat.printWithoutUniques) closure_errs + multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs bad_units = OS.fromList $ concat $ do x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs DriverHomePackagesNotClosed us <- pure x @@ -1225,6 +1225,4 @@ showPackageSetupException PackageSetupException{..} = unwords renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic renderPackageSetupException fp e = - let (showDiag, lspDiag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (T.pack $ showPackageSetupException e) - in - FileDiagnostic (toNormalizedFilePath' fp) showDiag lspDiag + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index 09e94935a8..0a3911f272 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -27,13 +27,13 @@ data CradleErrorDetails = Depicts the cradle error in a user-friendly way. -} renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic -renderCradleError (CradleError deps _ec ms) cradle nfp - | HieBios.isCabalCradle cradle = - let (showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) $ T.unlines $ map T.pack userFriendlyMessage - in FileDiagnostic nfp showDiag diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}} - | otherwise = - let (showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) $ T.unlines $ map T.pack userFriendlyMessage - in FileDiagnostic nfp showDiag diag +renderCradleError (CradleError deps _ec ms) cradle nfp = + let noDetails = + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage + in + if HieBios.isCabalCradle cradle + then flip modifyFdLspDiagnostic noDetails $ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}} + else noDetails where absDeps = fmap (cradleRootDir cradle ) deps userFriendlyMessage :: [String] diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 536be609a6..ff7309c2b9 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -49,17 +49,15 @@ type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v) ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic ideErrorText fdFilePath msg = - let (fdShouldShowDiagnostic, fdLspDiagnostic) = - ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) msg - in - FileDiagnostic{..} + ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) fdFilePath msg ideErrorWithSource :: Maybe T.Text -> Maybe DiagnosticSeverity + -> NormalizedFilePath -> T.Text - -> (ShowDiagnostic, Diagnostic) -ideErrorWithSource source sev msg = (ShowDiag, LSP.Diagnostic { + -> FileDiagnostic +ideErrorWithSource source sev fp msg = FileDiagnostic fp ShowDiag LSP.Diagnostic { _range = noRange, _severity = sev, _code = Nothing, @@ -69,7 +67,7 @@ ideErrorWithSource source sev msg = (ShowDiag, LSP.Diagnostic { _tags = Nothing, _codeDescription = Nothing, _data_ = Nothing - }) + } -- | Defines whether a particular diagnostic should be reported -- back to the user. From e9d1c68378b16b2575d05214ba92fe72a842005a Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 9 Jun 2024 14:00:54 +0100 Subject: [PATCH 03/44] 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 --- .../session-loader/Development/IDE/Session.hs | 39 ++++++++---- .../Development/IDE/Session/Diagnostics.hs | 2 +- ghcide/src/Development/IDE/Core/Compile.hs | 59 ++++++++++++----- ghcide/src/Development/IDE/Core/FileStore.hs | 2 +- .../src/Development/IDE/Core/Preprocessor.hs | 2 +- ghcide/src/Development/IDE/Core/Rules.hs | 14 +---- ghcide/src/Development/IDE/Core/Shake.hs | 6 +- ghcide/src/Development/IDE/GHC/Compat.hs | 13 ++++ .../Development/IDE/GHC/Compat/Outputable.hs | 4 ++ ghcide/src/Development/IDE/GHC/Error.hs | 54 ++++++++++------ ghcide/src/Development/IDE/GHC/Warnings.hs | 2 +- .../src/Development/IDE/Import/FindImports.hs | 2 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 2 +- .../src/Development/IDE/Types/Diagnostics.hs | 63 ++++++++++++++----- ghcide/src/Development/IDE/Types/Options.hs | 4 +- 15 files changed, 186 insertions(+), 82 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 98d78fe1c1..72506174e2 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -573,10 +573,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do this_flags = (this_error_env, this_dep_info) this_error_env = ([this_error], Nothing) this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp - $ T.unlines - [ "No cradle target found. Is this file listed in the targets of your cradle?" - , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" - ] + (T.unlines + [ "No cradle target found. Is this file listed in the targets of your cradle?" + , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" + ]) + Nothing void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map 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 } -- GHC had an implementation of this function, but it was horribly inefficient -- We should move back to the GHC implementation on compilers where -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included -checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages] +checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage) checkHomeUnitsClosed' ue home_id_set - | OS.null bad_unit_ids = [] - | otherwise = [singleMessage $ GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)] + | OS.null bad_unit_ids = Nothing + | otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)) where bad_unit_ids = upwards_closure OS.\\ home_id_set rootLoc = mkGeneralSrcSpan (Compat.fsLit "") @@ -875,13 +876,29 @@ newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4 Compat.initUnits dfs hsc_env - let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs +#if MIN_VERSION_ghc(9,6,1) + let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') + -- TODO: Is this the right thing to do here, to produce an error for each DriverMessage generated? + closure_err_to_multi_err err = + ideErrorWithSource + (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp + (T.pack (Compat.printWithoutUniques (singleMessage err))) + (Just (fmap GhcDriverMessage err)) + multi_errs = map closure_err_to_multi_err closure_errs bad_units = OS.fromList $ concat $ do - x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs + x <- map errMsgDiagnostic closure_errs DriverHomePackagesNotClosed us <- pure x pure us isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units +#else + let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') + multi_errs = map (\diag -> ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp (T.pack (Compat.printWithoutUniques (singleMessage diag))) Nothing) closure_errs + bad_units = OS.fromList $ concat $ do + x <- map errMsgDiagnostic closure_errs + DriverHomePackagesNotClosed us <- pure x + pure us + isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units +#endif -- Whenever we spin up a session on Linux, dynamically load libm.so.6 -- in. We need this in case the binary is statically linked, in which -- case the interactive session will fail when trying to load @@ -1225,4 +1242,4 @@ showPackageSetupException PackageSetupException{..} = unwords renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic renderPackageSetupException fp e = - ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) Nothing diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index 0a3911f272..b377824f79 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -29,7 +29,7 @@ data CradleErrorDetails = renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic renderCradleError (CradleError deps _ec ms) cradle nfp = let noDetails = - ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing in if HieBios.isCabalCradle cradle then flip modifyFdLspDiagnostic noDetails $ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}} diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 922f794dc0..be4e0e14f2 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -157,8 +157,13 @@ computePackageDeps -> IO (Either [FileDiagnostic] [UnitId]) computePackageDeps env pkg = do case lookupUnit env pkg of - Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ - T.pack $ "unknown package: " ++ show pkg] + Nothing -> + return $ Left + [ ideErrorText + Nothing + (toNormalizedFilePath' noFilePath) + (T.pack $ "unknown package: " ++ show pkg) + ] Just pkgInfo -> return $ Right $ unitDepends pkgInfo newtype TypecheckHelpers @@ -535,8 +540,14 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do source = "compile" catchErrs x = x `catches` [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException + , Handler $ \diag -> + return + ( diagFromString + source DiagnosticSeverity_Error (noSpan "") + ("Error during " ++ T.unpack source ++ show @SomeException diag) + Nothing + , Nothing + ) ] -- | Whether we should run the -O0 simplifier when generating core. @@ -859,16 +870,25 @@ handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] handleGenerationErrors dflags source action = action >> return [] `catches` [ Handler $ return . diagFromGhcException source dflags - , Handler $ return . diagFromString source DiagnosticSeverity_Error (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException + , Handler $ \(exception :: SomeException) -> return $ + diagFromString + source DiagnosticSeverity_Error (noSpan "") + ("Error during " ++ T.unpack source ++ show exception) + Nothing ] handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a) handleGenerationErrors' dflags source action = fmap ([],) action `catches` [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException + , Handler $ \(exception :: SomeException) -> + return + ( diagFromString + source DiagnosticSeverity_Error (noSpan "") + ("Error during " ++ T.unpack source ++ show exception) + Nothing + , Nothing + ) ] @@ -1087,12 +1107,21 @@ parseFileContents env customPreprocessor filename ms = do psMessages = getPsMessages pst in do - let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module - - unless (null errs) $ - throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs - - let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns + let IdePreprocessedSource preproc_warns preproc_errs parsed = customPreprocessor rdr_module + let attachNoStructuredError (span, msg) = (span, msg, Nothing) + + unless (null preproc_errs) $ + throwE $ + diagFromStrings + sourceParser + DiagnosticSeverity_Error + (fmap attachNoStructuredError preproc_errs) + + let preproc_warning_file_diagnostics = + diagFromStrings + sourceParser + DiagnosticSeverity_Warning + (fmap attachNoStructuredError preproc_warns) (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env ms parsed psMessages let (warns, errors) = renderMessages msgs @@ -1138,7 +1167,7 @@ parseFileContents env customPreprocessor filename ms = do let pm = ParsedModule ms parsed' srcs2 warnings = diagFromErrMsgs sourceParser dflags warns - pure (warnings ++ preproc_warnings, pm) + pure (warnings ++ preproc_warning_file_diagnostics, pm) loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile loadHieFile ncu f = do diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 3de21e175d..f8c62dde47 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -142,7 +142,7 @@ getModificationTimeImpl missingFileDiags file = do `catch` \(e :: IOException) -> do let err | isDoesNotExistError e = "File does not exist: " ++ file' | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e - diag = ideErrorText file (T.pack err) + diag = ideErrorText Nothing file (T.pack err) if isDoesNotExistError e && not missingFileDiags then return (Nothing, ([], Nothing)) else return (Nothing, ([diag], Nothing)) diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index c382784e03..d62347e246 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -104,7 +104,7 @@ data CPPDiag diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] diagsFromCPPLogs filename logs = - map (\d -> FileDiagnostic (toNormalizedFilePath' filename) ShowDiag (cppDiagToDiagnostic d)) $ + map (\d -> FileDiagnostic (toNormalizedFilePath' filename) ShowDiag (cppDiagToDiagnostic d) NoStructuredMessage) $ go [] logs where -- On errors, CPP calls logAction with a real span for the initial log and diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 1b2901d07f..0adbf96977 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -486,17 +486,9 @@ reportImportCyclesRule recorder = where cycleErrorInFile f (PartOfCycle imp fs) | f `elem` fs = Just (imp, fs) cycleErrorInFile _ _ = Nothing - toDiag imp mods = FileDiagnostic fp ShowDiag $ Diagnostic - { _range = rng - , _severity = Just DiagnosticSeverity_Error - , _source = Just "Import cycle detection" - , _message = "Cyclic module dependency between " <> showCycle mods - , _code = Nothing - , _relatedInformation = Nothing - , _tags = Nothing - , _codeDescription = Nothing - , _data_ = Nothing - } + toDiag imp mods = + modifyFdLspDiagnostic (\lspDiag -> lspDiag { _range = rng }) + $ ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) getModuleName file = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 32c254fce4..26c20276f6 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1247,7 +1247,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do (mbBs, (diags, mbRes)) <- actionCatch (do v <- action staleV; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do - pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) + pure (Nothing, ([ideErrorText Nothing file $ T.pack $ show e | not $ isBadDependency e],Nothing)) ver <- estimateFileVersionUnsafely key mbRes file (bs, res) <- case mbRes of @@ -1356,7 +1356,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. - logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (FileDiagnostic fp ShowDiag) newDiags) + logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (\lspDiag -> FileDiagnostic fp ShowDiag lspDiag NoStructuredMessage) newDiags) -- TODO: Should try to get structured diagnostics plumbed here if possible Just env -> LSP.runLspT env $ do liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) @@ -1423,7 +1423,7 @@ getAllDiagnostics :: STMDiagnosticStore -> STM [FileDiagnostic] getAllDiagnostics = - fmap (concatMap (\(k,v) -> map (FileDiagnostic (fromUri k) ShowDiag) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT + fmap (concatMap (\(k,v) -> map (\diag -> FileDiagnostic (fromUri k) ShowDiag diag NoStructuredMessage) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT -- TODO: Do we need the structured message here? updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index d6184bcd50..7367c03f26 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -310,12 +310,25 @@ corePrepExpr _ = GHC.corePrepExpr renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg) renderMessages msgs = +#if MIN_VERSION_ghc(9,6,1) + let renderMsgs extractor = (fmap . fmap) GhcPsMessage . getMessages $ extractor msgs + in (renderMsgs psWarnings, renderMsgs psErrors) +#else let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs in (renderMsgs psWarnings, renderMsgs psErrors) +#endif +#if MIN_VERSION_ghc(9,6,1) +pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope GhcMessage)) -> ParseResult a +#elif MIN_VERSION_ghc(9,3,0) pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a +#endif pattern PFailedWithErrorMessages msgs +#if MIN_VERSION_ghc(9,6,1) + <- PFailed (const . fmap (fmap GhcPsMessage) . getMessages . getPsErrorMessages -> msgs) +#else <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs) +#endif {-# COMPLETE POk, PFailedWithErrorMessages #-} hieExportNames :: HieFile -> [(SrcSpan, Name)] diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index 078d116434..50331101d1 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -118,6 +118,10 @@ pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e +#if MIN_VERSION_ghc(9,6,1) +type ErrMsg = MsgEnvelope GhcMessage +type WarnMsg = MsgEnvelope GhcMessage +#elif MIN_VERSION_ghc(9,3,0) type ErrMsg = MsgEnvelope DecoratedSDoc type WarnMsg = MsgEnvelope DecoratedSDoc diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index 4c20944105..4c04910792 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -6,6 +6,8 @@ module Development.IDE.GHC.Error -- * Producing Diagnostic values diagFromErrMsgs , diagFromErrMsg + , diagFromSDocErrMsgs + , diagFromSDocErrMsg , diagFromString , diagFromStrings , diagFromGhcException @@ -36,10 +38,11 @@ module Development.IDE.GHC.Error import Data.Maybe import Data.String (fromString) import qualified Data.Text as T -import Development.IDE.GHC.Compat (DecoratedSDoc, MsgEnvelope, - errMsgSeverity, errMsgSpan, +import Data.Tuple.Extra (uncurry3) +import Development.IDE.GHC.Compat (MsgEnvelope, + errMsgSeverity, errMsgSpan, errMsgDiagnostic, formatErrorWithQual, - srcErrorMessages) + srcErrorMessages, GhcMessage) import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.GHC.Orphans () @@ -51,8 +54,8 @@ import Language.LSP.VFS (CodePointPosition (CodePoint CodePointRange (CodePointRange)) -diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic -diagFromText diagSource sev loc msg = +diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic +diagFromText diagSource sev loc msg origMsg = FileDiagnostic { fdFilePath = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc , fdShouldShowDiagnostic = ShowDiag @@ -68,18 +71,31 @@ diagFromText diagSource sev loc msg = , _codeDescription = Nothing , _data_ = Nothing } + , fdStructuredMessage = maybe NoStructuredMessage SomeStructuredMessage origMsg } -- | Produce a GHC-style error from a source span and a message. -diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic] -diagFromErrMsg diagSource dflags e = - [ diagFromText diagSource sev (errMsgSpan e) - $ T.pack $ formatErrorWithQual dflags e - | Just sev <- [toDSeverity $ errMsgSeverity e]] +diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic] +diagFromErrMsg diagSource dflags origErr = + let err = fmap (\e -> (Compat.renderDiagnosticMessageWithHints e, Just origErr)) origErr + in + diagFromSDocWithOptionalOrigMsg diagSource dflags err -diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic] +diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic] diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . Compat.bagToList +diagFromSDocErrMsg :: T.Text -> DynFlags -> MsgEnvelope Compat.DecoratedSDoc -> [FileDiagnostic] +diagFromSDocErrMsg diagSource dflags err = + diagFromSDocWithOptionalOrigMsg diagSource dflags (fmap (,Nothing) err) + +diagFromSDocErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope Compat.DecoratedSDoc) -> [FileDiagnostic] +diagFromSDocErrMsgs diagSource dflags = concatMap (diagFromSDocErrMsg diagSource dflags) . Compat.bagToList + +diagFromSDocWithOptionalOrigMsg :: T.Text -> DynFlags -> MsgEnvelope (Compat.DecoratedSDoc, Maybe (MsgEnvelope GhcMessage)) -> [FileDiagnostic] +diagFromSDocWithOptionalOrigMsg diagSource dflags err = + [ diagFromText diagSource sev (errMsgSpan err) (T.pack (formatErrorWithQual dflags (fmap fst err))) (snd (errMsgDiagnostic err)) + | Just sev <- [toDSeverity $ errMsgSeverity err]] + -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range srcSpanToRange (UnhelpfulSpan _) = Nothing @@ -169,12 +185,12 @@ toDSeverity SevError = Just DiagnosticSeverity_Error -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given -- (optional) locations and message strings. -diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic] -diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev)) +diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String, Maybe (MsgEnvelope GhcMessage))] -> [FileDiagnostic] +diagFromStrings diagSource sev = concatMap (uncurry3 (diagFromString diagSource sev)) -- | Produce a GHC-style error from a source span and a message. -diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic] -diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x] +diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> Maybe (MsgEnvelope GhcMessage) -> [FileDiagnostic] +diagFromString diagSource sev sp x origMsg = [diagFromText diagSource sev sp (T.pack x) origMsg] -- | Produces an "unhelpful" source span with the given string. @@ -204,13 +220,11 @@ catchSrcErrors dflags fromWhere ghcM = do Right <$> ghcM where ghcExceptionToDiagnostics = return . Left . diagFromGhcException fromWhere dflags - sourceErrorToDiagnostics = return . Left . diagFromErrMsgs fromWhere dflags - . fmap (fmap Compat.renderDiagnosticMessageWithHints) . Compat.getMessages - . srcErrorMessages - + sourceErrorToDiagnostics diag = pure $ Left $ + diagFromErrMsgs fromWhere dflags (Compat.getMessages (srcErrorMessages diag)) diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic] -diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "") (showGHCE dflags exc) +diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "") (showGHCE dflags exc) Nothing showGHCE :: DynFlags -> GhcException -> String showGHCE dflags exc = case exc of diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index f32b345c3e..c0d843042a 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -29,7 +29,7 @@ withWarnings diagSource action = do warnings <- newVar [] let newAction :: DynFlags -> LogActionCompat newAction dynFlags logFlags wr _ loc prUnqual msg = do - let wr_d = map ((wr,) . modifyFdLspDiagnostic (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags wr logFlags loc prUnqual msg + let wr_d = map ((wr,) . modifyFdLspDiagnostic (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) modifyVar_ warnings $ return . (wr_d:) newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env) res <- action $ \env -> putLogHook (newLogger env) env diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index e17c490c5a..7fa287836b 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -187,7 +187,7 @@ notFoundErr env modName reason = mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason where dfs = hsc_dflags env - mkError' = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName) + mkError' doc = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName) doc Nothing modName0 = unLoc modName ppr' = showSDoc dfs -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer. diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 6ab66f5554..98fec8157e 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -126,7 +126,7 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif -- We don't actually pass any data to resolve, however we need this -- dummy type to make sure HLS resolves our lens [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve) - | FileDiagnostic dFile _ diag@Diagnostic{_range} <- diags + | FileDiagnostic dFile _ diag@Diagnostic{_range} _ <- diags , dFile == nfp , isGlobalDiagnostic diag] -- The second option is to generate lenses from the GlobalBindingTypeSig diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index ff7309c2b9..14a31d57d4 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -8,6 +8,7 @@ module Development.IDE.Types.Diagnostics ( ShowDiagnostic(..), FileDiagnostic(..), modifyFdLspDiagnostic, + StructuredMessage(..), IdeResult, LSP.DiagnosticSeverity(..), DiagnosticStore, @@ -21,6 +22,7 @@ import Control.DeepSeq import Data.ByteString (ByteString) import Data.Maybe as Maybe import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope) import Development.IDE.Types.Location import GHC.Generics import Language.LSP.Diagnostics @@ -47,27 +49,35 @@ type IdeResult v = ([FileDiagnostic], Maybe v) -- | an IdeResult with a fingerprint type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v) -ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic -ideErrorText fdFilePath msg = - ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) fdFilePath msg +ideErrorText :: Maybe (MsgEnvelope GhcMessage) -> NormalizedFilePath -> T.Text -> FileDiagnostic +ideErrorText origMsg fdFilePath msg = + ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) fdFilePath msg origMsg ideErrorWithSource :: Maybe T.Text -> Maybe DiagnosticSeverity -> NormalizedFilePath -> T.Text + -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic -ideErrorWithSource source sev fp msg = FileDiagnostic fp ShowDiag LSP.Diagnostic { - _range = noRange, - _severity = sev, - _code = Nothing, - _source = source, - _message = msg, - _relatedInformation = Nothing, - _tags = Nothing, - _codeDescription = Nothing, - _data_ = Nothing - } +ideErrorWithSource source sev fdFilePath msg origMsg = + let fdShouldShowDiagnostic = ShowDiag + fdLspDiagnostic = + LSP.Diagnostic { + _range = noRange, + _severity = sev, + _code = Nothing, + _source = source, + _message = msg, + _relatedInformation = Nothing, + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing + } + fdStructuredMessage = + maybe NoStructuredMessage SomeStructuredMessage origMsg + in + FileDiagnostic {..} -- | Defines whether a particular diagnostic should be reported -- back to the user. @@ -94,11 +104,36 @@ data FileDiagnostic = FileDiagnostic { fdFilePath :: NormalizedFilePath , fdShouldShowDiagnostic :: ShowDiagnostic , fdLspDiagnostic :: Diagnostic + , fdStructuredMessage :: StructuredMessage } deriving (Eq, Ord, Show, Generic) instance NFData FileDiagnostic +data StructuredMessage + = NoStructuredMessage + | SomeStructuredMessage (MsgEnvelope GhcMessage) + deriving (Generic) + +instance Show StructuredMessage where + show NoStructuredMessage = "NoStructuredMessage" + show SomeStructuredMessage {} = "SomeStructuredMessage" + +instance Eq StructuredMessage where + (==) NoStructuredMessage NoStructuredMessage = True + (==) SomeStructuredMessage {} SomeStructuredMessage {} = True + (==) _ _ = False + +instance Ord StructuredMessage where + compare NoStructuredMessage NoStructuredMessage = EQ + compare SomeStructuredMessage {} SomeStructuredMessage {} = EQ + compare NoStructuredMessage SomeStructuredMessage {} = GT + compare SomeStructuredMessage {} NoStructuredMessage = LT + +instance NFData StructuredMessage where + rnf NoStructuredMessage = () + rnf SomeStructuredMessage {} = () + modifyFdLspDiagnostic :: (Diagnostic -> Diagnostic) -> FileDiagnostic -> FileDiagnostic modifyFdLspDiagnostic f diag = diag { fdLspDiagnostic = f (fdLspDiagnostic diag) } diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index d330cd4cd3..e67110dfc2 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -89,9 +89,9 @@ data OptHaddockParse = HaddockParse | NoHaddockParse deriving (Eq,Ord,Show,Enum) data IdePreprocessedSource = IdePreprocessedSource - { preprocWarnings :: [(GHC.SrcSpan, String)] + { preprocWarnings :: [(GHC.SrcSpan, String)] -- TODO: Make these warnings structured as well -- ^ Warnings emitted by the preprocessor. - , preprocErrors :: [(GHC.SrcSpan, String)] + , preprocErrors :: [(GHC.SrcSpan, String)] -- TODO: Make these errors structured as well -- ^ Errors emitted by the preprocessor. , preprocSource :: GHC.ParsedSource -- ^ New parse tree emitted by the preprocessor. From 176e626bfe338a68c5b30e2e0fa6cf367093e4a7 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 9 Jun 2024 14:32:34 +0100 Subject: [PATCH 04/44] Fix UnitTests for new FileDiagnostic struct --- ghcide/test/exe/UnitTests.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs index 68e6f3e1f0..b2940ab27f 100644 --- a/ghcide/test/exe/UnitTests.hs +++ b/ghcide/test/exe/UnitTests.hs @@ -51,7 +51,7 @@ tests = do let uri = Uri "file://" uriToFilePath' uri @?= Just "" , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do - let diag = ("", Diagnostics.ShowDiag, Diagnostic + let diag = Diagnostics.FileDiagnostic "" Diagnostics.ShowDiag Diagnostic { _codeDescription = Nothing , _data_ = Nothing , _range = Range @@ -64,7 +64,7 @@ tests = do , _message = "" , _relatedInformation = Nothing , _tags = Nothing - }) + } Diagnostics.NoStructuredMessage let shown = T.unpack (Diagnostics.showDiagnostics [diag]) let expected = "1:2-3:4" assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ From 2e03927aa51e5100733f2fee3ffb855b5a647d97 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 9 Jun 2024 16:24:12 +0100 Subject: [PATCH 05/44] Remove explicit uses of FileDiagnostic, add codes to LSP diagnostics --- .../src/Development/IDE/Core/Preprocessor.hs | 2 +- ghcide/src/Development/IDE/Core/Shake.hs | 4 +- ghcide/src/Development/IDE/GHC/Error.hs | 23 +++-------- .../src/Development/IDE/Plugin/TypeLenses.hs | 7 ++-- .../src/Development/IDE/Types/Diagnostics.hs | 39 +++++++++++++++---- 5 files changed, 45 insertions(+), 30 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index d62347e246..b3614d89ad 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -104,7 +104,7 @@ data CPPDiag diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] diagsFromCPPLogs filename logs = - map (\d -> FileDiagnostic (toNormalizedFilePath' filename) ShowDiag (cppDiagToDiagnostic d) NoStructuredMessage) $ + map (\d -> ideErrorFromLspDiag (cppDiagToDiagnostic d) (toNormalizedFilePath' filename) Nothing) $ go [] logs where -- On errors, CPP calls logAction with a real span for the initial log and diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 26c20276f6..aa5344ede7 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1356,7 +1356,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. - logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (\lspDiag -> FileDiagnostic fp ShowDiag lspDiag NoStructuredMessage) newDiags) -- TODO: Should try to get structured diagnostics plumbed here if possible + logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (\lspDiag -> ideErrorFromLspDiag lspDiag fp Nothing) newDiags) -- TODO: Should try to get structured diagnostics plumbed here if possible Just env -> LSP.runLspT env $ do liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) @@ -1423,7 +1423,7 @@ getAllDiagnostics :: STMDiagnosticStore -> STM [FileDiagnostic] getAllDiagnostics = - fmap (concatMap (\(k,v) -> map (\diag -> FileDiagnostic (fromUri k) ShowDiag diag NoStructuredMessage) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT -- TODO: Do we need the structured message here? + fmap (concatMap (\(k,v) -> map (\diag -> ideErrorFromLspDiag diag (fromUri k) Nothing) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT -- TODO: Do we need the structured message here? updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index 4c04910792..fa377b0450 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DisambiguateRecordFields #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.GHC.Error @@ -56,23 +57,11 @@ import Language.LSP.VFS (CodePointPosition (CodePoint diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic diagFromText diagSource sev loc msg origMsg = - FileDiagnostic - { fdFilePath = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc - , fdShouldShowDiagnostic = ShowDiag - , fdLspDiagnostic = - Diagnostic - { _range = fromMaybe noRange $ srcSpanToRange loc - , _severity = Just sev - , _source = Just diagSource -- not shown in the IDE, but useful for ghcide developers - , _message = msg - , _code = Nothing - , _relatedInformation = Nothing - , _tags = Nothing - , _codeDescription = Nothing - , _data_ = Nothing - } - , fdStructuredMessage = maybe NoStructuredMessage SomeStructuredMessage origMsg - } + modifyFdLspDiagnostic (\diag -> diag { D._range = fromMaybe noRange $ srcSpanToRange loc }) $ + D.ideErrorWithSource + (Just diagSource) (Just sev) + (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc) + msg origMsg -- | Produce a GHC-style error from a source span and a message. diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic] diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 98fec8157e..a0d4e13953 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -126,9 +126,10 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif -- We don't actually pass any data to resolve, however we need this -- dummy type to make sure HLS resolves our lens [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve) - | FileDiagnostic dFile _ diag@Diagnostic{_range} _ <- diags - , dFile == nfp - , isGlobalDiagnostic diag] + | diag <- diags + , let lspDiag@Diagnostic {_range} = fdLspDiagnostic diag + , fdFilePath diag == nfp + , isGlobalDiagnostic lspDiag] -- The second option is to generate lenses from the GlobalBindingTypeSig -- rule. This is the only type that needs to have the range adjusted -- with PositionMapping. diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 14a31d57d4..19c21f04c8 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -2,11 +2,16 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE CPP #-} module Development.IDE.Types.Diagnostics ( LSP.Diagnostic(..), ShowDiagnostic(..), FileDiagnostic(..), + fdFilePath, + fdShouldShowDiagnostic, + fdLspDiagnostic, + fdStructuredMessage, modifyFdLspDiagnostic, StructuredMessage(..), IdeResult, @@ -14,6 +19,7 @@ module Development.IDE.Types.Diagnostics ( DiagnosticStore, ideErrorText, ideErrorWithSource, + ideErrorFromLspDiag, showDiagnostics, showDiagnosticsColored, IdeResultNoDiagnosticsEarlyCutoff) where @@ -25,13 +31,14 @@ import qualified Data.Text as T import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope) import Development.IDE.Types.Location import GHC.Generics +import GHC.Types.Error (diagnosticCode, DiagnosticCode (..), errMsgDiagnostic) import Language.LSP.Diagnostics -import Language.LSP.Protocol.Types as LSP (Diagnostic (..), - DiagnosticSeverity (..)) +import Language.LSP.Protocol.Types as LSP import Prettyprinter import Prettyprinter.Render.Terminal (Color (..), color) import qualified Prettyprinter.Render.Terminal as Terminal import Prettyprinter.Render.Text +import Text.Printf (printf) -- | The result of an IDE operation. Warnings and errors are in the Diagnostic, @@ -53,6 +60,27 @@ ideErrorText :: Maybe (MsgEnvelope GhcMessage) -> NormalizedFilePath -> T.Text - ideErrorText origMsg fdFilePath msg = ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) fdFilePath msg origMsg +ideErrorFromLspDiag + :: LSP.Diagnostic + -> NormalizedFilePath + -> Maybe (MsgEnvelope GhcMessage) + -> FileDiagnostic +ideErrorFromLspDiag lspDiag fdFilePath origMsg = + let fdShouldShowDiagnostic = ShowDiag + fdStructuredMessage = + maybe NoStructuredMessage SomeStructuredMessage origMsg + fdLspDiagnostic = lspDiag + { _code = fmap ghcCodeToLspCode . diagnosticCode . errMsgDiagnostic =<< origMsg + } + ghcCodeToLspCode :: DiagnosticCode -> Int32 LSP.|? T.Text +#if MIN_VERSION_ghc(9,10,1) + ghcCodeToLspCode = InR . T.pack . show +#else + ghcCodeToLspCode (DiagnosticCode prefix c) = InR $ T.pack $ prefix ++ "-" ++ printf "%05d" c +#endif + in + FileDiagnostic {..} + ideErrorWithSource :: Maybe T.Text -> Maybe DiagnosticSeverity @@ -61,8 +89,7 @@ ideErrorWithSource -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic ideErrorWithSource source sev fdFilePath msg origMsg = - let fdShouldShowDiagnostic = ShowDiag - fdLspDiagnostic = + let lspDiagnostic = LSP.Diagnostic { _range = noRange, _severity = sev, @@ -74,10 +101,8 @@ ideErrorWithSource source sev fdFilePath msg origMsg = _codeDescription = Nothing, _data_ = Nothing } - fdStructuredMessage = - maybe NoStructuredMessage SomeStructuredMessage origMsg in - FileDiagnostic {..} + ideErrorFromLspDiag lspDiagnostic fdFilePath origMsg -- | Defines whether a particular diagnostic should be reported -- back to the user. From 3ce7019409deea1e82c9a2e58c53804148e739d4 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Mon, 10 Jun 2024 10:52:05 +0100 Subject: [PATCH 06/44] Add field for expected error codes in ghcide tests --- ghcide/test/exe/CPPTests.hs | 4 +- ghcide/test/exe/CradleTests.hs | 4 +- ghcide/test/exe/DependentFileTest.hs | 2 +- ghcide/test/exe/DiagnosticTests.hs | 68 +++++++++---------- .../test/exe/FindDefinitionAndHoverTests.hs | 4 +- ghcide/test/exe/GarbageCollectionTests.hs | 2 +- ghcide/test/exe/IfaceTests.hs | 26 +++---- ghcide/test/exe/PluginSimpleTests.hs | 2 +- ghcide/test/exe/PreprocessorTests.hs | 2 +- ghcide/test/exe/SymlinkTests.hs | 2 +- ghcide/test/exe/THTests.hs | 18 ++--- ghcide/test/exe/WatchedFileTests.hs | 4 +- hls-test-utils/src/Development/IDE/Test.hs | 20 +++--- .../src/Development/IDE/Test/Diagnostic.hs | 11 ++- 14 files changed, 88 insertions(+), 81 deletions(-) diff --git a/ghcide/test/exe/CPPTests.hs b/ghcide/test/exe/CPPTests.hs index 91a59adc76..671ff03cfc 100644 --- a/ghcide/test/exe/CPPTests.hs +++ b/ghcide/test/exe/CPPTests.hs @@ -42,7 +42,7 @@ tests = ," failed" ,"#endif" ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked")])] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked", Nothing)])] ] where expectError :: T.Text -> Cursor -> Session () @@ -50,7 +50,7 @@ tests = _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs", - [(DiagnosticSeverity_Error, cursor, "error: unterminated")] + [(DiagnosticSeverity_Error, cursor, "error: unterminated", Nothing)] ) ] expectNoMoreDiagnostics 0.5 diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs index bd3e351f28..f1f8ecdbdc 100644 --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -111,7 +111,7 @@ simpleSubDirectoryTest = mainSource <- liftIO $ readFileUtf8 mainPath _mdoc <- createDoc mainPath "haskell" mainSource expectDiagnosticsWithTags - [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing, Nothing)]) -- So that we know P has been loaded ] expectNoMoreDiagnostics 0.5 @@ -215,7 +215,7 @@ sessionDepsArePickedUp = testWithDummyPluginEmpty' "cradle: {direct: {arguments: []}}" -- Open without OverloadedStrings and expect an error. doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type", Nothing)])] -- Update hie.yaml to enable OverloadedStrings. liftIO $ diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index d2d19cf88d..bc636857c9 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -46,7 +46,7 @@ tests = testGroup "addDependentFile" _fooDoc <- createDoc "Foo.hs" "haskell" fooContent doc <- createDoc "Baz.hs" "haskell" bazContent expectDiagnostics - [("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type")])] + [("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type", Nothing)])] -- Now modify the dependent file liftIO $ writeFile depFilePath "B" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 660dcb3241..f1dca2ed71 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -48,7 +48,7 @@ tests = testGroup "diagnostics" [ testWithDummyPluginEmpty "fix syntax error" $ do let content = T.unlines [ "module Testing wher" ] doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error", Nothing)])] let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial { _range = Range (Position 0 15) (Position 0 19) , _rangeLength = Nothing @@ -67,18 +67,18 @@ tests = testGroup "diagnostics" , _text = "wher" } changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error", Nothing)])] , testWithDummyPluginEmpty "update syntax error" $ do let content = T.unlines [ "module Testing(missing) where" ] doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'")])] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'", Nothing)])] let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial { _range = Range (Position 0 15) (Position 0 16) , _rangeLength = Nothing , _text = "l" } changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'")])] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'", Nothing)])] , testWithDummyPluginEmpty "variable not in scope" $ do let content = T.unlines [ "module Testing where" @@ -90,8 +90,8 @@ tests = testGroup "diagnostics" _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs" - , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab") - , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd") + , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab", Nothing) + , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd", Nothing) ] ) ] @@ -104,7 +104,7 @@ tests = testGroup "diagnostics" _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs" - , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'")] + , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'", Nothing)] ) ] , testWithDummyPluginEmpty "typed hole" $ do @@ -116,7 +116,7 @@ tests = testGroup "diagnostics" _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs" - , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String")] + , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String", Nothing)] ) ] @@ -132,8 +132,8 @@ tests = testGroup "diagnostics" , "b = True"] bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" expectedDs aMessage = - [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage)]) - , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage)])] + [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage, Nothing)]) + , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage, Nothing)])] deferralTest title binding msg = testWithDummyPluginEmpty title $ do _ <- createDoc "A.hs" "haskell" $ sourceA binding _ <- createDoc "B.hs" "haskell" sourceB @@ -158,14 +158,14 @@ tests = testGroup "diagnostics" , _text = "" } changeDoc docA [change] - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 0), "Could not find module")])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 0), "Could not find module", Nothing)])] , testWithDummyPluginEmpty "add missing module" $ do let contentB = T.unlines [ "module ModuleB where" , "import ModuleA ()" ] _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module", Nothing)])] let contentA = T.unlines [ "module ModuleA where" ] _ <- createDoc "ModuleA.hs" "haskell" contentA expectDiagnostics [("ModuleB.hs", [])] @@ -185,7 +185,7 @@ tests = testGroup "diagnostics" , "import ModuleA ()" ] _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB - expectDiagnostics [(tmpDir "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + expectDiagnostics [(tmpDir "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module", Nothing)])] let contentA = T.unlines [ "module ModuleA where" ] _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA expectDiagnostics [(tmpDir "ModuleB.hs", [])] @@ -202,10 +202,10 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleB.hs" "haskell" contentB expectDiagnostics [ ( "ModuleA.hs" - , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB", Nothing)] ) , ( "ModuleB.hs" - , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB", Nothing)] ) ] , let contentA = T.unlines [ "module ModuleA where" , "import ModuleB" ] @@ -222,8 +222,8 @@ tests = testGroup "diagnostics" ]) $ do _ <- createDoc "ModuleD.hs" "haskell" contentD expectDiagnostics - [ ( "ModuleB.hs" , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]) - , ( "ModuleA.hs" , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]) + [ ( "ModuleB.hs" , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB", Nothing)]) + , ( "ModuleA.hs" , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB", Nothing)]) ] , testWithDummyPluginEmpty "cyclic module dependency with hs-boot" $ do let contentA = T.unlines @@ -243,7 +243,7 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleB.hs" "haskell" contentB _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Nothing)])] , testWithDummyPlugin "bidirectional module dependency with hs-boot" (mkIdeTestFs [directCradle ["ModuleA", "ModuleB"]]) $ do @@ -268,7 +268,7 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot _ <- createDoc "ModuleB.hs" "haskell" contentB _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Nothing)])] , testWithDummyPluginEmpty "correct reference used with hs-boot" $ do let contentB = T.unlines [ "module ModuleB where" @@ -294,7 +294,7 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot _ <- createDoc "ModuleC.hs" "haskell" contentC - expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Nothing)])] , testWithDummyPluginEmpty "redundant import" $ do let contentA = T.unlines ["module ModuleA where"] let contentB = T.unlines @@ -306,7 +306,7 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleB.hs" "haskell" contentB expectDiagnosticsWithTags [ ( "ModuleB.hs" - , [(DiagnosticSeverity_Warning, (2, 0), "The import of 'ModuleA' is redundant", Just DiagnosticTag_Unnecessary)] + , [(DiagnosticSeverity_Warning, (2, 0), "The import of 'ModuleA' is redundant", Nothing, Just DiagnosticTag_Unnecessary)] ) ] , testWithDummyPluginEmpty "redundant import even without warning" $ do @@ -320,7 +320,7 @@ tests = testGroup "diagnostics" ] _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Nothing)])] , testWithDummyPluginEmpty "package imports" $ do let thisDataListContent = T.unlines [ "module Data.List where" @@ -348,14 +348,14 @@ tests = testGroup "diagnostics" else if ghcVersion >= GHC94 then "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 else - "Not in scope: \8216ThisList.map\8217") + "Not in scope: \8216ThisList.map\8217", Nothing) ,(DiagnosticSeverity_Error, (7, 9), if ghcVersion >= GHC96 then "Variable not in scope: BaseList.x" else if ghcVersion >= GHC94 then "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 else - "Not in scope: \8216BaseList.x\8217") + "Not in scope: \8216BaseList.x\8217", Nothing) ] ) ] @@ -373,7 +373,7 @@ tests = testGroup "diagnostics" -- where appropriate. The warning should use an unqualified name 'Ord', not -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to -- test this is fairly arbitrary. - , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") + , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a", Nothing) ] ) ] @@ -439,7 +439,7 @@ tests = testGroup "diagnostics" _ <- createDoc "Foo.hs" "haskell" fooContent expectDiagnostics [ ( "Foo.hs" - , [(DiagnosticSeverity_Warning, (1, 0), "Top-level binding with no type signature:") + , [(DiagnosticSeverity_Warning, (1, 0), "Top-level binding with no type signature:", Nothing) ] ) ] @@ -453,7 +453,7 @@ tests = testGroup "diagnostics" _ <- createDoc "Foo.hs" "haskell" fooContent expectDiagnostics [ ( "Foo.hs" - , [(DiagnosticSeverity_Warning, (3, 0), "Defined but not used:") + , [(DiagnosticSeverity_Warning, (3, 0), "Defined but not used:", Nothing) ] ) ] @@ -469,13 +469,13 @@ tests = testGroup "diagnostics" bdoc <- createDoc bPath "haskell" bSource _pdoc <- createDoc pPath "haskell" pSource expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)])] -- So that we know P has been loaded -- Change y from Int to B which introduces a type error in A (imported from P) changeDoc bdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] expectDiagnostics - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)]) ] -- Open A and edit to fix the type error @@ -485,8 +485,8 @@ tests = testGroup "diagnostics" expectDiagnostics [ ( "P.hs", - [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), - (DiagnosticSeverity_Warning, (4, 0), "Top-level binding") + [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing), + (DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Nothing) ] ), ("A.hs", []) @@ -496,14 +496,14 @@ tests = testGroup "diagnostics" , testWithDummyPluginEmpty "deduplicate missing module diagnostics" $ do let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'", Nothing)])] changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ "module Foo() where" ] expectDiagnostics [] changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ T.unlines [ "module Foo() where" , "import MissingModule" ] ] - expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'", Nothing)])] , testGroup "Cancellation" [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc @@ -564,7 +564,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r ] -- for the example above we expect one warning - let missingSigDiags = [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding") ] + let missingSigDiags = [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding", Nothing) ] typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags -- Now we edit the document and wait for the given key (if any) diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index 66115c16ae..b677714ed2 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -88,8 +88,8 @@ tests = let , testGroup "hover" $ mapMaybe snd tests , testGroup "hover compile" [checkFileCompiles sourceFilePath $ expectDiagnostics - [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")]) - , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")]) + [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _", Nothing)]) + , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _", Nothing)]) ]] , testGroup "type-definition" typeDefinitionTests , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] diff --git a/ghcide/test/exe/GarbageCollectionTests.hs b/ghcide/test/exe/GarbageCollectionTests.hs index 8c0c428c1a..5e6bd0f633 100644 --- a/ghcide/test/exe/GarbageCollectionTests.hs +++ b/ghcide/test/exe/GarbageCollectionTests.hs @@ -72,7 +72,7 @@ tests = testGroup "garbage collection" changeDoc doc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument edit] builds <- waitForTypecheck doc liftIO $ assertBool "it still builds" builds - expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type")] + expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type", Nothing)] ] ] where diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs index 330d372d73..0b403845a2 100644 --- a/ghcide/test/exe/IfaceTests.hs +++ b/ghcide/test/exe/IfaceTests.hs @@ -50,8 +50,8 @@ ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do -- Check that the change propagates to C changeDoc cdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument cSource] expectDiagnostics - [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])] + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'", Nothing)]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Nothing)])] closeDoc cdoc ifaceErrorTest :: TestTree @@ -65,7 +65,7 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do bdoc <- createDoc bPath "haskell" bSource expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So what we know P has been loaded + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)])] -- So what we know P has been loaded -- Change y from Int to B changeDoc bdoc [ TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ @@ -77,7 +77,7 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do -- Check that the error propagates to A expectDiagnostics - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)])] -- Check that we wrote the interfaces for B when we saved hidir <- getInterfaceFilesDir bdoc @@ -86,7 +86,7 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do pdoc <- openDoc pPath "haskell" expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)]) ] changeDoc pdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ pSource <> "\nfoo = y :: Bool" ] -- Now in P we have @@ -98,8 +98,8 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics -- - P is being typechecked with the last successful artifacts for A. expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) - ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding")]) + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)]) + ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding", Nothing)]) ] expectNoMoreDiagnostics 2 @@ -114,7 +114,7 @@ ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do bdoc <- createDoc bPath "haskell" bSource pdoc <- createDoc pPath "haskell" pSource expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)])] -- So that we know P has been loaded -- Change y from Int to B changeDoc bdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ @@ -130,9 +130,9 @@ ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do expectDiagnostics -- As in the other test, P is being typechecked with the last successful artifacts for A -- (ot thanks to -fdeferred-type-errors) - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding")]) - ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding")]) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)]) + ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Nothing)]) + ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding", Nothing)]) ] expectNoMoreDiagnostics 2 @@ -156,7 +156,7 @@ ifaceErrorTest3 = testWithExtraFiles "iface-error-test-3" "recomp" $ \dir -> do -- In this example the interface file for A should not exist (modulo the cache folder) -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors expectDiagnostics - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)]) + ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)]) ] expectNoMoreDiagnostics 2 diff --git a/ghcide/test/exe/PluginSimpleTests.hs b/ghcide/test/exe/PluginSimpleTests.hs index 05eb76ba81..0a4616097a 100644 --- a/ghcide/test/exe/PluginSimpleTests.hs +++ b/ghcide/test/exe/PluginSimpleTests.hs @@ -41,6 +41,6 @@ tests = expectDiagnostics [ ( "KnownNat.hs", - [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c")] + [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c", Nothing)] ) ] diff --git a/ghcide/test/exe/PreprocessorTests.hs b/ghcide/test/exe/PreprocessorTests.hs index 1846a31964..81dacfa6d7 100644 --- a/ghcide/test/exe/PreprocessorTests.hs +++ b/ghcide/test/exe/PreprocessorTests.hs @@ -22,6 +22,6 @@ tests = testWithDummyPluginEmpty "preprocessor" $ do _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs", - [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z")] + [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z", Nothing)] ) ] diff --git a/ghcide/test/exe/SymlinkTests.hs b/ghcide/test/exe/SymlinkTests.hs index ade13bfc41..dda41922f0 100644 --- a/ghcide/test/exe/SymlinkTests.hs +++ b/ghcide/test/exe/SymlinkTests.hs @@ -22,6 +22,6 @@ tests = liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") let fooPath = dir "src" "Foo.hs" _ <- openDoc fooPath "haskell" - expectDiagnosticsWithTags [("src" "Foo.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of 'Sym' is redundant", Just DiagnosticTag_Unnecessary)])] + expectDiagnosticsWithTags [("src" "Foo.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of 'Sym' is redundant", Nothing, Just DiagnosticTag_Unnecessary)])] pure () ] diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs index 42a5650ed7..91ef60d2e2 100644 --- a/ghcide/test/exe/THTests.hs +++ b/ghcide/test/exe/THTests.hs @@ -43,7 +43,7 @@ tests = ] _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n")] ) ] + expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n", Nothing)] ) ] , testWithDummyPluginEmpty "newtype-closure" $ do let sourceA = T.unlines @@ -91,7 +91,7 @@ tests = , "main = $a (putStrLn \"success!\")"] _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] + expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()", Nothing)] ) ] , testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do -- This test defines a TH value with the meaning "data A = A" in A.hs @@ -102,7 +102,7 @@ tests = let cPath = dir "C.hs" _ <- openDoc cPath "haskell" - expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] + expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A", Nothing)] ) ] ] @@ -135,7 +135,7 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do bdoc <- createDoc bPath "haskell" bSource cdoc <- createDoc cPath "haskell" cSource - expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Nothing)])] -- Change th from () to Bool let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] @@ -145,9 +145,9 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do -- Check that the change propagates to C expectDiagnostics - [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding")]) - ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level bindin")]) + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'", Nothing)]) + ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding", Nothing)]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level bindin", Nothing)]) ] closeDoc adoc @@ -170,7 +170,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do adoc <- createDoc aPath "haskell" aSource bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Nothing)])] let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] changeDoc adoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument aSource'] @@ -180,7 +180,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do changeDoc bdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument bSource'] _ <- waitForDiagnostics - expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")] + expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Nothing)] closeDoc adoc closeDoc bdoc diff --git a/ghcide/test/exe/WatchedFileTests.hs b/ghcide/test/exe/WatchedFileTests.hs index d013f673a9..eebf0ada31 100644 --- a/ghcide/test/exe/WatchedFileTests.hs +++ b/ghcide/test/exe/WatchedFileTests.hs @@ -60,7 +60,7 @@ tests = testGroup "watched files" ,"a :: ()" ,"a = b" ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'", Nothing)])] -- modify B off editor liftIO $ writeFile (sessionDir "B.hs") $ unlines ["module B where" @@ -68,7 +68,7 @@ tests = testGroup "watched files" ,"b = 0"] sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri $ sessionDir "B.hs") FileChangeType_Changed ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'", Nothing)])] ] ] diff --git a/hls-test-utils/src/Development/IDE/Test.hs b/hls-test-utils/src/Development/IDE/Test.hs index 285d91aadb..8672429fd2 100644 --- a/hls-test-utils/src/Development/IDE/Test.hs +++ b/hls-test-utils/src/Development/IDE/Test.hs @@ -66,7 +66,7 @@ import Test.Tasty.HUnit requireDiagnosticM :: (Foldable f, Show (f Diagnostic), HasCallStack) => f Diagnostic - -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> (DiagnosticSeverity, Cursor, T.Text, Maybe T.Text, Maybe DiagnosticTag) -> Assertion requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of Nothing -> pure () @@ -114,25 +114,25 @@ flushMessages = do -- -- Rather than trying to assert the absence of diagnostics, introduce an -- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic. -expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () +expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text)])] -> Session () expectDiagnostics = expectDiagnosticsWithTags - . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) + . map (second (map (\(ds, c, t, code) -> (ds, c, t, code, Nothing)))) unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic]) unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics) -expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () +expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text, Maybe DiagnosticTag)])] -> Session () expectDiagnosticsWithTags expected = do - let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri + let toSessionPath = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic - expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected + expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) toSessionPath expected expectDiagnosticsWithTags' next expected' expectDiagnosticsWithTags' :: (HasCallStack, MonadIO m) => m (Uri, [Diagnostic]) -> - Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> + Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text, Maybe DiagnosticTag)] -> m () expectDiagnosticsWithTags' next m | null m = do (_,actual) <- next @@ -170,14 +170,14 @@ expectDiagnosticsWithTags' next expected = go expected <> show actual go $ Map.delete canonUri m -expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () +expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text)] -> Session () expectCurrentDiagnostics doc expected = do diags <- getCurrentDiagnostics doc checkDiagnosticsForDoc doc expected diags -checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () +checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text)] -> [Diagnostic] -> Session () checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do - let expected' = Map.singleton nuri (map (\(ds, c, t) -> (ds, c, t, Nothing)) expected) + let expected' = Map.singleton nuri (map (\(ds, c, t, code) -> (ds, c, t, code, Nothing)) expected) nuri = toNormalizedUri _uri expectDiagnosticsWithTags' (return (_uri, obtained)) expected' diff --git a/hls-test-utils/src/Development/IDE/Test/Diagnostic.hs b/hls-test-utils/src/Development/IDE/Test/Diagnostic.hs index 86c1b8bb9d..77ae9e37c1 100644 --- a/hls-test-utils/src/Development/IDE/Test/Diagnostic.hs +++ b/hls-test-utils/src/Development/IDE/Test/Diagnostic.hs @@ -17,9 +17,9 @@ type ErrorMsg = String requireDiagnostic :: (Foldable f, Show (f Diagnostic), HasCallStack) => f Diagnostic - -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> (DiagnosticSeverity, Cursor, T.Text, Maybe T.Text, Maybe DiagnosticTag) -> Maybe ErrorMsg -requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) +requireDiagnostic actuals expected@(severity, cursor, expectedMsg, mbExpectedCode, expectedTag) | any match actuals = Nothing | otherwise = Just $ "Could not find " <> show expected <> @@ -32,6 +32,13 @@ requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` standardizeQuotes (T.toLower $ d ^. message) && hasTag expectedTag (d ^. tags) + && codeMatches d + + codeMatches d = + case (mbExpectedCode, _code d) of + (Nothing, _) -> True + (Just expectedCode, Nothing) -> False + (Just expectedCode, Just actualCode) -> InR expectedCode == actualCode hasTag :: Maybe DiagnosticTag -> Maybe [DiagnosticTag] -> Bool hasTag Nothing _ = True From 11fdd875b1e56e85274a8bc82504540dc61a1596 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Mon, 10 Jun 2024 15:20:38 +0100 Subject: [PATCH 07/44] Expect GHC-83865 for "type error" test - basic test --- ghcide/test/exe/DiagnosticTests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index f1dca2ed71..a22b8bb153 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -104,7 +104,7 @@ tests = testGroup "diagnostics" _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs" - , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'", Nothing)] + , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'", Just "GHC-83865")] ) ] , testWithDummyPluginEmpty "typed hole" $ do From ac17800b133b658389e229f3da9c06f4ebf3b1ec Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Mon, 10 Jun 2024 15:25:16 +0100 Subject: [PATCH 08/44] Return structured warnings in TcModuleResult by copying from Driver --- ghcide/ghcide.cabal | 1 + ghcide/src/Development/IDE/Core/Compile.hs | 31 +++-- ghcide/src/Development/IDE/Core/RuleTypes.hs | 2 + .../src/Development/IDE/GHC/Compat/Driver.hs | 125 ++++++++++++++++++ 4 files changed, 146 insertions(+), 13 deletions(-) create mode 100644 ghcide/src/Development/IDE/GHC/Compat/Driver.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index bf88a55ed3..1df93c6bbf 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -150,6 +150,7 @@ library Development.IDE.GHC.Compat Development.IDE.GHC.Compat.Core Development.IDE.GHC.Compat.CmdLine + Development.IDE.GHC.Compat.Driver Development.IDE.GHC.Compat.Env Development.IDE.GHC.Compat.Iface Development.IDE.GHC.Compat.Logger diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index be4e0e14f2..14fd987d58 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -111,6 +111,7 @@ import qualified Data.Set as Set import qualified GHC as G import qualified GHC.Runtime.Loader as Loader import GHC.Tc.Gen.Splice +import GHC.Types.Error import GHC.Types.ForeignStubs import GHC.Types.HpcInfo import GHC.Types.TypeEnv @@ -130,6 +131,8 @@ import GHC.Unit.Module.Warnings import Development.IDE.Core.FileStore (shareFilePath) #endif +import Development.IDE.GHC.Compat.Driver (hscTypecheckRenameWithDiagnostics) + --Simple constants to make sure the source is consistently named sourceTypecheck :: T.Text sourceTypecheck = "typecheck" @@ -184,20 +187,22 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do case initialized of Left errs -> return (errs, Nothing) Right hscEnv -> do - (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak -> + etcm <- let - session = tweak (hscSetFlags dflags hscEnv) - -- TODO: maybe settings ms_hspp_opts is unnecessary? - mod_summary'' = modSummary { ms_hspp_opts = hsc_dflags session} + -- TODO: maybe setting ms_hspp_opts is unnecessary? + mod_summary' = modSummary { ms_hspp_opts = hsc_dflags session} in catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do - tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''} - let errorPipeline = unDefer . hideDiag dflags . tagDiag - diags = map errorPipeline warnings - deferredError = any fst diags + tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary'} case etcm of - Left errs -> return (map snd diags ++ errs, Nothing) - Right tcm -> return (map snd diags, Just $ tcm{tmrDeferredError = deferredError}) + Left errs -> return (errs, Nothing) + Right tcm -> + let addReason diag = map (Just (diagnosticReason (errMsgDiagnostic diag)),) $ diagFromErrMsg sourceTypecheck (hsc_dflags hscEnv) diag + errorPipeline = map (unDefer . hideDiag dflags . tagDiag) . addReason + diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm + deferredError = any fst diags + in + return (map snd diags, Just $ tcm{tmrDeferredError = deferredError}) where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id @@ -363,9 +368,9 @@ tcRnModule hsc_env tc_helpers pmod = do let ms = pm_mod_summary pmod hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env - ((tc_gbl_env', mrn_info), splices, mod_env) + (((tc_gbl_env', mrn_info), warning_messages), splices, mod_env) <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp -> - do hscTypecheckRename hscEnvTmp ms $ + do hscTypecheckRenameWithDiagnostics hscEnvTmp ms $ HsParsedModule { hpm_module = parsedSource pmod , hpm_src_files = pm_extra_src_files pmod } @@ -377,7 +382,7 @@ tcRnModule hsc_env tc_helpers pmod = do mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash) (moduleEnvToList mod_env) tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns } - pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env) + pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env warning_messages) -- Note [Clearing mi_globals after generating an iface] diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 046cc9246e..d60b61b6da 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -45,6 +45,7 @@ import Ide.Logger (Pretty (..), viaShow) import Language.LSP.Protocol.Types (Int32, NormalizedFilePath) +import GHC.Driver.Errors.Types (WarningMessages) data LinkableType = ObjectLinkable | BCOLinkable deriving (Eq,Ord,Show, Generic) @@ -157,6 +158,7 @@ data TcModuleResult = TcModuleResult -- ^ Which modules did we need at runtime while compiling this file? -- Used for recompilation checking in the presence of TH -- Stores the hash of their core file + , tmrWarnings :: WarningMessages } instance Show TcModuleResult where show = show . pm_mod_summary . tmrParsed diff --git a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs new file mode 100644 index 0000000000..acccf9b381 --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs @@ -0,0 +1,125 @@ +-- This module copies parts of the driver code in GHC.Main.Driver to provide +-- `hscTypecheckRenameWithDiagnostics`. +module Development.IDE.GHC.Compat.Driver + ( hscTypecheckRenameWithDiagnostics + ) where + +import GHC.Driver.Main +import GHC.Driver.Session +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Hs +import GHC.Hs.Dump +import GHC.Iface.Ext.Ast ( mkHieFile ) +import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) +import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result) +import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) +import GHC.Core +import GHC.Tc.Module +import GHC.Tc.Utils.Monad +import GHC.Unit +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Utils.Panic.Plain +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Logger +import GHC.Data.FastString +import GHC.Data.Maybe +import Control.Monad + +-- ----------------------------------------------------------------------------- +-- | Rename and typecheck a module the same way that GHC does, additionally returning the renamed syntax and the diagnostics produced. +hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule + -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage) +hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = runHsc' hsc_env $ + hsc_typecheck True mod_summary (Just rdr_module) + +-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack +-- b) concerning dumping rename info and hie files. It would be nice to further +-- separate this stuff out, probably in conjunction better separating renaming +-- and type checking (#17781). +hsc_typecheck :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc (TcGblEnv, RenamedStuff) +hsc_typecheck keep_rn mod_summary mb_rdr_module = do + hsc_env <- getHscEnv + let hsc_src = ms_hsc_src mod_summary + dflags = hsc_dflags hsc_env + home_unit = hsc_home_unit hsc_env + outer_mod = ms_mod mod_summary + mod_name = moduleName outer_mod + outer_mod' = mkHomeModule home_unit mod_name + inner_mod = homeModuleNameInstantiation home_unit mod_name + src_filename = ms_hspp_file mod_summary + real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + keep_rn' = gopt Opt_WriteHie dflags || keep_rn + massert (isHomeModule home_unit outer_mod) + tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) + then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc + else + do hpm <- case mb_rdr_module of + Just hpm -> return hpm + Nothing -> hscParse' mod_summary + tc_result0 <- tcRnModule' mod_summary keep_rn' hpm + if hsc_src == HsigFile + then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary + ioMsgMaybe $ hoistTcRnMessage $ + tcRnMergeSignatures hsc_env hpm tc_result0 iface + else return tc_result0 + -- TODO are we extracting anything when we merely instantiate a signature? + -- If not, try to move this into the "else" case above. + rn_info <- extract_renamed_stuff mod_summary tc_result + return (tc_result, rn_info) + +extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff +extract_renamed_stuff mod_summary tc_result = do + let rn_info = getRenamedStuff tc_result + + dflags <- getDynFlags + logger <- getLogger + liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer" + FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info) + + -- Create HIE files + when (gopt Opt_WriteHie dflags) $ do + -- I assume this fromJust is safe because `-fwrite-hie-file` + -- enables the option which keeps the renamed source. + hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) + let out_file = ml_hie_file $ ms_location mod_summary + liftIO $ writeHieFile out_file hieFile + liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + + -- Validate HIE files + when (gopt Opt_ValidateHie dflags) $ do + hs_env <- Hsc $ \e w -> return (e, w) + liftIO $ do + -- Validate Scopes + case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of + [] -> putMsg logger $ text "Got valid scopes" + xs -> do + putMsg logger $ text "Got invalid scopes" + mapM_ (putMsg logger) xs + -- Roundtrip testing + file' <- readHieFile (hsc_NC hs_env) out_file + case diffFile hieFile (hie_file_result file') of + [] -> + putMsg logger $ text "Got no roundtrip errors" + xs -> do + putMsg logger $ text "Got roundtrip errors" + let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug) + mapM_ (putMsg logger') xs + return rn_info + +-- | Generate a stripped down interface file, e.g. for boot files or when ghci +-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] +hscSimpleIface :: HscEnv + -> Maybe CoreProgram + -> TcGblEnv + -> ModSummary + -> IO (ModIface, ModDetails) +hscSimpleIface hsc_env mb_core_program tc_result summary + = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary From 59abf29ca6977b164c1dab73a4cc974a6000ecc0 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 10:45:50 +0100 Subject: [PATCH 09/44] Store FileDiagnostic instead of LSP Diagnostic in Shake store --- ghcide/src/Development/IDE/Core/Shake.hs | 38 +++++++++++++----------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index aa5344ede7..04c6dcc1b5 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -281,7 +281,7 @@ data ShakeExtras = ShakeExtras ,state :: Values ,diagnostics :: STMDiagnosticStore ,hiddenDiagnostics :: STMDiagnosticStore - ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] + ,publishedDiagnostics :: STM.Map NormalizedUri [FileDiagnostic] -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. @@ -1331,14 +1331,14 @@ updateFileDiagnostics :: MonadIO m -> ShakeExtras -> [FileDiagnostic] -- ^ current results -> m () -updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = +updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do addTag "key" (show k) let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current uri = filePathToUri' fp addTagUnsafe :: String -> String -> String -> a -> a addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v - update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic] + update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic] update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store current = map (modifyFdLspDiagnostic diagsFromRule) current0 addTag "version" (show ver) @@ -1347,8 +1347,8 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti -- published. Otherwise, we might never publish certain diagnostics if -- an exception strikes between modifyVar but before -- publishDiagnosticsNotification. - newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map fdLspDiagnostic currentShown) diagnostics - _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map fdLspDiagnostic currentHidden) hiddenDiagnostics + newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") currentShown diagnostics + _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") currentHidden hiddenDiagnostics let uri' = filePathToUri' fp let delay = if null newDiags then 0.1 else 0 registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do @@ -1356,12 +1356,12 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. - logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (\lspDiag -> ideErrorFromLspDiag lspDiag fp Nothing) newDiags) -- TODO: Should try to get structured diagnostics plumbed here if possible + logWith recorder Info $ LogDiagsDiffButNoLspEnv newDiags Just env -> LSP.runLspT env $ do liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) newDiags + LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) (map fdLspDiagnostic newDiags) return action where diagsFromRule :: Diagnostic -> Diagnostic @@ -1384,26 +1384,28 @@ actionLogger :: Action (Recorder (WithPriority Log)) actionLogger = shakeRecorder <$> getShakeExtras -------------------------------------------------------------------------------- -type STMDiagnosticStore = STM.Map NormalizedUri StoreItem +type STMDiagnosticStore = STM.Map NormalizedUri StoreItem' +data StoreItem' = StoreItem' (Maybe Int32) FileDiagnosticsBySource +type FileDiagnosticsBySource = Map.Map (Maybe T.Text) (SL.SortedList FileDiagnostic) -getDiagnosticsFromStore :: StoreItem -> [Diagnostic] -getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags +getDiagnosticsFromStore :: StoreItem' -> [FileDiagnostic] +getDiagnosticsFromStore (StoreItem' _ diags) = concatMap SL.fromSortedList $ Map.elems diags updateSTMDiagnostics :: (forall a. String -> String -> a -> a) -> STMDiagnosticStore -> NormalizedUri -> Maybe Int32 -> - DiagnosticsBySource -> - STM [LSP.Diagnostic] + FileDiagnosticsBySource -> + STM [FileDiagnostic] updateSTMDiagnostics addTag store uri mv newDiagsBySource = getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store where - update (Just(StoreItem mvs dbs)) + update (Just(StoreItem' mvs dbs)) | addTag "previous version" (show mvs) $ addTag "previous count" (show $ Prelude.length $ filter (not.null) $ Map.elems dbs) False = undefined - | mvs == mv = Just (StoreItem mv (newDiagsBySource <> dbs)) - update _ = Just (StoreItem mv newDiagsBySource) + | mvs == mv = Just (StoreItem' mv (newDiagsBySource <> dbs)) + update _ = Just (StoreItem' mv newDiagsBySource) -- | Sets the diagnostics for a file and compilation step -- if you want to clear the diagnostics call this with an empty list @@ -1412,9 +1414,9 @@ setStageDiagnostics -> NormalizedUri -> Maybe Int32 -- ^ the time that the file these diagnostics originate from was last edited -> T.Text - -> [LSP.Diagnostic] + -> [FileDiagnostic] -> STMDiagnosticStore - -> STM [LSP.Diagnostic] + -> STM [FileDiagnostic] setStageDiagnostics addTag uri ver stage diags ds = updateSTMDiagnostics addTag ds uri ver updatedDiags where !updatedDiags = Map.singleton (Just stage) $! SL.toSortedList diags @@ -1423,7 +1425,7 @@ getAllDiagnostics :: STMDiagnosticStore -> STM [FileDiagnostic] getAllDiagnostics = - fmap (concatMap (\(k,v) -> map (\diag -> ideErrorFromLspDiag diag (fromUri k) Nothing) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT -- TODO: Do we need the structured message here? + fmap (concatMap (\(_,v) -> getDiagnosticsFromStore v)) . ListT.toList . STM.listT updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = From 861170abde362f112acceeed330780d81e8278de Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 10:48:05 +0100 Subject: [PATCH 10/44] Add expected error codes for diagnostics that have them --- ghcide/test/exe/DiagnosticTests.hs | 54 +++++++++++++++--------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index a22b8bb153..615e6ad69e 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -48,7 +48,7 @@ tests = testGroup "diagnostics" [ testWithDummyPluginEmpty "fix syntax error" $ do let content = T.unlines [ "module Testing wher" ] doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error", Nothing)])] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error", Just "GHC-58481")])] let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial { _range = Range (Position 0 15) (Position 0 19) , _rangeLength = Nothing @@ -67,18 +67,18 @@ tests = testGroup "diagnostics" , _text = "wher" } changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error", Nothing)])] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error", Just "GHC-58481")])] , testWithDummyPluginEmpty "update syntax error" $ do let content = T.unlines [ "module Testing(missing) where" ] doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'", Nothing)])] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'", Just "GHC-76037")])] let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial { _range = Range (Position 0 15) (Position 0 16) , _rangeLength = Nothing , _text = "l" } changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'", Nothing)])] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'", Just "GHC-76037")])] , testWithDummyPluginEmpty "variable not in scope" $ do let content = T.unlines [ "module Testing where" @@ -90,8 +90,8 @@ tests = testGroup "diagnostics" _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs" - , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab", Nothing) - , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd", Nothing) + , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab", Just "GHC-88464") + , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd", Just "GHC-88464") ] ) ] @@ -116,7 +116,7 @@ tests = testGroup "diagnostics" _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs" - , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String", Nothing)] + , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String", Just "GHC-88464")] ) ] @@ -131,17 +131,17 @@ tests = testGroup "diagnostics" , "b :: Float" , "b = True"] bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" - expectedDs aMessage = - [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage, Nothing)]) - , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage, Nothing)])] - deferralTest title binding msg = testWithDummyPluginEmpty title $ do + expectedDs aMessage aCode = + [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage, aCode)]) + , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage, Just "GHC-83865")])] + deferralTest title binding msg code = testWithDummyPluginEmpty title $ do _ <- createDoc "A.hs" "haskell" $ sourceA binding _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics $ expectedDs msg + expectDiagnostics $ expectedDs msg code in - [ deferralTest "type error" "True" "Couldn't match expected type" - , deferralTest "typed hole" "_" "Found hole" - , deferralTest "out of scope var" "unbound" "Variable not in scope" + [ deferralTest "type error" "True" "Couldn't match expected type" (Just "GHC-83865") + , deferralTest "typed hole" "_" "Found hole" (Just "GHC-88464") + , deferralTest "out of scope var" "unbound" "Variable not in scope" (Just "GHC-88464") ] , testWithDummyPluginEmpty "remove required module" $ do @@ -243,7 +243,7 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleB.hs" "haskell" contentB _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Nothing)])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Just "GHC-38417")])] , testWithDummyPlugin "bidirectional module dependency with hs-boot" (mkIdeTestFs [directCradle ["ModuleA", "ModuleB"]]) $ do @@ -268,7 +268,7 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot _ <- createDoc "ModuleB.hs" "haskell" contentB _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Nothing)])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Just "GHC-38417")])] , testWithDummyPluginEmpty "correct reference used with hs-boot" $ do let contentB = T.unlines [ "module ModuleB where" @@ -294,7 +294,7 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot _ <- createDoc "ModuleC.hs" "haskell" contentC - expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Nothing)])] + expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Just "GHC-38417")])] , testWithDummyPluginEmpty "redundant import" $ do let contentA = T.unlines ["module ModuleA where"] let contentB = T.unlines @@ -320,7 +320,7 @@ tests = testGroup "diagnostics" ] _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Nothing)])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding", Just "GHC-38417")])] , testWithDummyPluginEmpty "package imports" $ do let thisDataListContent = T.unlines [ "module Data.List where" @@ -348,14 +348,14 @@ tests = testGroup "diagnostics" else if ghcVersion >= GHC94 then "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 else - "Not in scope: \8216ThisList.map\8217", Nothing) + "Not in scope: \8216ThisList.map\8217", Just "GHC-88464") ,(DiagnosticSeverity_Error, (7, 9), if ghcVersion >= GHC96 then "Variable not in scope: BaseList.x" else if ghcVersion >= GHC94 then "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 else - "Not in scope: \8216BaseList.x\8217", Nothing) + "Not in scope: \8216BaseList.x\8217", Just "GHC-88464") ] ) ] @@ -373,7 +373,7 @@ tests = testGroup "diagnostics" -- where appropriate. The warning should use an unqualified name 'Ord', not -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to -- test this is fairly arbitrary. - , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a", Nothing) + , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a", Just "GHC-30606") ] ) ] @@ -469,13 +469,13 @@ tests = testGroup "diagnostics" bdoc <- createDoc bPath "haskell" bSource _pdoc <- createDoc pPath "haskell" pSource expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)])] -- So that we know P has been loaded + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Just "GHC-38417")])] -- So that we know P has been loaded -- Change y from Int to B which introduces a type error in A (imported from P) changeDoc bdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] expectDiagnostics - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)]) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Just "GHC-83865")]) ] -- Open A and edit to fix the type error @@ -485,8 +485,8 @@ tests = testGroup "diagnostics" expectDiagnostics [ ( "P.hs", - [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing), - (DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Nothing) + [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'", Just "GHC-83865"), + (DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Just "GHC-38417") ] ), ("A.hs", []) @@ -564,7 +564,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r ] -- for the example above we expect one warning - let missingSigDiags = [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding", Nothing) ] + let missingSigDiags = [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding", Just "GHC-38417") ] typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags -- Now we edit the document and wait for the given key (if any) From 441a32361668485ec15bea4d2f76ebadec96a8dd Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 12:46:47 +0100 Subject: [PATCH 11/44] Dispatch TODOs, amend remaining TODOs as future work --- ghcide/session-loader/Development/IDE/Session.hs | 1 - ghcide/src/Development/IDE/GHC/Compat/Driver.hs | 2 -- ghcide/src/Development/IDE/Types/Options.hs | 4 ++-- 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 72506174e2..db8981dc66 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -878,7 +878,6 @@ newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do #if MIN_VERSION_ghc(9,6,1) let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - -- TODO: Is this the right thing to do here, to produce an error for each DriverMessage generated? closure_err_to_multi_err err = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp diff --git a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs index acccf9b381..6edf1a0125 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs @@ -70,8 +70,6 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do ioMsgMaybe $ hoistTcRnMessage $ tcRnMergeSignatures hsc_env hpm tc_result0 iface else return tc_result0 - -- TODO are we extracting anything when we merely instantiate a signature? - -- If not, try to move this into the "else" case above. rn_info <- extract_renamed_stuff mod_summary tc_result return (tc_result, rn_info) diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index e67110dfc2..be3ea20932 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -89,9 +89,9 @@ data OptHaddockParse = HaddockParse | NoHaddockParse deriving (Eq,Ord,Show,Enum) data IdePreprocessedSource = IdePreprocessedSource - { preprocWarnings :: [(GHC.SrcSpan, String)] -- TODO: Make these warnings structured as well + { preprocWarnings :: [(GHC.SrcSpan, String)] -- TODO: Future work could we make these warnings structured as well? -- ^ Warnings emitted by the preprocessor. - , preprocErrors :: [(GHC.SrcSpan, String)] -- TODO: Make these errors structured as well + , preprocErrors :: [(GHC.SrcSpan, String)] -- TODO: Future work could we make these errors structured as well? -- ^ Errors emitted by the preprocessor. , preprocSource :: GHC.ParsedSource -- ^ New parse tree emitted by the preprocessor. From 34618b886abdc7434c479eed3cb2eb4a4b04cb1f Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 14:03:46 +0100 Subject: [PATCH 12/44] Add scary comments all over copied code in Compat.Driver --- .../src/Development/IDE/GHC/Compat/Driver.hs | 23 +++++++++++-------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs index 6edf1a0125..4cff8e9a26 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs @@ -1,5 +1,9 @@ --- This module copies parts of the driver code in GHC.Main.Driver to provide +-- ============================================================================ +-- DO NOT EDIT +-- This module copies parts of the driver code in GHC.Driver.Main to provide -- `hscTypecheckRenameWithDiagnostics`. +-- ============================================================================ + module Development.IDE.GHC.Compat.Driver ( hscTypecheckRenameWithDiagnostics ) where @@ -31,17 +35,14 @@ import GHC.Data.FastString import GHC.Data.Maybe import Control.Monad --- ----------------------------------------------------------------------------- --- | Rename and typecheck a module the same way that GHC does, additionally returning the renamed syntax and the diagnostics produced. hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage) hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = runHsc' hsc_env $ hsc_typecheck True mod_summary (Just rdr_module) --- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack --- b) concerning dumping rename info and hie files. It would be nice to further --- separate this stuff out, probably in conjunction better separating renaming --- and type checking (#17781). +-- ============================================================================ +-- DO NOT EDIT - Refer to top of file +-- ============================================================================ hsc_typecheck :: Bool -- ^ Keep renamed source? -> ModSummary -> Maybe HsParsedModule -> Hsc (TcGblEnv, RenamedStuff) @@ -73,6 +74,9 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do rn_info <- extract_renamed_stuff mod_summary tc_result return (tc_result, rn_info) +-- ============================================================================ +-- DO NOT EDIT - Refer to top of file +-- ============================================================================ extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff extract_renamed_stuff mod_summary tc_result = do let rn_info = getRenamedStuff tc_result @@ -112,8 +116,9 @@ extract_renamed_stuff mod_summary tc_result = do mapM_ (putMsg logger') xs return rn_info --- | Generate a stripped down interface file, e.g. for boot files or when ghci --- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] +-- ============================================================================ +-- DO NOT EDIT - Refer to top of file +-- ============================================================================ hscSimpleIface :: HscEnv -> Maybe CoreProgram -> TcGblEnv From a1769a8ab94858c23d06f627a09d8063801fa2ec Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 14:04:23 +0100 Subject: [PATCH 13/44] Update all remaining diagnostics that could use an expected error code --- ghcide/test/exe/CPPTests.hs | 2 +- ghcide/test/exe/CradleTests.hs | 4 +-- ghcide/test/exe/DependentFileTest.hs | 2 +- .../test/exe/FindDefinitionAndHoverTests.hs | 4 +-- ghcide/test/exe/GarbageCollectionTests.hs | 2 +- ghcide/test/exe/IfaceTests.hs | 26 +++++++++---------- ghcide/test/exe/PluginSimpleTests.hs | 2 +- ghcide/test/exe/PreprocessorTests.hs | 2 +- ghcide/test/exe/THTests.hs | 18 ++++++------- ghcide/test/exe/WatchedFileTests.hs | 4 +-- 10 files changed, 33 insertions(+), 33 deletions(-) diff --git a/ghcide/test/exe/CPPTests.hs b/ghcide/test/exe/CPPTests.hs index 671ff03cfc..762e6632f1 100644 --- a/ghcide/test/exe/CPPTests.hs +++ b/ghcide/test/exe/CPPTests.hs @@ -42,7 +42,7 @@ tests = ," failed" ,"#endif" ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked", Nothing)])] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked", Just "GHC-88464")])] ] where expectError :: T.Text -> Cursor -> Session () diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs index f1f8ecdbdc..046b8bbf2f 100644 --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -111,7 +111,7 @@ simpleSubDirectoryTest = mainSource <- liftIO $ readFileUtf8 mainPath _mdoc <- createDoc mainPath "haskell" mainSource expectDiagnosticsWithTags - [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing, Nothing)]) -- So that we know P has been loaded + [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Just "GHC-38417", Nothing)]) -- So that we know P has been loaded ] expectNoMoreDiagnostics 0.5 @@ -215,7 +215,7 @@ sessionDepsArePickedUp = testWithDummyPluginEmpty' "cradle: {direct: {arguments: []}}" -- Open without OverloadedStrings and expect an error. doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type", Nothing)])] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type", Just "GHC-83865")])] -- Update hie.yaml to enable OverloadedStrings. liftIO $ diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index bc636857c9..1f243819e3 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -46,7 +46,7 @@ tests = testGroup "addDependentFile" _fooDoc <- createDoc "Foo.hs" "haskell" fooContent doc <- createDoc "Baz.hs" "haskell" bazContent expectDiagnostics - [("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type", Nothing)])] + [("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type", Just "GHC-83865")])] -- Now modify the dependent file liftIO $ writeFile depFilePath "B" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index b677714ed2..b6068aac12 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -88,8 +88,8 @@ tests = let , testGroup "hover" $ mapMaybe snd tests , testGroup "hover compile" [checkFileCompiles sourceFilePath $ expectDiagnostics - [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _", Nothing)]) - , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _", Nothing)]) + [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _", Just "GHC-88464")]) + , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _", Just "GHC-88464")]) ]] , testGroup "type-definition" typeDefinitionTests , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] diff --git a/ghcide/test/exe/GarbageCollectionTests.hs b/ghcide/test/exe/GarbageCollectionTests.hs index 5e6bd0f633..5cc9935352 100644 --- a/ghcide/test/exe/GarbageCollectionTests.hs +++ b/ghcide/test/exe/GarbageCollectionTests.hs @@ -72,7 +72,7 @@ tests = testGroup "garbage collection" changeDoc doc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument edit] builds <- waitForTypecheck doc liftIO $ assertBool "it still builds" builds - expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type", Nothing)] + expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type", Just "GHC-83865")] ] ] where diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs index 0b403845a2..d7dc533550 100644 --- a/ghcide/test/exe/IfaceTests.hs +++ b/ghcide/test/exe/IfaceTests.hs @@ -50,8 +50,8 @@ ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do -- Check that the change propagates to C changeDoc cdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument cSource] expectDiagnostics - [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'", Nothing)]) - ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Nothing)])] + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'", Just "GHC-83865")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")])] closeDoc cdoc ifaceErrorTest :: TestTree @@ -65,7 +65,7 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do bdoc <- createDoc bPath "haskell" bSource expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)])] -- So what we know P has been loaded + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Just "GHC-38417")])] -- So what we know P has been loaded -- Change y from Int to B changeDoc bdoc [ TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ @@ -77,7 +77,7 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do -- Check that the error propagates to A expectDiagnostics - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)])] + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Just "GHC-83865")])] -- Check that we wrote the interfaces for B when we saved hidir <- getInterfaceFilesDir bdoc @@ -86,7 +86,7 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do pdoc <- openDoc pPath "haskell" expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)]) + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Just "GHC-38417")]) ] changeDoc pdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ pSource <> "\nfoo = y :: Bool" ] -- Now in P we have @@ -98,8 +98,8 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics -- - P is being typechecked with the last successful artifacts for A. expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)]) - ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding", Nothing)]) + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Just "GHC-38417")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding", Just "GHC-38417")]) ] expectNoMoreDiagnostics 2 @@ -114,7 +114,7 @@ ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do bdoc <- createDoc bPath "haskell" bSource pdoc <- createDoc pPath "haskell" pSource expectDiagnostics - [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)])] -- So that we know P has been loaded + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Just "GHC-38417")])] -- So that we know P has been loaded -- Change y from Int to B changeDoc bdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ @@ -130,9 +130,9 @@ ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do expectDiagnostics -- As in the other test, P is being typechecked with the last successful artifacts for A -- (ot thanks to -fdeferred-type-errors) - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)]) - ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Nothing)]) - ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding", Nothing)]) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Just "GHC-83865")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Just "GHC-38417")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding", Just "GHC-38417")]) ] expectNoMoreDiagnostics 2 @@ -156,7 +156,7 @@ ifaceErrorTest3 = testWithExtraFiles "iface-error-test-3" "recomp" $ \dir -> do -- In this example the interface file for A should not exist (modulo the cache folder) -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors expectDiagnostics - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Nothing)]) - ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Nothing)]) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'", Just "GHC-83865")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Just "GHC-38417")]) ] expectNoMoreDiagnostics 2 diff --git a/ghcide/test/exe/PluginSimpleTests.hs b/ghcide/test/exe/PluginSimpleTests.hs index 0a4616097a..c160d2461c 100644 --- a/ghcide/test/exe/PluginSimpleTests.hs +++ b/ghcide/test/exe/PluginSimpleTests.hs @@ -41,6 +41,6 @@ tests = expectDiagnostics [ ( "KnownNat.hs", - [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c", Nothing)] + [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c", Just "GHC-88464")] ) ] diff --git a/ghcide/test/exe/PreprocessorTests.hs b/ghcide/test/exe/PreprocessorTests.hs index 81dacfa6d7..dbbbdc9bc7 100644 --- a/ghcide/test/exe/PreprocessorTests.hs +++ b/ghcide/test/exe/PreprocessorTests.hs @@ -22,6 +22,6 @@ tests = testWithDummyPluginEmpty "preprocessor" $ do _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs", - [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z", Nothing)] + [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z", Just "GHC-88464")] ) ] diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs index 91ef60d2e2..59b06431f5 100644 --- a/ghcide/test/exe/THTests.hs +++ b/ghcide/test/exe/THTests.hs @@ -43,7 +43,7 @@ tests = ] _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n", Nothing)] ) ] + expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n", Just "GHC-88464")] ) ] , testWithDummyPluginEmpty "newtype-closure" $ do let sourceA = T.unlines @@ -91,7 +91,7 @@ tests = , "main = $a (putStrLn \"success!\")"] _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()", Nothing)] ) ] + expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()", Just "GHC-38417")] ) ] , testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do -- This test defines a TH value with the meaning "data A = A" in A.hs @@ -102,7 +102,7 @@ tests = let cPath = dir "C.hs" _ <- openDoc cPath "haskell" - expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A", Nothing)] ) ] + expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A", Just "GHC-38417")] ) ] ] @@ -135,7 +135,7 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do bdoc <- createDoc bPath "haskell" bSource cdoc <- createDoc cPath "haskell" cSource - expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Nothing)])] + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")])] -- Change th from () to Bool let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] @@ -145,9 +145,9 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do -- Check that the change propagates to C expectDiagnostics - [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'", Nothing)]) - ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding", Nothing)]) - ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level bindin", Nothing)]) + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'", Just "GHC-83865")]) + ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding", Just "GHC-38417")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level bindin", Just "GHC-38417")]) ] closeDoc adoc @@ -170,7 +170,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do adoc <- createDoc aPath "haskell" aSource bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Nothing)])] + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")])] let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] changeDoc adoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument aSource'] @@ -180,7 +180,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do changeDoc bdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument bSource'] _ <- waitForDiagnostics - expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Nothing)] + expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")] closeDoc adoc closeDoc bdoc diff --git a/ghcide/test/exe/WatchedFileTests.hs b/ghcide/test/exe/WatchedFileTests.hs index eebf0ada31..d89a4ca84b 100644 --- a/ghcide/test/exe/WatchedFileTests.hs +++ b/ghcide/test/exe/WatchedFileTests.hs @@ -60,7 +60,7 @@ tests = testGroup "watched files" ,"a :: ()" ,"a = b" ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'", Nothing)])] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'", Just "GHC-83865")])] -- modify B off editor liftIO $ writeFile (sessionDir "B.hs") $ unlines ["module B where" @@ -68,7 +68,7 @@ tests = testGroup "watched files" ,"b = 0"] sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri $ sessionDir "B.hs") FileChangeType_Changed ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'", Nothing)])] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'", Just "GHC-83865")])] ] ] From ac5b8bbf820d4bfb6e0f7c5d7e0ab1d23e85c509 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 14:12:52 +0100 Subject: [PATCH 14/44] Add _code to pretty printing for FileDiagnostic --- ghcide/src/Development/IDE/Types/Diagnostics.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 19c21f04c8..a32437e703 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -188,6 +188,10 @@ prettyDiagnostic FileDiagnostic { fdFilePath, fdShouldShowDiagnostic, fdLspDiagn , slabel_ "Range: " $ prettyRange _range , slabel_ "Source: " $ pretty _source , slabel_ "Severity:" $ pretty $ show sev + , slabel_ "Code: " $ case _code of + Just (InR text) -> pretty text + Just (InL i) -> pretty i + Nothing -> "" , slabel_ "Message: " $ case sev of LSP.DiagnosticSeverity_Error -> annotate $ color Red From 7b8f271a0a69d0b326c11de523fc9d315475d1d3 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 14:43:02 +0100 Subject: [PATCH 15/44] Use case instead of `maybe` for StructuredMessage match --- ghcide/src/Development/IDE/Types/Diagnostics.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index a32437e703..7dedbf61a9 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -68,7 +68,9 @@ ideErrorFromLspDiag ideErrorFromLspDiag lspDiag fdFilePath origMsg = let fdShouldShowDiagnostic = ShowDiag fdStructuredMessage = - maybe NoStructuredMessage SomeStructuredMessage origMsg + case origMsg of + Nothing -> NoStructuredMessage + Just msg -> SomeStructuredMessage msg fdLspDiagnostic = lspDiag { _code = fmap ghcCodeToLspCode . diagnosticCode . errMsgDiagnostic =<< origMsg } From 037ca0a80cd84d50a787baf305721f140b118ca8 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 14:43:41 +0100 Subject: [PATCH 16/44] Use CPP to prevent setting _code before structured errors --- ghcide/src/Development/IDE/Types/Diagnostics.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 7dedbf61a9..5d21151e4d 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -72,12 +72,16 @@ ideErrorFromLspDiag lspDiag fdFilePath origMsg = Nothing -> NoStructuredMessage Just msg -> SomeStructuredMessage msg fdLspDiagnostic = lspDiag +#if MIN_VERSION_ghc(9,6,1) { _code = fmap ghcCodeToLspCode . diagnosticCode . errMsgDiagnostic =<< origMsg } +#endif +#if MIN_VERSION_ghc(9,8,1) ghcCodeToLspCode :: DiagnosticCode -> Int32 LSP.|? T.Text -#if MIN_VERSION_ghc(9,10,1) ghcCodeToLspCode = InR . T.pack . show -#else +#elif MIN_VERSION_ghc(9,6,1) + -- DiagnosticCode only got a show instance in 9.8.1 + ghcCodeToLspCode :: DiagnosticCode -> Int32 LSP.|? T.Text ghcCodeToLspCode (DiagnosticCode prefix c) = InR $ T.pack $ prefix ++ "-" ++ printf "%05d" c #endif in From 8662431946703b10b681f08ea16a07425fe8c350 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 14:45:02 +0100 Subject: [PATCH 17/44] Swap modifier for lenses, document StructuredMessage type --- .../Development/IDE/Session/Diagnostics.hs | 3 +- ghcide/src/Development/IDE/Core/Compile.hs | 11 +++-- ghcide/src/Development/IDE/Core/Rules.hs | 5 +- ghcide/src/Development/IDE/Core/Shake.hs | 4 +- ghcide/src/Development/IDE/GHC/Error.hs | 11 +++-- ghcide/src/Development/IDE/GHC/Warnings.hs | 3 +- .../src/Development/IDE/Types/Diagnostics.hs | 49 ++++++++++--------- 7 files changed, 46 insertions(+), 40 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index b377824f79..ac98ae453d 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -2,6 +2,7 @@ module Development.IDE.Session.Diagnostics where import Control.Applicative +import Control.Lens import Control.Monad import qualified Data.Aeson as Aeson import Data.List @@ -32,7 +33,7 @@ renderCradleError (CradleError deps _ec ms) cradle nfp = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing in if HieBios.isCabalCradle cradle - then flip modifyFdLspDiagnostic noDetails $ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}} + then noDetails & fdLspDiagnosticL %~ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}} else noDetails where absDeps = fmap (cradleRootDir cradle ) deps diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 14fd987d58..f94913d896 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -676,8 +676,9 @@ unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True unDefer ( _ , fd) = (False, fd) upgradeWarningToError :: FileDiagnostic -> FileDiagnostic -upgradeWarningToError fd = - modifyFdLspDiagnostic (\diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag}) fd where +upgradeWarningToError = + fdLspDiagnosticL %~ \diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag} + where warn2err :: T.Text -> T.Text warn2err = T.intercalate ": error:" . T.splitOn ": warning:" @@ -710,14 +711,14 @@ tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, #if MIN_VERSION_ghc(9,7,0) tagDiag (w@(Just (WarningWithCategory cat)), fd) | cat == defaultWarningCategory -- default warning category is for deprecations - = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) }) fd) + = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) }) tagDiag (w@(Just (WarningWithFlags warnings)), fd) | tags <- mapMaybe requiresTag (toList warnings) - = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tags ++ concat (_tags diag) }) fd) + = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tags ++ concat (_tags diag) }) #else tagDiag (w@(Just (WarningWithFlag warning)), fd) | Just tag <- requiresTag warning - = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tag : concat (_tags diag) }) fd) + = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tag : concat (_tags diag) }) #endif where requiresTag :: WarningFlag -> Maybe DiagnosticTag diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 0adbf96977..fe15646982 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -64,6 +64,7 @@ import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception (evaluate) import Control.Exception.Safe +import Control.Lens ((%~), (&)) import Control.Monad.Extra import Control.Monad.IO.Unlift import Control.Monad.Reader @@ -487,8 +488,8 @@ reportImportCyclesRule recorder = | f `elem` fs = Just (imp, fs) cycleErrorInFile _ _ = Nothing toDiag imp mods = - modifyFdLspDiagnostic (\lspDiag -> lspDiag { _range = rng }) - $ ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing + ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing + & fdLspDiagnosticL %~ \lspDiag -> (lspDiag { _range = rng } :: Diagnostic) where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) getModuleName file = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 04c6dcc1b5..42280ad418 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -83,7 +83,7 @@ import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Extra hiding (bracket_) -import Control.Lens ((&), (?~)) +import Control.Lens ((&), (?~), (%~)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader @@ -1340,7 +1340,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic] update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store - current = map (modifyFdLspDiagnostic diagsFromRule) current0 + current = map (fdLspDiagnosticL %~ diagsFromRule) current0 addTag "version" (show ver) mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index fa377b0450..daf5cee7ac 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -36,6 +36,7 @@ module Development.IDE.GHC.Error , toDSeverity ) where +import Control.Lens import Data.Maybe import Data.String (fromString) import qualified Data.Text as T @@ -57,11 +58,11 @@ import Language.LSP.VFS (CodePointPosition (CodePoint diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic diagFromText diagSource sev loc msg origMsg = - modifyFdLspDiagnostic (\diag -> diag { D._range = fromMaybe noRange $ srcSpanToRange loc }) $ - D.ideErrorWithSource - (Just diagSource) (Just sev) - (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc) - msg origMsg + D.ideErrorWithSource + (Just diagSource) (Just sev) + (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc) + msg origMsg + & fdLspDiagnosticL %~ \diag -> diag { D._range = fromMaybe noRange $ srcSpanToRange loc } -- | Produce a GHC-style error from a source span and a message. diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic] diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index c0d843042a..5b2489c4e8 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -6,6 +6,7 @@ module Development.IDE.GHC.Warnings(withWarnings) where import Control.Concurrent.Strict +import Control.Lens (over) import Data.List import qualified Data.Text as T @@ -29,7 +30,7 @@ withWarnings diagSource action = do warnings <- newVar [] let newAction :: DynFlags -> LogActionCompat newAction dynFlags logFlags wr _ loc prUnqual msg = do - let wr_d = map ((wr,) . modifyFdLspDiagnostic (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) + let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) modifyVar_ warnings $ return . (wr_d:) newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env) res <- action $ \env -> putLogHook (newLogger env) env diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 5d21151e4d..9f8a131420 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -2,17 +2,14 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Development.IDE.Types.Diagnostics ( LSP.Diagnostic(..), ShowDiagnostic(..), FileDiagnostic(..), - fdFilePath, - fdShouldShowDiagnostic, - fdLspDiagnostic, - fdStructuredMessage, - modifyFdLspDiagnostic, + fdLspDiagnosticL, StructuredMessage(..), IdeResult, LSP.DiagnosticSeverity(..), @@ -25,6 +22,7 @@ module Development.IDE.Types.Diagnostics ( IdeResultNoDiagnosticsEarlyCutoff) where import Control.DeepSeq +import Control.Lens import Data.ByteString (ByteString) import Data.Maybe as Maybe import qualified Data.Text as T @@ -125,22 +123,9 @@ data ShowDiagnostic instance NFData ShowDiagnostic where rnf = rwhnf --- | Human readable diagnostics for a specific file. --- --- This type packages a pretty printed, human readable error message --- along with the related source location so that we can display the error --- on either the console or in the IDE at the right source location. --- -data FileDiagnostic = FileDiagnostic - { fdFilePath :: NormalizedFilePath - , fdShouldShowDiagnostic :: ShowDiagnostic - , fdLspDiagnostic :: Diagnostic - , fdStructuredMessage :: StructuredMessage - } - deriving (Eq, Ord, Show, Generic) - -instance NFData FileDiagnostic - +-- | A Maybe-like wrapper for a GhcMessage that doesn't try to compare, show, or +-- force the GhcMessage inside, so that we can derive Show, Eq, Ord, NFData on +-- FileDiagnostic data StructuredMessage = NoStructuredMessage | SomeStructuredMessage (MsgEnvelope GhcMessage) @@ -165,9 +150,25 @@ instance NFData StructuredMessage where rnf NoStructuredMessage = () rnf SomeStructuredMessage {} = () -modifyFdLspDiagnostic :: (Diagnostic -> Diagnostic) -> FileDiagnostic -> FileDiagnostic -modifyFdLspDiagnostic f diag = - diag { fdLspDiagnostic = f (fdLspDiagnostic diag) } +-- | Human readable diagnostics for a specific file. +-- +-- This type packages a pretty printed, human readable error message +-- along with the related source location so that we can display the error +-- on either the console or in the IDE at the right source location. +-- +data FileDiagnostic = FileDiagnostic + { fdFilePath :: NormalizedFilePath + , fdShouldShowDiagnostic :: ShowDiagnostic + , fdLspDiagnostic :: Diagnostic + , fdStructuredMessage :: StructuredMessage + } + deriving (Eq, Ord, Show, Generic) + +instance NFData FileDiagnostic + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''FileDiagnostic prettyRange :: Range -> Doc Terminal.AnsiStyle prettyRange Range{..} = f _start <> "-" <> f _end From 676ef8fdeab552a81898b912ebbdb7284f71759a Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 15:06:54 +0100 Subject: [PATCH 18/44] Add link to Issue & MR to Compat.Driver --- ghcide/src/Development/IDE/GHC/Compat/Driver.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs index 4cff8e9a26..229dd45d57 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs @@ -2,6 +2,8 @@ -- DO NOT EDIT -- This module copies parts of the driver code in GHC.Driver.Main to provide -- `hscTypecheckRenameWithDiagnostics`. +-- Issue to add this function: https://gitlab.haskell.org/ghc/ghc/-/issues/24996 +-- MR to add this function: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12891 -- ============================================================================ module Development.IDE.GHC.Compat.Driver From 6b5b043403222d08c7d5999a2c6c9e290d4036c8 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 15:16:58 +0100 Subject: [PATCH 19/44] Drop attachReason logic from withWarnings, technically incorrect --- ghcide/src/Development/IDE/GHC/Warnings.hs | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 5b2489c4e8..c44c1d1704 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -6,14 +6,11 @@ module Development.IDE.GHC.Warnings(withWarnings) where import Control.Concurrent.Strict -import Control.Lens (over) -import Data.List import qualified Data.Text as T import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics -import Language.LSP.Protocol.Types (type (|?) (..)) -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some @@ -30,20 +27,9 @@ withWarnings diagSource action = do warnings <- newVar [] let newAction :: DynFlags -> LogActionCompat newAction dynFlags logFlags wr _ loc prUnqual msg = do - let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) + let wr_d = map (wr,) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) modifyVar_ warnings $ return . (wr_d:) newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env) res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res) - -attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic -attachReason Nothing d = d -attachReason (Just wr) d = d{_code = InR <$> showReason wr} - where - showReason = \case - WarningWithFlag flag -> showFlag flag - _ -> Nothing - -showFlag :: WarningFlag -> Maybe T.Text -showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags From 36fd84e0b68641ef39617c04a4cd7b4fc83706fd Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 15:23:09 +0100 Subject: [PATCH 20/44] Revert "Drop attachReason logic", needed by pragmas-plugin This reverts commit 4fed9877f7748c4abd8f4f88686e102206f86ed7. --- ghcide/src/Development/IDE/GHC/Warnings.hs | 26 +++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index c44c1d1704..77decfc0d9 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -6,11 +6,14 @@ module Development.IDE.GHC.Warnings(withWarnings) where import Control.Concurrent.Strict +import Control.Lens (over) +import Data.List import qualified Data.Text as T import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics +import Language.LSP.Protocol.Types (type (|?) (..)) -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some @@ -27,9 +30,30 @@ withWarnings diagSource action = do warnings <- newVar [] let newAction :: DynFlags -> LogActionCompat newAction dynFlags logFlags wr _ loc prUnqual msg = do - let wr_d = map (wr,) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) + let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) modifyVar_ warnings $ return . (wr_d:) newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env) res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res) + +#if MIN_VERSION_ghc(9,3,0) +attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic +attachReason Nothing d = d +attachReason (Just wr) d = d{_code = InR <$> showReason wr} + where + showReason = \case + WarningWithFlag flag -> showFlag flag + _ -> Nothing +#else +attachReason :: WarnReason -> Diagnostic -> Diagnostic +attachReason wr d = d{_code = InR <$> showReason wr} + where + showReason = \case + NoReason -> Nothing + Reason flag -> showFlag flag + ErrReason flag -> showFlag =<< flag +#endif + +showFlag :: WarningFlag -> Maybe T.Text +showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags From 2868e8352be4513dc971b26bb6c50fe32af71fbf Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 18:07:23 +0100 Subject: [PATCH 21/44] Fix plugins where necessary for new diagnostic structure --- .../src/Ide/Plugin/Cabal/Diagnostics.hs | 23 +++++++------- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 12 ++++---- .../src/Development/IDE/Plugin/CodeAction.hs | 3 +- .../hls-stan-plugin/src/Ide/Plugin/Stan.hs | 30 ++++++++++--------- 4 files changed, 36 insertions(+), 32 deletions(-) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs index 26156c5131..6824985adb 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -11,9 +11,11 @@ module Ide.Plugin.Cabal.Diagnostics ) where +import Control.Lens ((.~), (&)) import qualified Data.Text as T import Development.IDE (FileDiagnostic, ShowDiagnostic (ShowDiag)) +import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, ideErrorWithSource) import Distribution.Fields (showPError, showPWarning) import qualified Distribution.Parsec as Syntax import Ide.PluginUtils (extendNextLine) @@ -23,6 +25,7 @@ import Language.LSP.Protocol.Types (Diagnostic (..), Position (Position), Range (Range), fromNormalizedFilePath) +import Language.LSP.Protocol.Lens (range) -- | Produce a diagnostic for a fatal Cabal parser error. fatalParseErrorDiagnostic :: NormalizedFilePath -> T.Text -> FileDiagnostic @@ -79,15 +82,11 @@ mkDiag -> T.Text -- ^ The message displayed by the editor -> FileDiagnostic -mkDiag file diagSource sev loc msg = (file, ShowDiag,) - Diagnostic - { _range = loc - , _severity = Just sev - , _source = Just diagSource - , _message = msg - , _code = Nothing - , _tags = Nothing - , _relatedInformation = Nothing - , _codeDescription = Nothing - , _data_ = Nothing - } +mkDiag file diagSource sev loc msg = + ideErrorWithSource + (Just diagSource) + (Just sev) + file + msg + Nothing + & fdLspDiagnosticL . range .~ loc diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index b1c88210ad..14c43f8db8 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -211,9 +211,9 @@ rules recorder plugin = do diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic] diagnostics file (Right ideas) = - (file, ShowDiag,) <$> catMaybes [ideaToDiagnostic i | i <- ideas] + [ideErrorFromLspDiag diag file Nothing | i <- ideas, Just diag <- [ideaToDiagnostic i]] diagnostics file (Left parseErr) = - [(file, ShowDiag, parseErrorToDiagnostic parseErr)] + [ideErrorFromLspDiag (parseErrorToDiagnostic parseErr) file Nothing] ideaToDiagnostic :: Idea -> Maybe Diagnostic @@ -371,9 +371,11 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context allDiagnostics <- atomically $ getDiagnostics ideState let numHintsInDoc = length - [diagnostic | (diagnosticNormalizedFilePath, _, diagnostic) <- allDiagnostics - , validCommand diagnostic - , diagnosticNormalizedFilePath == docNormalizedFilePath + [lspDiagnostic + | diag <- allDiagnostics + , let lspDiagnostic = fdLspDiagnostic diag + , validCommand lspDiagnostic + , fdFilePath diag == docNormalizedFilePath ] let numHintsInContext = length [diagnostic | diagnostic <- diags diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index e52349b3ac..5bf93f9105 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -68,6 +68,7 @@ import Development.IDE.Plugin.TypeLenses (suggestSigna import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options +import Development.IDE.Types.Diagnostics import GHC (AddEpAnn (AddEpAnn), AnnsModule (am_main), DeltaPos (..), @@ -125,7 +126,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = contents <- liftIO $ runAction "hls-refactor-plugin.codeAction.getUriContents" state $ getUriContents $ toNormalizedUri uri liftIO $ do let mbFile = toNormalizedFilePath' <$> uriToFilePath uri - allDiags <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state + allDiags <- atomically $ fmap fdLspDiagnostic . filter (\d -> mbFile == Just (fdFilePath d)) <$> getDiagnostics state (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile let textContents = fmap Rope.toText contents diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index 757768a574..5841f56405 100644 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -12,6 +12,7 @@ import qualified Data.HashMap.Strict as HM import Data.Maybe (mapMaybe) import qualified Data.Text as T import Development.IDE +import Development.IDE.Types.Diagnostics import Development.IDE.Core.Rules (getHieFile) import qualified Development.IDE.Core.Shake as Shake import GHC.Generics (Generic) @@ -187,17 +188,18 @@ rules recorder plId = do "Possible solutions:" ] ++ map (" - " <>) (inspectionSolution inspection) - return ( file, - ShowDiag, - LSP.Diagnostic - { _range = realSrcSpanToRange observationSrcSpan, - _severity = Just LSP.DiagnosticSeverity_Hint, - _code = Just (LSP.InR $ unId (inspectionId inspection)), - _source = Just "stan", - _message = message, - _relatedInformation = Nothing, - _tags = Nothing, - _codeDescription = Nothing, - _data_ = Nothing - } - ) + return $ + ideErrorFromLspDiag + LSP.Diagnostic + { _range = realSrcSpanToRange observationSrcSpan, + _severity = Just LSP.DiagnosticSeverity_Hint, + _code = Just (LSP.InR $ unId (inspectionId inspection)), + _source = Just "stan", + _message = message, + _relatedInformation = Nothing, + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing + } + file + Nothing From 7d4cf38916805d74fce9d6ae83e0e611dec0feb2 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 16 Jun 2024 22:58:39 +0100 Subject: [PATCH 22/44] Fix build issues with other tests from `expectDiagnostics` --- ghcide-bench/src/Experiments.hs | 2 +- plugins/hls-refactor-plugin/test/Main.hs | 34 ++++++++++++------------ test/functional/Config.hs | 6 ++--- 3 files changed, 21 insertions(+), 21 deletions(-) diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 525f07a37d..40c064e4d6 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -266,7 +266,7 @@ experiments = flip allM docs $ \DocumentPositions{..} -> do bottom <- pred . length . T.lines <$> documentContents doc diags <- getCurrentDiagnostics doc - case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Nothing) of + case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Just "88464", Nothing) of Nothing -> pure True Just _err -> pure False ), diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 7144d14f2d..d4fb0cac47 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -1996,7 +1996,7 @@ suggestImportDisambiguationTests = testGroup "suggest import disambiguation acti compareHideFunctionTo = compareTwo "HideFunction.hs" withTarget file locs k = runWithExtraFiles "hiding" $ \dir -> do doc <- openDoc file "haskell" - void $ expectDiagnostics [(file, [(DiagnosticSeverity_Error, loc, "Ambiguous occurrence") | loc <- locs])] + void $ expectDiagnostics [(file, [(DiagnosticSeverity_Error, loc, "Ambiguous occurrence", Nothing) | loc <- locs])] -- TODO: Give this a proper error actions <- getAllCodeActions doc k dir doc actions withHideFunction = withTarget ("HideFunction" <.> "hs") @@ -2455,7 +2455,7 @@ deleteUnusedDefinitionTests = testGroup "delete unused definition action" where testFor sourceLines pos@(l,c) expectedTitle expectedLines = do docId <- createDoc "A.hs" "haskell" $ T.unlines sourceLines - expectDiagnostics [ ("A.hs", [(DiagnosticSeverity_Warning, pos, "not used")]) ] + expectDiagnostics [ ("A.hs", [(DiagnosticSeverity_Warning, pos, "not used", Nothing)]) ] action <- pickActionWithTitle expectedTitle =<< getCodeActions docId (R l c l c) executeCodeAction action contentAfterAction <- documentContents docId @@ -2471,8 +2471,8 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f = 1" ] (if ghcVersion >= GHC94 - then [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the type variable") ] - else [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the following constraint") ]) + then [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the type variable", Nothing) ] + else [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘Integer’ to ‘1’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A (f) where" @@ -2490,8 +2490,8 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , " in x" ] (if ghcVersion >= GHC94 - then [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the type variable") ] - else [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the following constraint") ]) + then [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the type variable", Nothing) ] + else [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘Integer’ to ‘3’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A where" @@ -2510,8 +2510,8 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , " in x" ] (if ghcVersion >= GHC94 - then [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the type variable") ] - else [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the following constraint") ]) + then [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the type variable", Nothing) ] + else [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘Integer’ to ‘5’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A where" @@ -2532,12 +2532,12 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t ] (if ghcVersion >= GHC94 then - [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the type variable") - , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the type variable") + [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the type variable", Nothing) + , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the type variable", Nothing) ] else - [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the following constraint") - , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the following constraint") + [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the following constraint", Nothing) + , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘String’ to ‘\"debug\"’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" @@ -2559,8 +2559,8 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f a = traceShow \"debug\" a" ] (if ghcVersion >= GHC94 - then [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the type variable") ] - else [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the following constraint") ]) + then [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the type variable", Nothing) ] + else [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘String’ to ‘\"debug\"’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -2581,8 +2581,8 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" ] (if ghcVersion >= GHC94 - then [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the type variable") ] - else [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the following constraint") ]) + then [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the type variable", Nothing) ] + else [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘String’ to ‘\"debug\"’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -2597,7 +2597,7 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t testFor sourceLines diag expectedTitle expectedLines = do docId <- createDoc "A.hs" "haskell" $ T.unlines sourceLines expectDiagnostics [ ("A.hs", diag) ] - let cursors = map snd3 diag + let cursors = map (\(_, snd, _, _) -> snd) diag (ls, cs) = minimum cursors (le, ce) = maximum cursors diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 445683366c..222feac7c3 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -67,8 +67,8 @@ genericConfigTests = testGroup "generic plugin config" expectDiagnostics standardDiagnostics ] where - standardDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Warning, (1,0), "Top-level binding")])] - testPluginDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Error, (0,0), "testplugin")])] + standardDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Warning, (1,0), "Top-level binding", Nothing)])] + testPluginDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Error, (0,0), "testplugin", Nothing)])] runConfigSession subdir session = do failIfSessionTimeout $ @@ -90,7 +90,7 @@ genericConfigTests = testGroup "generic plugin config" files <- getFilesOfInterestUntracked void $ uses_ GetTestDiagnostics $ HM.keys files define mempty $ \GetTestDiagnostics file -> do - let diags = [ideErrorText file "testplugin"] + let diags = [ideErrorText Nothing file "testplugin"] return (diags,Nothing) } -- A config that disables the plugin initially From dafb559d0f8468c3d51a871eed79d84a83d49dc9 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Mon, 17 Jun 2024 21:01:49 +0100 Subject: [PATCH 23/44] Improve comment on metadata fdStructuredMessage in FileDiagnostic --- ghcide/src/Development/IDE/Types/Diagnostics.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 9f8a131420..9538da867f 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -125,7 +125,8 @@ instance NFData ShowDiagnostic where -- | A Maybe-like wrapper for a GhcMessage that doesn't try to compare, show, or -- force the GhcMessage inside, so that we can derive Show, Eq, Ord, NFData on --- FileDiagnostic +-- FileDiagnostic. FileDiagnostic only uses this as metadata so we can safely +-- ignore it in fields. data StructuredMessage = NoStructuredMessage | SomeStructuredMessage (MsgEnvelope GhcMessage) @@ -156,10 +157,17 @@ instance NFData StructuredMessage where -- along with the related source location so that we can display the error -- on either the console or in the IDE at the right source location. -- +-- It also optionally keeps a structured diagnostic message GhcMessage in +-- StructuredMessage. +-- data FileDiagnostic = FileDiagnostic { fdFilePath :: NormalizedFilePath , fdShouldShowDiagnostic :: ShowDiagnostic , fdLspDiagnostic :: Diagnostic + -- | The optional GhcMessage inside of this StructuredMessage is ignored for + -- Eq, Ord, Show, and NFData instances. This is fine because this field + -- should only ever be metadata and should never be used to distinguish + -- between FileDiagnostics. , fdStructuredMessage :: StructuredMessage } deriving (Eq, Ord, Show, Generic) From d904b9881ed14f2cfc2ae8be7169202238dfe660 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 20 Jun 2024 09:10:48 +0100 Subject: [PATCH 24/44] Add note to withWarnings explaining the current state of things --- ghcide/src/Development/IDE/GHC/Warnings.hs | 23 ++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 77decfc0d9..1c0bfff99f 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -15,6 +15,29 @@ import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics import Language.LSP.Protocol.Types (type (|?) (..)) +{- + NOTE on withWarnings and its dangers + + withWarnings collects warnings by registering a custom logger which extracts + the SDocs of those warnings. If you receive warnings this way, you will not + get them in a structured form. In the medium term we'd like to remove all + uses of withWarnings to get structured messages everywhere we can. + + For the time being, withWarnings is no longer used for anything in the main + typecheckModule codepath, but it is still used for bytecode/object code + generation, as well as a few other places. + + I suspect some of these functions (e.g. codegen) will need deeper changes to + be able to get diagnostics as a list, though I don't have great evidence for + that atm. I haven't taken a look to see if those functions that are wrapped + with this could produce diagnostics another way. + + It would be good for someone to take a look. What we've done so far gives us + diagnostics for renaming and typechecking, and doesn't require us to copy + too much code from GHC or make any deeper changes, and lets us get started + with the bulk of the useful plugin work, but it would be good to have all + diagnostics with structure be collected that way. +-} -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some -- parsed module 'pm@') and produce a "decorated" action that will From 27c36cfe9e455485f42387fadd707142028dda6b Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 20 Jun 2024 23:13:37 +0100 Subject: [PATCH 25/44] 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. --- ghcide/ghcide.cabal | 1 + ghcide/src/Development/IDE/GHC/Warnings.hs | 25 +----------- .../src/Development/IDE/Types/Diagnostics.hs | 38 +++++++++++++++++-- haskell-language-server.cabal | 2 + .../src/Ide/Plugin/Pragmas.hs | 6 ++- 5 files changed, 42 insertions(+), 30 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 1df93c6bbf..48ed1e3319 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -85,6 +85,7 @@ library , hls-plugin-api == 2.9.0.1 , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens + , lens-aeson , list-t , lsp ^>=2.7 , lsp-types ^>=2.3 diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 1c0bfff99f..6dc9a1a0d8 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -7,13 +7,11 @@ module Development.IDE.GHC.Warnings(withWarnings) where import Control.Concurrent.Strict import Control.Lens (over) -import Data.List import qualified Data.Text as T import Development.IDE.GHC.Compat -import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics -import Language.LSP.Protocol.Types (type (|?) (..)) +import Development.IDE.GHC.Error {- NOTE on withWarnings and its dangers @@ -59,24 +57,3 @@ withWarnings diagSource action = do res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res) - -#if MIN_VERSION_ghc(9,3,0) -attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic -attachReason Nothing d = d -attachReason (Just wr) d = d{_code = InR <$> showReason wr} - where - showReason = \case - WarningWithFlag flag -> showFlag flag - _ -> Nothing -#else -attachReason :: WarnReason -> Diagnostic -> Diagnostic -attachReason wr d = d{_code = InR <$> showReason wr} - where - showReason = \case - NoReason -> Nothing - Reason flag -> showFlag flag - ErrReason flag -> showFlag =<< flag -#endif - -showFlag :: WarningFlag -> Maybe T.Text -showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 9538da867f..59e09f0c46 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -19,18 +19,24 @@ module Development.IDE.Types.Diagnostics ( ideErrorFromLspDiag, showDiagnostics, showDiagnosticsColored, - IdeResultNoDiagnosticsEarlyCutoff) where + IdeResultNoDiagnosticsEarlyCutoff, + attachReason, + attachedReason) where import Control.DeepSeq import Control.Lens +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Lens as JSON import Data.ByteString (ByteString) +import Data.List import Data.Maybe as Maybe import qualified Data.Text as T -import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope) +import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope, WarningFlag, wWarningFlags, flagSpecFlag, flagSpecName) import Development.IDE.Types.Location import GHC.Generics -import GHC.Types.Error (diagnosticCode, DiagnosticCode (..), errMsgDiagnostic) +import GHC.Types.Error (diagnosticCode, DiagnosticCode (..), errMsgDiagnostic, DiagnosticReason(..), diagnosticReason) import Language.LSP.Diagnostics +import Language.LSP.Protocol.Lens (data_) import Language.LSP.Protocol.Types as LSP import Prettyprinter import Prettyprinter.Render.Terminal (Color (..), color) @@ -69,7 +75,7 @@ ideErrorFromLspDiag lspDiag fdFilePath origMsg = case origMsg of Nothing -> NoStructuredMessage Just msg -> SomeStructuredMessage msg - fdLspDiagnostic = lspDiag + fdLspDiagnostic = (attachReason (fmap (diagnosticReason . errMsgDiagnostic) origMsg) lspDiag) #if MIN_VERSION_ghc(9,6,1) { _code = fmap ghcCodeToLspCode . diagnosticCode . errMsgDiagnostic =<< origMsg } @@ -85,6 +91,30 @@ ideErrorFromLspDiag lspDiag fdFilePath origMsg = in FileDiagnostic {..} +attachedReason :: Traversal' Diagnostic (Maybe JSON.Value) +attachedReason = data_ . non (JSON.object []) . JSON.atKey "attachedReason" + +#if MIN_VERSION_ghc(9,3,0) +attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic +attachReason Nothing = id +attachReason (Just wr) = attachedReason .~ fmap JSON.toJSON (showReason wr) + where + showReason = \case + WarningWithFlag flag -> showFlag flag + _ -> Nothing +#else +attachReason :: WarnReason -> Diagnostic -> Diagnostic +attachReason wr = attachedReason .~ fmap JSON.toJSON (showReason wr) + where + showReason = \case + NoReason -> Nothing + Reason flag -> showFlag flag + ErrReason flag -> showFlag =<< flag +#endif + +showFlag :: WarningFlag -> Maybe T.Text +showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags + ideErrorWithSource :: Maybe T.Text -> Maybe DiagnosticSeverity diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 447882a61e..78f3a63ab4 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -912,11 +912,13 @@ library hls-pragmas-plugin hs-source-dirs: plugins/hls-pragmas-plugin/src build-depends: , base >=4.12 && <5 + , aeson , extra , fuzzy , ghcide == 2.9.0.1 , hls-plugin-api == 2.9.0.1 , lens + , lens-aeson , lsp , text , transformers diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index 3bca988580..228467a424 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -15,6 +15,7 @@ module Ide.Plugin.Pragmas , AppearWhere(..) ) where +import qualified Data.Aeson as JSON import Control.Lens hiding (List) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Char (isAlphaNum) @@ -120,8 +121,9 @@ suggest dflags diag = -- --------------------------------------------------------------------- suggestDisableWarning :: Diagnostic -> [PragmaEdit] -suggestDisableWarning Diagnostic {_code} - | Just (LSP.InR (T.stripPrefix "-W" -> Just w)) <- _code +suggestDisableWarning diagnostic + | Just (Just (JSON.String attachedReason)) <- diagnostic ^? attachedReason + , Just w <- T.stripPrefix "-W" attachedReason , w `notElem` warningBlacklist = pure ("Disable \"" <> w <> "\" warnings", OptGHC w) | otherwise = [] From 3961148c21345f39f3de8f9c49b13517ffc540dc Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Thu, 20 Jun 2024 23:56:14 +0100 Subject: [PATCH 26/44] Fix up mistakes from merge, TODO fix merge issues for 9.3.0 --- ghcide/src/Development/IDE/Core/Compile.hs | 2 +- ghcide/src/Development/IDE/GHC/Compat/Outputable.hs | 3 ++- ghcide/src/Development/IDE/Types/Diagnostics.hs | 10 ---------- 3 files changed, 3 insertions(+), 12 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index f94913d896..19be8b02c2 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -720,7 +720,7 @@ tagDiag (w@(Just (WarningWithFlag warning)), fd) | Just tag <- requiresTag warning = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tag : concat (_tags diag) }) #endif - where + where requiresTag :: WarningFlag -> Maybe DiagnosticTag #if !MIN_VERSION_ghc(9,7,0) -- doesn't exist on 9.8, we use WarningWithCategory instead diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index 50331101d1..269353e1ed 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -121,9 +121,10 @@ pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e #if MIN_VERSION_ghc(9,6,1) type ErrMsg = MsgEnvelope GhcMessage type WarnMsg = MsgEnvelope GhcMessage -#elif MIN_VERSION_ghc(9,3,0) +#else type ErrMsg = MsgEnvelope DecoratedSDoc type WarnMsg = MsgEnvelope DecoratedSDoc +#endif mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified #if MIN_VERSION_ghc(9,5,0) diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 59e09f0c46..1648731b2b 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -94,7 +94,6 @@ ideErrorFromLspDiag lspDiag fdFilePath origMsg = attachedReason :: Traversal' Diagnostic (Maybe JSON.Value) attachedReason = data_ . non (JSON.object []) . JSON.atKey "attachedReason" -#if MIN_VERSION_ghc(9,3,0) attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic attachReason Nothing = id attachReason (Just wr) = attachedReason .~ fmap JSON.toJSON (showReason wr) @@ -102,15 +101,6 @@ attachReason (Just wr) = attachedReason .~ fmap JSON.toJSON (showReason wr) showReason = \case WarningWithFlag flag -> showFlag flag _ -> Nothing -#else -attachReason :: WarnReason -> Diagnostic -> Diagnostic -attachReason wr = attachedReason .~ fmap JSON.toJSON (showReason wr) - where - showReason = \case - NoReason -> Nothing - Reason flag -> showFlag flag - ErrReason flag -> showFlag =<< flag -#endif showFlag :: WarningFlag -> Maybe T.Text showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags From 0aa6aaac42c471a9255da4c8ec4d746aff0286cb Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Mon, 24 Jun 2024 18:20:12 +0100 Subject: [PATCH 27/44] Set CodeDescription from HaskellErrorIndex when available --- ghcide/ghcide.cabal | 2 + .../Development/IDE/Core/HaskellErrorIndex.hs | 80 +++++++++++++++++++ ghcide/src/Development/IDE/Core/Shake.hs | 32 ++++++-- .../src/Development/IDE/Types/Diagnostics.hs | 18 +++-- 4 files changed, 119 insertions(+), 13 deletions(-) create mode 100644 ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 48ed1e3319..8e870c8ff1 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -83,6 +83,7 @@ library , hiedb ^>= 0.6.0.0 , hls-graph == 2.9.0.1 , hls-plugin-api == 2.9.0.1 + , http-conduit , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens , lens-aeson @@ -135,6 +136,7 @@ library Development.IDE.Core.Debouncer Development.IDE.Core.FileStore Development.IDE.Core.FileUtils + Development.IDE.Core.HaskellErrorIndex Development.IDE.Core.IdeConfiguration Development.IDE.Core.OfInterest Development.IDE.Core.PluginUtils diff --git a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs new file mode 100644 index 0000000000..7dcecaa895 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs @@ -0,0 +1,80 @@ +-- Retrieve the list of errors from the HaskellErrorIndex via its API +module Development.IDE.Core.HaskellErrorIndex where + +import Control.Exception (tryJust) +import Data.Aeson (FromJSON (..), (.:), withObject) +import qualified Data.Map as M +import qualified Data.Text as T +import Development.IDE.Types.Diagnostics +import GHC.Types.Error (DiagnosticCode) +import Ide.Logger (Recorder, Pretty (..), WithPriority, logWith, Priority (..), vcat) +import Language.LSP.Protocol.Types (Uri (..), CodeDescription (..)) +import Network.HTTP.Simple (HttpException, JSONException, getResponseBody, httpJSON) + +data Log + = LogHaskellErrorIndexInitialized + | LogHaskellErrorIndexJSONError JSONException + | LogHaskellErrorIndexHTTPError HttpException + deriving (Show) + +instance Pretty Log where + pretty = \case + LogHaskellErrorIndexInitialized -> "Initialized Haskell Error Index from internet" + LogHaskellErrorIndexJSONError err -> + vcat + [ "Failed to initialize Haskell Error Index due to a JSON error:" + , pretty (show err) + ] + LogHaskellErrorIndexHTTPError err -> + vcat + [ "Failed to initialize Haskell Error Index due to an HTTP error:" + , pretty (show err) + ] + +newtype HaskellErrorIndex = HaskellErrorIndex (M.Map T.Text HEIError) + deriving (Show, Eq, Ord) + +data HEIError = HEIError + { code :: T.Text + , route :: T.Text + } + deriving (Show, Eq, Ord) + +errorsToIndex :: [HEIError] -> HaskellErrorIndex +errorsToIndex errs = HaskellErrorIndex $ M.fromList $ map (\err -> (code err, err)) errs + +instance FromJSON HEIError where + parseJSON = + withObject "HEIError" $ \v -> + HEIError + <$> v .: "code" + <*> v .: "route" + +instance FromJSON HaskellErrorIndex where + parseJSON = fmap errorsToIndex <$> parseJSON + +initHaskellErrorIndex :: Recorder (WithPriority Log) -> IO (Maybe HaskellErrorIndex) +initHaskellErrorIndex recorder = do + res <- tryJust handleJSONError $ tryJust handleHttpError $ httpJSON "https://errors.haskell.org/api/errors.json" + case res of + Left jsonErr -> do + logWith recorder Info (LogHaskellErrorIndexJSONError jsonErr) + pure Nothing + Right (Left httpErr) -> do + logWith recorder Info (LogHaskellErrorIndexHTTPError httpErr) + pure Nothing + Right (Right res) -> pure $ Just (getResponseBody res) + where + handleJSONError :: JSONException -> Maybe JSONException + handleJSONError = Just + handleHttpError :: HttpException -> Maybe HttpException + handleHttpError = Just + +heiGetError :: HaskellErrorIndex -> DiagnosticCode -> Maybe HEIError +heiGetError (HaskellErrorIndex index) code = showGhcCode code `M.lookup` index + +attachHeiErrorCodeDescription :: HEIError -> Diagnostic -> Diagnostic +attachHeiErrorCodeDescription heiError diag = + diag + { _codeDescription = Just $ CodeDescription $ Uri $ "https://errors.haskell.org/" <> route heiError + } diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 42280ad418..88b7bc93de 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -83,7 +83,7 @@ import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Extra hiding (bracket_) -import Control.Lens ((&), (?~), (%~)) +import Control.Lens ((&), (?~), (%~), over) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader @@ -121,6 +121,8 @@ import Data.Vector (Vector) import qualified Data.Vector as Vector import Development.IDE.Core.Debouncer import Development.IDE.Core.FileUtils (getModTime) +import Development.IDE.Core.HaskellErrorIndex hiding (Log) +import qualified Development.IDE.Core.HaskellErrorIndex as HaskellErrorIndex import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes @@ -156,6 +158,7 @@ import Development.IDE.Types.Shake import qualified Focus import GHC.Fingerprint import GHC.Stack (HasCallStack) +import GHC.Types.Error (diagnosticCode, errMsgDiagnostic) import GHC.TypeLits (KnownSymbol) import HieDb.Types import Ide.Logger hiding (Priority) @@ -195,6 +198,7 @@ data Log | LogShakeGarbageCollection !T.Text !Int !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] + | LogInitializeHaskellErrorIndex !HaskellErrorIndex.Log deriving Show instance Pretty Log where @@ -238,6 +242,8 @@ instance Pretty Log where LogSetFilesOfInterest ofInterest -> "Set files of interst to" <> Pretty.line <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) + LogInitializeHaskellErrorIndex hei -> + "Haskell Error Index:" <+> pretty hei -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -333,6 +339,8 @@ data ShakeExtras = ShakeExtras -- ^ Queue of restart actions to be run. , loaderQueue :: TQueue (IO ()) -- ^ Queue of loader actions to be run. + , haskellErrorIndex :: Maybe HaskellErrorIndex + -- ^ List of errors in the Haskell Error Index (errors.haskell.org) } type WithProgressFunc = forall a. @@ -703,6 +711,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv + haskellErrorIndex <- initHaskellErrorIndex (cmapWithPrio LogInitializeHaskellErrorIndex recorder) pure ShakeExtras{shakeRecorder = recorder, ..} shakeDb <- shakeNewDatabase @@ -1323,24 +1332,25 @@ traceA (A Failed{}) = "Failed" traceA (A Stale{}) = "Stale" traceA (A Succeeded{}) = "Success" -updateFileDiagnostics :: MonadIO m - => Recorder (WithPriority Log) +updateFileDiagnostics + :: Recorder (WithPriority Log) -> NormalizedFilePath -> Maybe Int32 -> Key -> ShakeExtras -> [FileDiagnostic] -- ^ current results - -> m () + -> Action () updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do + hei <- haskellErrorIndex <$> getShakeExtras liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do addTag "key" (show k) + current <- traverse (attachHEI hei) $ map (over fdLspDiagnosticL diagsFromRule) current0 let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current uri = filePathToUri' fp addTagUnsafe :: String -> String -> String -> a -> a addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic] update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store - current = map (fdLspDiagnosticL %~ diagsFromRule) current0 addTag "version" (show ver) mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always @@ -1364,6 +1374,18 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) (map fdLspDiagnostic newDiags) return action where + attachHEI :: Maybe HaskellErrorIndex -> FileDiagnostic -> IO FileDiagnostic + attachHEI mbHei diag + | Just hei <- mbHei + , SomeStructuredMessage msg <- fdStructuredMessage diag + , Just code <- diagnosticCode (errMsgDiagnostic msg) + , Just heiError <- hei `heiGetError` code + = pure $ diag & fdLspDiagnosticL %~ attachHeiErrorCodeDescription heiError + | otherwise + = do + writeFile "/home/dylan/attachHEI" (show mbHei <> "\n" <> show diag) + pure diag + diagsFromRule :: Diagnostic -> Diagnostic diagsFromRule c@Diagnostic{_range} | coerce ideTesting = c & L.relatedInformation ?~ diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index 1648731b2b..f4237202a4 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -19,6 +19,7 @@ module Development.IDE.Types.Diagnostics ( ideErrorFromLspDiag, showDiagnostics, showDiagnosticsColored, + showGhcCode, IdeResultNoDiagnosticsEarlyCutoff, attachReason, attachedReason) where @@ -77,19 +78,20 @@ ideErrorFromLspDiag lspDiag fdFilePath origMsg = Just msg -> SomeStructuredMessage msg fdLspDiagnostic = (attachReason (fmap (diagnosticReason . errMsgDiagnostic) origMsg) lspDiag) #if MIN_VERSION_ghc(9,6,1) - { _code = fmap ghcCodeToLspCode . diagnosticCode . errMsgDiagnostic =<< origMsg + { _code = fmap (InR . showGhcCode) . diagnosticCode . errMsgDiagnostic =<< origMsg } #endif + in + FileDiagnostic {..} + #if MIN_VERSION_ghc(9,8,1) - ghcCodeToLspCode :: DiagnosticCode -> Int32 LSP.|? T.Text - ghcCodeToLspCode = InR . T.pack . show +showGhcCode :: DiagnosticCode -> T.Text +showGhcCode = T.pack . show #elif MIN_VERSION_ghc(9,6,1) - -- DiagnosticCode only got a show instance in 9.8.1 - ghcCodeToLspCode :: DiagnosticCode -> Int32 LSP.|? T.Text - ghcCodeToLspCode (DiagnosticCode prefix c) = InR $ T.pack $ prefix ++ "-" ++ printf "%05d" c +-- DiagnosticCode only got a show instance in 9.8.1 +showGhcCode :: DiagnosticCode -> T.Text +showGhcCode (DiagnosticCode prefix c) = T.pack $ prefix ++ "-" ++ printf "%05d" c #endif - in - FileDiagnostic {..} attachedReason :: Traversal' Diagnostic (Maybe JSON.Value) attachedReason = data_ . non (JSON.object []) . JSON.atKey "attachedReason" From c14cee602766199e645bb6d417c0d0e6d36f2c8c Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 28 Jun 2024 00:46:03 +0100 Subject: [PATCH 28/44] Remove debugging print, fix expectation for preprocessor tests --- ghcide/src/Development/IDE/Core/Shake.hs | 4 +--- ghcide/test/exe/PreprocessorTests.hs | 2 +- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 88b7bc93de..07522f1e38 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1382,9 +1382,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti , Just heiError <- hei `heiGetError` code = pure $ diag & fdLspDiagnosticL %~ attachHeiErrorCodeDescription heiError | otherwise - = do - writeFile "/home/dylan/attachHEI" (show mbHei <> "\n" <> show diag) - pure diag + = pure diag diagsFromRule :: Diagnostic -> Diagnostic diagsFromRule c@Diagnostic{_range} diff --git a/ghcide/test/exe/PreprocessorTests.hs b/ghcide/test/exe/PreprocessorTests.hs index dbbbdc9bc7..24e2e80a10 100644 --- a/ghcide/test/exe/PreprocessorTests.hs +++ b/ghcide/test/exe/PreprocessorTests.hs @@ -22,6 +22,6 @@ tests = testWithDummyPluginEmpty "preprocessor" $ do _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs", - [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z", Just "GHC-88464")] + [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z", Nothing)] -- TODO: Why doesn't this work with expected code "GHC-88464"? ) ] From 7a6e00e4ebb938e986d44e8f3736ebad64ed815b Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 28 Jun 2024 00:50:17 +0100 Subject: [PATCH 29/44] Fix CPP for using Show instance on DiagnosticCode --- ghcide/src/Development/IDE/Types/Diagnostics.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index f4237202a4..f59fc96fb1 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -84,11 +84,11 @@ ideErrorFromLspDiag lspDiag fdFilePath origMsg = in FileDiagnostic {..} -#if MIN_VERSION_ghc(9,8,1) +#if MIN_VERSION_ghc(9,10,1) +-- DiagnosticCode only got a show instance in 9.10.1 showGhcCode :: DiagnosticCode -> T.Text showGhcCode = T.pack . show #elif MIN_VERSION_ghc(9,6,1) --- DiagnosticCode only got a show instance in 9.8.1 showGhcCode :: DiagnosticCode -> T.Text showGhcCode (DiagnosticCode prefix c) = T.pack $ prefix ++ "-" ++ printf "%05d" c #endif From a8a7a64628c5e13261cdae21274d098f9115088e Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 28 Jun 2024 01:55:39 +0100 Subject: [PATCH 30/44] Remove diagFromErrMsgs for GHC version < 9.6.1 using CPP --- ghcide/src/Development/IDE/Core/Compile.hs | 31 +++++++++++++++++-- .../Development/IDE/Core/HaskellErrorIndex.hs | 24 ++++++++++++-- ghcide/src/Development/IDE/Core/Shake.hs | 5 ++- .../src/Development/IDE/GHC/Compat/Driver.hs | 17 ++++++++-- .../src/Development/IDE/Types/Diagnostics.hs | 8 ++++- 5 files changed, 74 insertions(+), 11 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 19be8b02c2..1ad641e086 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -197,7 +197,9 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do case etcm of Left errs -> return (errs, Nothing) Right tcm -> - let addReason diag = map (Just (diagnosticReason (errMsgDiagnostic diag)),) $ diagFromErrMsg sourceTypecheck (hsc_dflags hscEnv) diag + let addReason diag = + map (Just (diagnosticReason (errMsgDiagnostic diag)),) $ + diagFromErrMsg sourceTypecheck (hsc_dflags hscEnv) diag errorPipeline = map (unDefer . hideDiag dflags . tagDiag) . addReason diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm deferredError = any fst diags @@ -1074,7 +1076,11 @@ parseHeader dflags filename contents = do let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of PFailedWithErrorMessages msgs -> +#if MIN_VERSION_ghc(9,6,1) throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags +#else + throwE $ diagFromSDocErrMsgs sourceParser dflags $ msgs dflags +#endif POk pst rdr_module -> do let (warns, errs) = renderMessages $ getPsMessages pst @@ -1088,9 +1094,17 @@ parseHeader dflags filename contents = do -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ +#if MIN_VERSION_ghc(9,6,1) throwE $ diagFromErrMsgs sourceParser dflags errs +#else + throwE $ diagFromSDocErrMsgs sourceParser dflags errs +#endif +#if MIN_VERSION_ghc(9,6,1) let warnings = diagFromErrMsgs sourceParser dflags warns +#else + let warnings = diagFromSDocErrMsgs sourceParser dflags warns +#endif return (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a @@ -1107,7 +1121,12 @@ parseFileContents env customPreprocessor filename ms = do dflags = ms_hspp_opts ms contents = fromJust $ ms_hspp_buf ms case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of - PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags + PFailedWithErrorMessages msgs -> +#if MIN_VERSION_ghc(9,6,1) + throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags +#else + throwE $ diagFromSDocErrMsgs sourceParser dflags $ msgs dflags +#endif POk pst rdr_module -> let psMessages = getPsMessages pst @@ -1141,7 +1160,11 @@ parseFileContents env customPreprocessor filename ms = do -- errors are those from which a parse tree just can't -- be produced. unless (null errors) $ +#if MIN_VERSION_ghc(9,6,1) throwE $ diagFromErrMsgs sourceParser dflags errors +#else + throwE $ diagFromSDocErrMsgs sourceParser dflags errors +#endif -- To get the list of extra source files, we take the list @@ -1172,7 +1195,11 @@ parseFileContents env customPreprocessor filename ms = do srcs2 <- liftIO $ filterM doesFileExist srcs1 let pm = ParsedModule ms parsed' srcs2 +#if MIN_VERSION_ghc(9,6,1) warnings = diagFromErrMsgs sourceParser dflags warns +#else + warnings = diagFromSDocErrMsgs sourceParser dflags warns +#endif pure (warnings ++ preproc_warning_file_diagnostics, pm) loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile diff --git a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs index 7dcecaa895..ef0a98b4a3 100644 --- a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs +++ b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs @@ -1,4 +1,6 @@ -- Retrieve the list of errors from the HaskellErrorIndex via its API +{-# LANGUAGE CPP #-} + module Development.IDE.Core.HaskellErrorIndex where import Control.Exception (tryJust) @@ -6,7 +8,11 @@ import Data.Aeson (FromJSON (..), (.:), withObj import qualified Data.Map as M import qualified Data.Text as T import Development.IDE.Types.Diagnostics -import GHC.Types.Error (DiagnosticCode) +import GHC.Driver.Errors.Types ( GhcMessage +#if MIN_VERSION_ghc(9,6,1) + , DiagnosticCode, diagnosticCode +#endif + ) import Ide.Logger (Recorder, Pretty (..), WithPriority, logWith, Priority (..), vcat) import Language.LSP.Protocol.Types (Uri (..), CodeDescription (..)) import Network.HTTP.Simple (HttpException, JSONException, getResponseBody, httpJSON) @@ -55,6 +61,7 @@ instance FromJSON HaskellErrorIndex where initHaskellErrorIndex :: Recorder (WithPriority Log) -> IO (Maybe HaskellErrorIndex) initHaskellErrorIndex recorder = do +#if MIN_VERSION_ghc(9,6,1) res <- tryJust handleJSONError $ tryJust handleHttpError $ httpJSON "https://errors.haskell.org/api/errors.json" case res of Left jsonErr -> do @@ -69,9 +76,20 @@ initHaskellErrorIndex recorder = do handleJSONError = Just handleHttpError :: HttpException -> Maybe HttpException handleHttpError = Just +#else + pure Nothing +#endif -heiGetError :: HaskellErrorIndex -> DiagnosticCode -> Maybe HEIError -heiGetError (HaskellErrorIndex index) code = showGhcCode code `M.lookup` index +heiGetError :: HaskellErrorIndex -> GhcMessage -> Maybe HEIError +heiGetError (HaskellErrorIndex index) msg = +#if MIN_VERSION_ghc(9,6,1) + | Just code <- diagnosticCode (errMsgDiagnostic msg) + = showGhcCode code `M.lookup` index + | otherwise + = Nothing +#else + Nothing +#endif attachHeiErrorCodeDescription :: HEIError -> Diagnostic -> Diagnostic attachHeiErrorCodeDescription heiError diag = diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 07522f1e38..a51dec8303 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -158,7 +158,7 @@ import Development.IDE.Types.Shake import qualified Focus import GHC.Fingerprint import GHC.Stack (HasCallStack) -import GHC.Types.Error (diagnosticCode, errMsgDiagnostic) +import GHC.Types.Error (errMsgDiagnostic) import GHC.TypeLits (KnownSymbol) import HieDb.Types import Ide.Logger hiding (Priority) @@ -1378,8 +1378,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti attachHEI mbHei diag | Just hei <- mbHei , SomeStructuredMessage msg <- fdStructuredMessage diag - , Just code <- diagnosticCode (errMsgDiagnostic msg) - , Just heiError <- hei `heiGetError` code + , Just heiError <- hei `heiGetError` errMsgDiagnostic msg = pure $ diag & fdLspDiagnosticL %~ attachHeiErrorCodeDescription heiError | otherwise = pure diag diff --git a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs index 229dd45d57..9475268f1a 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs @@ -6,6 +6,8 @@ -- MR to add this function: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12891 -- ============================================================================ +{-# LANGUAGE CPP #-} + module Development.IDE.GHC.Compat.Driver ( hscTypecheckRenameWithDiagnostics ) where @@ -37,11 +39,21 @@ import GHC.Data.FastString import GHC.Data.Maybe import Control.Monad +#if !MIN_VERSION_ghc(9,6,1) +import Development.IDE.GHC.Compat.Core (hscTypecheckRename) +import GHC.Utils.Error (emptyMessages) +#endif + hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage) -hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = runHsc' hsc_env $ - hsc_typecheck True mod_summary (Just rdr_module) +hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = +#if MIN_VERSION_ghc(9,6,1) + runHsc' hsc_env $ hsc_typecheck True mod_summary (Just rdr_module) +#else + (,emptyMessages) <$> hscTypecheckRename hsc_env mod_summary rdr_module +#endif +#if MIN_VERSION_ghc(9,6,1) -- ============================================================================ -- DO NOT EDIT - Refer to top of file -- ============================================================================ @@ -128,3 +140,4 @@ hscSimpleIface :: HscEnv -> IO (ModIface, ModDetails) hscSimpleIface hsc_env mb_core_program tc_result summary = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary +#endif diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index f59fc96fb1..ce197150f4 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -19,7 +19,9 @@ module Development.IDE.Types.Diagnostics ( ideErrorFromLspDiag, showDiagnostics, showDiagnosticsColored, +#if MIN_VERSION_ghc(9,6,1) showGhcCode, +#endif IdeResultNoDiagnosticsEarlyCutoff, attachReason, attachedReason) where @@ -35,7 +37,11 @@ import qualified Data.Text as T import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope, WarningFlag, wWarningFlags, flagSpecFlag, flagSpecName) import Development.IDE.Types.Location import GHC.Generics -import GHC.Types.Error (diagnosticCode, DiagnosticCode (..), errMsgDiagnostic, DiagnosticReason(..), diagnosticReason) +import GHC.Types.Error ( errMsgDiagnostic, DiagnosticReason(..), diagnosticReason +#if MIN_VERSION_ghc(9,6,1) + , diagnosticCode, DiagnosticCode (..) +#endif + ) import Language.LSP.Diagnostics import Language.LSP.Protocol.Lens (data_) import Language.LSP.Protocol.Types as LSP From 14fbd7c933fc1fadb41af262481f09a1e80bd21e Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 28 Jun 2024 02:01:44 +0100 Subject: [PATCH 31/44] CPP fix --- ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs index ef0a98b4a3..396affbd1e 100644 --- a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs +++ b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs @@ -81,7 +81,7 @@ initHaskellErrorIndex recorder = do #endif heiGetError :: HaskellErrorIndex -> GhcMessage -> Maybe HEIError -heiGetError (HaskellErrorIndex index) msg = +heiGetError (HaskellErrorIndex index) msg #if MIN_VERSION_ghc(9,6,1) | Just code <- diagnosticCode (errMsgDiagnostic msg) = showGhcCode code `M.lookup` index From 61164ea6638eb942846974411c946373002553ae Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Fri, 28 Jun 2024 23:42:21 +0100 Subject: [PATCH 32/44] More stylish-haskell, more CPP fix --- .../Development/IDE/Core/HaskellErrorIndex.hs | 29 +++++++++++-------- 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs index 396affbd1e..68c1637029 100644 --- a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs +++ b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs @@ -1,21 +1,26 @@ -- Retrieve the list of errors from the HaskellErrorIndex via its API -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} module Development.IDE.Core.HaskellErrorIndex where import Control.Exception (tryJust) -import Data.Aeson (FromJSON (..), (.:), withObject) +import Data.Aeson (FromJSON (..), withObject, + (.:)) import qualified Data.Map as M import qualified Data.Text as T import Development.IDE.Types.Diagnostics -import GHC.Driver.Errors.Types ( GhcMessage +import GHC.Driver.Errors.Types (GhcMessage) #if MIN_VERSION_ghc(9,6,1) - , DiagnosticCode, diagnosticCode +import GHC.Types.Error (diagnosticCode) #endif - ) -import Ide.Logger (Recorder, Pretty (..), WithPriority, logWith, Priority (..), vcat) -import Language.LSP.Protocol.Types (Uri (..), CodeDescription (..)) -import Network.HTTP.Simple (HttpException, JSONException, getResponseBody, httpJSON) +import Ide.Logger (Pretty (..), Priority (..), + Recorder, WithPriority, + logWith, vcat) +import Language.LSP.Protocol.Types (CodeDescription (..), + Uri (..)) +import Network.HTTP.Simple (HttpException, + JSONException, + getResponseBody, httpJSON) data Log = LogHaskellErrorIndexInitialized @@ -41,7 +46,7 @@ newtype HaskellErrorIndex = HaskellErrorIndex (M.Map T.Text HEIError) deriving (Show, Eq, Ord) data HEIError = HEIError - { code :: T.Text + { code :: T.Text , route :: T.Text } deriving (Show, Eq, Ord) @@ -60,8 +65,8 @@ instance FromJSON HaskellErrorIndex where parseJSON = fmap errorsToIndex <$> parseJSON initHaskellErrorIndex :: Recorder (WithPriority Log) -> IO (Maybe HaskellErrorIndex) -initHaskellErrorIndex recorder = do #if MIN_VERSION_ghc(9,6,1) +initHaskellErrorIndex recorder = do res <- tryJust handleJSONError $ tryJust handleHttpError $ httpJSON "https://errors.haskell.org/api/errors.json" case res of Left jsonErr -> do @@ -77,13 +82,13 @@ initHaskellErrorIndex recorder = do handleHttpError :: HttpException -> Maybe HttpException handleHttpError = Just #else - pure Nothing +initHaskellErrorIndex recorder = pure Nothing #endif heiGetError :: HaskellErrorIndex -> GhcMessage -> Maybe HEIError heiGetError (HaskellErrorIndex index) msg #if MIN_VERSION_ghc(9,6,1) - | Just code <- diagnosticCode (errMsgDiagnostic msg) + | Just code <- diagnosticCode msg = showGhcCode code `M.lookup` index | otherwise = Nothing From 53221fffb0b4e50fd2898150d073e359e1b236e2 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sat, 29 Jun 2024 00:15:21 +0100 Subject: [PATCH 33/44] Fix all stylish-haskell errors triggering --- ghcide/src/Development/IDE/Core/RuleTypes.hs | 2 +- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- .../src/Development/IDE/GHC/Compat/Driver.hs | 61 +++++++------- ghcide/src/Development/IDE/GHC/Error.hs | 9 +- ghcide/src/Development/IDE/GHC/Warnings.hs | 4 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 5 +- .../src/Development/IDE/Types/Diagnostics.hs | 48 ++++++----- ghcide/src/Text/Fuzzy/Parallel.hs | 21 +++-- .../src/Development/IDE/Test/Diagnostic.hs | 4 +- .../src/Ide/Plugin/Cabal/Diagnostics.hs | 31 +++---- .../src/Ide/Plugin/Pragmas.hs | 2 +- .../hls-stan-plugin/src/Ide/Plugin/Stan.hs | 83 ++++++++++--------- 12 files changed, 141 insertions(+), 131 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index d60b61b6da..0f89674d27 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -40,12 +40,12 @@ import Development.IDE.Import.FindImports (ArtifactsLocation import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics +import GHC.Driver.Errors.Types (WarningMessages) import GHC.Serialized (Serialized) import Ide.Logger (Pretty (..), viaShow) import Language.LSP.Protocol.Types (Int32, NormalizedFilePath) -import GHC.Driver.Errors.Types (WarningMessages) data LinkableType = ObjectLinkable | BCOLinkable deriving (Eq,Ord,Show, Generic) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index a51dec8303..666f6777d7 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -83,7 +83,7 @@ import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Extra hiding (bracket_) -import Control.Lens ((&), (?~), (%~), over) +import Control.Lens (over, (%~), (&), (?~)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader diff --git a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs index 9475268f1a..05aa30ceb2 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Driver.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Driver.hs @@ -6,42 +6,43 @@ -- MR to add this function: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12891 -- ============================================================================ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} module Development.IDE.GHC.Compat.Driver ( hscTypecheckRenameWithDiagnostics ) where -import GHC.Driver.Main -import GHC.Driver.Session -import GHC.Driver.Env -import GHC.Driver.Errors.Types -import GHC.Hs -import GHC.Hs.Dump -import GHC.Iface.Ext.Ast ( mkHieFile ) -import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) -import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result) -import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) -import GHC.Core -import GHC.Tc.Module -import GHC.Tc.Utils.Monad -import GHC.Unit -import GHC.Unit.Module.ModDetails -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.ModSummary -import GHC.Types.SourceFile -import GHC.Types.SrcLoc -import GHC.Utils.Panic.Plain -import GHC.Utils.Error -import GHC.Utils.Outputable -import GHC.Utils.Logger -import GHC.Data.FastString -import GHC.Data.Maybe -import Control.Monad +import Control.Monad +import GHC.Core +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Driver.Main +import GHC.Driver.Session +import GHC.Hs +import GHC.Hs.Dump +import GHC.Iface.Ext.Ast (mkHieFile) +import GHC.Iface.Ext.Binary (hie_file_result, readHieFile, + writeHieFile) +import GHC.Iface.Ext.Debug (diffFile, validateScopes) +import GHC.Iface.Ext.Types (getAsts, hie_asts, hie_module) +import GHC.Tc.Module +import GHC.Tc.Utils.Monad +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Unit +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic.Plain #if !MIN_VERSION_ghc(9,6,1) -import Development.IDE.GHC.Compat.Core (hscTypecheckRename) -import GHC.Utils.Error (emptyMessages) +import Development.IDE.GHC.Compat.Core (hscTypecheckRename) +import GHC.Utils.Error (emptyMessages) #endif hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule @@ -78,7 +79,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do else do hpm <- case mb_rdr_module of Just hpm -> return hpm - Nothing -> hscParse' mod_summary + Nothing -> hscParse' mod_summary tc_result0 <- tcRnModule' mod_summary keep_rn' hpm if hsc_src == HsigFile then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index daf5cee7ac..38cdf93605 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DisambiguateRecordFields #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 @@ -41,10 +41,11 @@ import Data.Maybe import Data.String (fromString) import qualified Data.Text as T import Data.Tuple.Extra (uncurry3) -import Development.IDE.GHC.Compat (MsgEnvelope, - errMsgSeverity, errMsgSpan, errMsgDiagnostic, +import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope, + errMsgDiagnostic, + errMsgSeverity, errMsgSpan, formatErrorWithQual, - srcErrorMessages, GhcMessage) + srcErrorMessages) import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.GHC.Orphans () diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 6dc9a1a0d8..13e5f8b604 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -6,12 +6,12 @@ module Development.IDE.GHC.Warnings(withWarnings) where import Control.Concurrent.Strict -import Control.Lens (over) +import Control.Lens (over) import qualified Data.Text as T import Development.IDE.GHC.Compat -import Development.IDE.Types.Diagnostics import Development.IDE.GHC.Error +import Development.IDE.Types.Diagnostics {- NOTE on withWarnings and its dangers diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index a0d4e13953..a1aa237de8 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -26,11 +26,12 @@ import Data.List (find) import qualified Data.Map as Map import Data.Maybe (catMaybes, maybeToList) import qualified Data.Text as T -import Development.IDE (GhcSession (..), +import Development.IDE (FileDiagnostic (..), + GhcSession (..), HscEnvEq (hscEnv), RuleResult, Rules, Uri, define, srcSpanToRange, - usePropertyAction, FileDiagnostic (..)) + usePropertyAction) import Development.IDE.Core.Compile (TcModuleResult (..)) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index ce197150f4..cfa975b454 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -1,9 +1,9 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} module Development.IDE.Types.Diagnostics ( LSP.Diagnostic(..), @@ -28,20 +28,22 @@ module Development.IDE.Types.Diagnostics ( import Control.DeepSeq import Control.Lens -import qualified Data.Aeson as JSON -import qualified Data.Aeson.Lens as JSON +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Lens as JSON import Data.ByteString (ByteString) import Data.List import Data.Maybe as Maybe import qualified Data.Text as T -import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope, WarningFlag, wWarningFlags, flagSpecFlag, flagSpecName) +import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope, + WarningFlag, flagSpecFlag, + flagSpecName, wWarningFlags) import Development.IDE.Types.Location import GHC.Generics -import GHC.Types.Error ( errMsgDiagnostic, DiagnosticReason(..), diagnosticReason -#if MIN_VERSION_ghc(9,6,1) - , diagnosticCode, DiagnosticCode (..) -#endif - ) +import GHC.Types.Error (DiagnosticCode (..), + DiagnosticReason (..), + diagnosticCode, + diagnosticReason, + errMsgDiagnostic) import Language.LSP.Diagnostics import Language.LSP.Protocol.Lens (data_) import Language.LSP.Protocol.Types as LSP @@ -80,7 +82,7 @@ ideErrorFromLspDiag lspDiag fdFilePath origMsg = let fdShouldShowDiagnostic = ShowDiag fdStructuredMessage = case origMsg of - Nothing -> NoStructuredMessage + Nothing -> NoStructuredMessage Just msg -> SomeStructuredMessage msg fdLspDiagnostic = (attachReason (fmap (diagnosticReason . errMsgDiagnostic) origMsg) lspDiag) #if MIN_VERSION_ghc(9,6,1) @@ -161,22 +163,22 @@ data StructuredMessage deriving (Generic) instance Show StructuredMessage where - show NoStructuredMessage = "NoStructuredMessage" + show NoStructuredMessage = "NoStructuredMessage" show SomeStructuredMessage {} = "SomeStructuredMessage" instance Eq StructuredMessage where - (==) NoStructuredMessage NoStructuredMessage = True + (==) NoStructuredMessage NoStructuredMessage = True (==) SomeStructuredMessage {} SomeStructuredMessage {} = True - (==) _ _ = False + (==) _ _ = False instance Ord StructuredMessage where - compare NoStructuredMessage NoStructuredMessage = EQ + compare NoStructuredMessage NoStructuredMessage = EQ compare SomeStructuredMessage {} SomeStructuredMessage {} = EQ - compare NoStructuredMessage SomeStructuredMessage {} = GT - compare SomeStructuredMessage {} NoStructuredMessage = LT + compare NoStructuredMessage SomeStructuredMessage {} = GT + compare SomeStructuredMessage {} NoStructuredMessage = LT instance NFData StructuredMessage where - rnf NoStructuredMessage = () + rnf NoStructuredMessage = () rnf SomeStructuredMessage {} = () -- | Human readable diagnostics for a specific file. @@ -189,14 +191,14 @@ instance NFData StructuredMessage where -- StructuredMessage. -- data FileDiagnostic = FileDiagnostic - { fdFilePath :: NormalizedFilePath + { fdFilePath :: NormalizedFilePath , fdShouldShowDiagnostic :: ShowDiagnostic - , fdLspDiagnostic :: Diagnostic + , fdLspDiagnostic :: Diagnostic -- | The optional GhcMessage inside of this StructuredMessage is ignored for -- Eq, Ord, Show, and NFData instances. This is fine because this field -- should only ever be metadata and should never be used to distinguish -- between FileDiagnostics. - , fdStructuredMessage :: StructuredMessage + , fdStructuredMessage :: StructuredMessage } deriving (Eq, Ord, Show, Generic) @@ -233,8 +235,8 @@ prettyDiagnostic FileDiagnostic { fdFilePath, fdShouldShowDiagnostic, fdLspDiagn , slabel_ "Severity:" $ pretty $ show sev , slabel_ "Code: " $ case _code of Just (InR text) -> pretty text - Just (InL i) -> pretty i - Nothing -> "" + Just (InL i) -> pretty i + Nothing -> "" , slabel_ "Message: " $ case sev of LSP.DiagnosticSeverity_Error -> annotate $ color Red diff --git a/ghcide/src/Text/Fuzzy/Parallel.hs b/ghcide/src/Text/Fuzzy/Parallel.hs index 13039e1e55..4d7a1d67e0 100644 --- a/ghcide/src/Text/Fuzzy/Parallel.hs +++ b/ghcide/src/Text/Fuzzy/Parallel.hs @@ -89,8 +89,7 @@ simpleFilter :: Int -- ^ Chunk size. 1000 works well. -> T.Text -- ^ Pattern to look for. -> [T.Text] -- ^ List of texts to check. -> [Scored T.Text] -- ^ The ones that match. -simpleFilter chunk maxRes pattern xs = - filter chunk maxRes pattern xs id +simpleFilter chunk maxRes pat xs = filter chunk maxRes pat xs id -- | The function to filter a list of values by fuzzy search on the text extracted from them, @@ -104,15 +103,15 @@ filter' :: Int -- ^ Chunk size. 1000 works well. -- ^ Custom scoring function to use for calculating how close words are -- When the function returns Nothing, this means the values are incomparable. -> [Scored t] -- ^ The list of results, sorted, highest score first. -filter' chunkSize maxRes pattern ts extract match' = partialSortByAscScore maxRes perfectScore (concat vss) +filter' chunkSize maxRes pat ts extract match' = partialSortByAscScore maxRes perfectScore (concat vss) where -- Preserve case for the first character, make all others lowercase - pattern' = case T.uncons pattern of + pat' = case T.uncons pat of Just (c, rest) -> T.cons c (T.toLower rest) - _ -> pattern - vss = map (mapMaybe (\t -> flip Scored t <$> match' pattern' (extract t))) (chunkList chunkSize ts) + _ -> pat + vss = map (mapMaybe (\t -> flip Scored t <$> match' pat' (extract t))) (chunkList chunkSize ts) `using` parList (evalList rseq) - perfectScore = fromMaybe (error $ T.unpack pattern) $ match' pattern' pattern' + perfectScore = fromMaybe (error $ T.unpack pat) $ match' pat' pat' -- | The function to filter a list of values by fuzzy search on the text extracted from them, -- using a custom matching function which determines how close words are. @@ -122,8 +121,8 @@ filter :: Int -- ^ Chunk size. 1000 works well. -> [t] -- ^ The list of values containing the text to search in. -> (t -> T.Text) -- ^ The function to extract the text from the container. -> [Scored t] -- ^ The list of results, sorted, highest score first. -filter chunkSize maxRes pattern ts extract = - filter' chunkSize maxRes pattern ts extract match +filter chunkSize maxRes pat ts extract = + filter' chunkSize maxRes pat ts extract match -- | Return all elements of the list that have a fuzzy match against the pattern, -- the closeness of the match is determined using the custom scoring match function that is passed. @@ -136,8 +135,8 @@ simpleFilter' :: Int -- ^ Chunk size. 1000 works well. -> (T.Text -> T.Text -> Maybe Int) -- ^ Custom scoring function to use for calculating how close words are -> [Scored T.Text] -- ^ The ones that match. -simpleFilter' chunk maxRes pattern xs match' = - filter' chunk maxRes pattern xs id match' +simpleFilter' chunk maxRes pat xs match' = + filter' chunk maxRes pat xs id match' -------------------------------------------------------------------------------- chunkList :: Int -> [a] -> [[a]] diff --git a/hls-test-utils/src/Development/IDE/Test/Diagnostic.hs b/hls-test-utils/src/Development/IDE/Test/Diagnostic.hs index 77ae9e37c1..83caeab58d 100644 --- a/hls-test-utils/src/Development/IDE/Test/Diagnostic.hs +++ b/hls-test-utils/src/Development/IDE/Test/Diagnostic.hs @@ -36,8 +36,8 @@ requireDiagnostic actuals expected@(severity, cursor, expectedMsg, mbExpectedCod codeMatches d = case (mbExpectedCode, _code d) of - (Nothing, _) -> True - (Just expectedCode, Nothing) -> False + (Nothing, _) -> True + (Just expectedCode, Nothing) -> False (Just expectedCode, Just actualCode) -> InR expectedCode == actualCode hasTag :: Maybe DiagnosticTag -> Maybe [DiagnosticTag] -> Bool diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs index 6824985adb..5425c419d7 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -11,21 +11,22 @@ module Ide.Plugin.Cabal.Diagnostics ) where -import Control.Lens ((.~), (&)) -import qualified Data.Text as T -import Development.IDE (FileDiagnostic, - ShowDiagnostic (ShowDiag)) -import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, ideErrorWithSource) -import Distribution.Fields (showPError, showPWarning) -import qualified Distribution.Parsec as Syntax -import Ide.PluginUtils (extendNextLine) -import Language.LSP.Protocol.Types (Diagnostic (..), - DiagnosticSeverity (..), - NormalizedFilePath, - Position (Position), - Range (Range), - fromNormalizedFilePath) -import Language.LSP.Protocol.Lens (range) +import Control.Lens ((&), (.~)) +import qualified Data.Text as T +import Development.IDE (FileDiagnostic, + ShowDiagnostic (ShowDiag)) +import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, + ideErrorWithSource) +import Distribution.Fields (showPError, showPWarning) +import qualified Distribution.Parsec as Syntax +import Ide.PluginUtils (extendNextLine) +import Language.LSP.Protocol.Lens (range) +import Language.LSP.Protocol.Types (Diagnostic (..), + DiagnosticSeverity (..), + NormalizedFilePath, + Position (Position), + Range (Range), + fromNormalizedFilePath) -- | Produce a diagnostic for a fatal Cabal parser error. fatalParseErrorDiagnostic :: NormalizedFilePath -> T.Text -> FileDiagnostic diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index 228467a424..376ded04e4 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -15,9 +15,9 @@ module Ide.Plugin.Pragmas , AppearWhere(..) ) where -import qualified Data.Aeson as JSON import Control.Lens hiding (List) import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Aeson as JSON import Data.Char (isAlphaNum) import Data.List.Extra (nubOrdOn) import qualified Data.Map as M diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index 5841f56405..1fc7fa42c2 100644 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -2,47 +2,52 @@ {-# LANGUAGE PatternSynonyms #-} module Ide.Plugin.Stan (descriptor, Log) where -import Compat.HieTypes (HieFile (..)) -import Control.DeepSeq (NFData) -import Control.Monad (void) -import Control.Monad.IO.Class (liftIO) -import Data.Foldable (toList) -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as HM -import Data.Maybe (mapMaybe) -import qualified Data.Text as T +import Compat.HieTypes (HieFile (..)) +import Control.DeepSeq (NFData) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Foldable (toList) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (mapMaybe) +import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.Rules (getHieFile) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Diagnostics -import Development.IDE.Core.Rules (getHieFile) -import qualified Development.IDE.Core.Shake as Shake -import GHC.Generics (Generic) -import Ide.Plugin.Config (PluginConfig (..)) -import Ide.Types (PluginDescriptor (..), PluginId, - configHasDiagnostics, - configInitialGenericConfig, - defaultConfigDescriptor, - defaultPluginDescriptor) -import qualified Language.LSP.Protocol.Types as LSP -import Stan (createCabalExtensionsMap, - getStanConfig) -import Stan.Analysis (Analysis (..), runAnalysis) -import Stan.Category (Category (..)) -import Stan.Cli (StanArgs (..)) -import Stan.Config (Config, ConfigP (..), applyConfig) -import Stan.Config.Pretty (prettyConfigCli) -import Stan.Core.Id (Id (..)) -import Stan.EnvVars (EnvVars (..), envVarsToText) -import Stan.Inspection (Inspection (..)) -import Stan.Inspection.All (inspectionsIds, inspectionsMap) -import Stan.Observation (Observation (..)) -import Stan.Report.Settings (OutputSettings (..), - ToggleSolution (..), - Verbosity (..)) -import Stan.Toml (usedTomlFiles) -import System.Directory (makeRelativeToCurrentDirectory) -import Trial (Fatality, Trial (..), fiasco, - pattern FiascoL, pattern ResultL, - prettyTrial, prettyTrialWith) +import GHC.Generics (Generic) +import Ide.Plugin.Config (PluginConfig (..)) +import Ide.Types (PluginDescriptor (..), + PluginId, + configHasDiagnostics, + configInitialGenericConfig, + defaultConfigDescriptor, + defaultPluginDescriptor) +import qualified Language.LSP.Protocol.Types as LSP +import Stan (createCabalExtensionsMap, + getStanConfig) +import Stan.Analysis (Analysis (..), runAnalysis) +import Stan.Category (Category (..)) +import Stan.Cli (StanArgs (..)) +import Stan.Config (Config, ConfigP (..), + applyConfig) +import Stan.Config.Pretty (prettyConfigCli) +import Stan.Core.Id (Id (..)) +import Stan.EnvVars (EnvVars (..), envVarsToText) +import Stan.Inspection (Inspection (..)) +import Stan.Inspection.All (inspectionsIds, + inspectionsMap) +import Stan.Observation (Observation (..)) +import Stan.Report.Settings (OutputSettings (..), + ToggleSolution (..), + Verbosity (..)) +import Stan.Toml (usedTomlFiles) +import System.Directory (makeRelativeToCurrentDirectory) +import Trial (Fatality, Trial (..), + fiasco, pattern FiascoL, + pattern ResultL, + prettyTrial, + prettyTrialWith) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId desc) From 4d1742e7d692813ac49cc793577f5f81755da620 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sat, 29 Jun 2024 02:05:45 +0100 Subject: [PATCH 34/44] Fix more CPP --- ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs index 68c1637029..9e51aa4348 100644 --- a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs +++ b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs @@ -86,14 +86,15 @@ initHaskellErrorIndex recorder = pure Nothing #endif heiGetError :: HaskellErrorIndex -> GhcMessage -> Maybe HEIError -heiGetError (HaskellErrorIndex index) msg #if MIN_VERSION_ghc(9,6,1) +heiGetError (HaskellErrorIndex index) msg | Just code <- diagnosticCode msg = showGhcCode code `M.lookup` index | otherwise = Nothing #else - Nothing +heiGetError (HaskellErrorIndex index) msg + = Nothing #endif attachHeiErrorCodeDescription :: HEIError -> Diagnostic -> Diagnostic From 8b229fc5b45e62e061fffb3fa752255693918ffd Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sat, 29 Jun 2024 04:07:19 +0100 Subject: [PATCH 35/44] Only override the LSP diagnostic code when not already set --- .../src/Development/IDE/Types/Diagnostics.hs | 27 ++++++++++++++----- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index cfa975b454..a690a04203 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -26,6 +26,7 @@ module Development.IDE.Types.Diagnostics ( attachReason, attachedReason) where +import Control.Applicative ((<|>)) import Control.DeepSeq import Control.Lens import qualified Data.Aeson as JSON @@ -78,20 +79,32 @@ ideErrorFromLspDiag -> NormalizedFilePath -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic -ideErrorFromLspDiag lspDiag fdFilePath origMsg = +ideErrorFromLspDiag lspDiag fdFilePath mbOrigMsg = let fdShouldShowDiagnostic = ShowDiag fdStructuredMessage = - case origMsg of + case mbOrigMsg of Nothing -> NoStructuredMessage Just msg -> SomeStructuredMessage msg - fdLspDiagnostic = (attachReason (fmap (diagnosticReason . errMsgDiagnostic) origMsg) lspDiag) -#if MIN_VERSION_ghc(9,6,1) - { _code = fmap (InR . showGhcCode) . diagnosticCode . errMsgDiagnostic =<< origMsg - } -#endif + fdLspDiagnostic = + lspDiag + & attachReason (fmap (diagnosticReason . errMsgDiagnostic) mbOrigMsg) + & setGhcCode mbOrigMsg in FileDiagnostic {..} +setGhcCode :: Maybe (MsgEnvelope GhcMessage) -> LSP.Diagnostic -> LSP.Diagnostic +#if MIN_VERSION_ghc(9,6,1) +setGhcCode mbOrigMsg diag = + let mbGhcCode = do + origMsg <- mbOrigMsg + code <- diagnosticCode (errMsgDiagnostic origMsg) + pure (InR (showGhcCode code)) + in + diag { _code = mbGhcCode <|> _code diag } +#else +setGhcCode _ diag = diag +#endif + #if MIN_VERSION_ghc(9,10,1) -- DiagnosticCode only got a show instance in 9.10.1 showGhcCode :: DiagnosticCode -> T.Text From 296b8477f996f54e0ed35c231dc771600696cf07 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sat, 29 Jun 2024 11:34:13 +0100 Subject: [PATCH 36/44] Fixes for stylish-haskell stylish-haskell does not handle CPP pragmas very well, is this a regression? --- ghcide/test/exe/FuzzySearch.hs | 4 ++-- .../src/Development/IDE/Plugin/CodeAction.hs | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/ghcide/test/exe/FuzzySearch.hs b/ghcide/test/exe/FuzzySearch.hs index f565b94526..7bf8d37b19 100644 --- a/ghcide/test/exe/FuzzySearch.hs +++ b/ghcide/test/exe/FuzzySearch.hs @@ -87,7 +87,7 @@ referenceImplementation :: (t -> s) -> -- | The original value, rendered string and score. Maybe (Fuzzy t s) -referenceImplementation pattern t pre post extract = +referenceImplementation pat t pre post extract = if null pat then Just (Fuzzy t result totalScore) else Nothing where null :: (T.TextualMonoid s) => s -> Bool @@ -118,7 +118,7 @@ referenceImplementation pattern t pre post extract = ( 0, 1, -- matching at the start gives a bonus (cur = 1) mempty, - pattern, + pat, True ) s diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 5bf93f9105..b969a8b7cb 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -65,10 +65,10 @@ import Development.IDE.Plugin.Plugins.FillHole (suggestFillH import Development.IDE.Plugin.Plugins.FillTypeWildcard (suggestFillTypeWildcard) import Development.IDE.Plugin.Plugins.ImportUtils import Development.IDE.Plugin.TypeLenses (suggestSignature) +import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options -import Development.IDE.Types.Diagnostics import GHC (AddEpAnn (AddEpAnn), AnnsModule (am_main), DeltaPos (..), @@ -2008,6 +2008,7 @@ smallerRangesForBindingExport lies b = | T.unpack (printOutputable thing) == b' = [] | otherwise = [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] +#endif ranges' _ = [] rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] From dd3da46e9eb4ca58b41c27cd0ba0c7c97e12f262 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sat, 29 Jun 2024 19:36:09 +0100 Subject: [PATCH 37/44] Qualify s, t for FuzzySearch --- ghcide/test/exe/FuzzySearch.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/test/exe/FuzzySearch.hs b/ghcide/test/exe/FuzzySearch.hs index 7bf8d37b19..bde9aaa957 100644 --- a/ghcide/test/exe/FuzzySearch.hs +++ b/ghcide/test/exe/FuzzySearch.hs @@ -73,7 +73,7 @@ dictionary = unsafePerformIO $ do then map pack . words <$> readFile dictionaryPath else pure [] -referenceImplementation :: +referenceImplementation :: forall s t. (T.TextualMonoid s) => -- | Pattern in lowercase except for first character s -> From 4fd35fd9b9882d3bf145d7acb3ad14ab60d37658 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sat, 29 Jun 2024 19:46:09 +0100 Subject: [PATCH 38/44] Ignore use of unsafePerformIO in FuzzySearch --- ghcide/test/exe/FuzzySearch.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/test/exe/FuzzySearch.hs b/ghcide/test/exe/FuzzySearch.hs index bde9aaa957..6739da60da 100644 --- a/ghcide/test/exe/FuzzySearch.hs +++ b/ghcide/test/exe/FuzzySearch.hs @@ -65,6 +65,7 @@ replaceAt t i c = dictionaryPath :: FilePath dictionaryPath = "/usr/share/dict/words" +{-# ANN dictionary "HLint: ignore Avoid restricted function" #-} {-# NOINLINE dictionary #-} dictionary :: [Text] dictionary = unsafePerformIO $ do From 6a66ad2344f374e667946353239cdf7f47e39ee3 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 30 Jun 2024 01:36:31 +0100 Subject: [PATCH 39/44] Properly split GHC.Types.Error import in Diagnostics for stylish-haskell --- ghcide/src/Development/IDE/Types/Diagnostics.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index a690a04203..60dcce3c6c 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -40,11 +40,17 @@ import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope, flagSpecName, wWarningFlags) import Development.IDE.Types.Location import GHC.Generics +#if MIN_VERSION_ghc(9,6,1) import GHC.Types.Error (DiagnosticCode (..), DiagnosticReason (..), diagnosticCode, diagnosticReason, errMsgDiagnostic) +#else +import GHC.Types.Error (DiagnosticReason (..), + diagnosticReason, + errMsgDiagnostic) +#endif import Language.LSP.Diagnostics import Language.LSP.Protocol.Lens (data_) import Language.LSP.Protocol.Types as LSP From 679bc6bce682f183bde5b2c1b5abc6b209c435b6 Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Sun, 30 Jun 2024 01:49:41 +0100 Subject: [PATCH 40/44] Force type signature of annotation on FuzzySearch.dictionary --- ghcide/test/exe/FuzzySearch.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/test/exe/FuzzySearch.hs b/ghcide/test/exe/FuzzySearch.hs index 6739da60da..3bc3ecb4b1 100644 --- a/ghcide/test/exe/FuzzySearch.hs +++ b/ghcide/test/exe/FuzzySearch.hs @@ -65,7 +65,7 @@ replaceAt t i c = dictionaryPath :: FilePath dictionaryPath = "/usr/share/dict/words" -{-# ANN dictionary "HLint: ignore Avoid restricted function" #-} +{-# ANN dictionary ("HLint: ignore Avoid restricted function" :: String) #-} {-# NOINLINE dictionary #-} dictionary :: [Text] dictionary = unsafePerformIO $ do From de8bfaa2798d68bd219744fa86a7347b38913f0a Mon Sep 17 00:00:00 2001 From: Dylan Thinnes Date: Wed, 3 Jul 2024 00:54:53 +0100 Subject: [PATCH 41/44] DRY up definition of closure_errs From review https://github.com/haskell/haskell-language-server/pull/4311#discussion_r1661179289 --- ghcide/session-loader/Development/IDE/Session.hs | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index db8981dc66..d89141c857 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -876,28 +876,22 @@ newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4 Compat.initUnits dfs hsc_env -#if MIN_VERSION_ghc(9,6,1) let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') closure_err_to_multi_err err = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp (T.pack (Compat.printWithoutUniques (singleMessage err))) +#if MIN_VERSION_ghc(9,6,1) (Just (fmap GhcDriverMessage err)) - multi_errs = map closure_err_to_multi_err closure_errs - bad_units = OS.fromList $ concat $ do - x <- map errMsgDiagnostic closure_errs - DriverHomePackagesNotClosed us <- pure x - pure us - isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units #else - let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') - multi_errs = map (\diag -> ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp (T.pack (Compat.printWithoutUniques (singleMessage diag))) Nothing) closure_errs + Nothing +#endif + multi_errs = map closure_err_to_multi_err closure_errs bad_units = OS.fromList $ concat $ do x <- map errMsgDiagnostic closure_errs DriverHomePackagesNotClosed us <- pure x pure us isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units -#endif -- Whenever we spin up a session on Linux, dynamically load libm.so.6 -- in. We need this in case the binary is statically linked, in which -- case the interactive session will fail when trying to load From 5177e65cc9387fc41ef31dd4de2350b7689d2956 Mon Sep 17 00:00:00 2001 From: Jaro Reinders Date: Thu, 17 Oct 2024 09:05:38 +0200 Subject: [PATCH 42/44] Remove unused imports --- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs | 3 +-- .../src/Development/IDE/Plugin/CodeAction.hs | 1 - plugins/hls-refactor-plugin/test/Main.hs | 1 - plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs | 1 - 4 files changed, 1 insertion(+), 5 deletions(-) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs index 5425c419d7..a0cea4dc9e 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -13,8 +13,7 @@ where import Control.Lens ((&), (.~)) import qualified Data.Text as T -import Development.IDE (FileDiagnostic, - ShowDiagnostic (ShowDiag)) +import Development.IDE (FileDiagnostic) import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, ideErrorWithSource) import Distribution.Fields (showPError, showPWarning) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index b969a8b7cb..6c283e512a 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -88,7 +88,6 @@ import Language.LSP.Protocol.Types (ApplyWorkspa CodeActionKind (CodeActionKind_QuickFix), CodeActionParams (CodeActionParams), Command, - Diagnostic (..), MessageType (..), Null (Null), ShowMessageParams (..), diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index d4fb0cac47..2efff8c9cb 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -21,7 +21,6 @@ import Data.Foldable import Data.List.Extra import Data.Maybe import qualified Data.Text as T -import Data.Tuple.Extra import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types (extendImportCommandId) import Development.IDE.Test diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index 1fc7fa42c2..51e0055031 100644 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -14,7 +14,6 @@ import qualified Data.Text as T import Development.IDE import Development.IDE.Core.Rules (getHieFile) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Types.Diagnostics import GHC.Generics (Generic) import Ide.Plugin.Config (PluginConfig (..)) import Ide.Types (PluginDescriptor (..), From e651d41ba505c61c352fff4457d79f0f5cc0f68a Mon Sep 17 00:00:00 2001 From: Jaro Reinders Date: Thu, 17 Oct 2024 10:10:59 +0200 Subject: [PATCH 43/44] Post-rebase fixes --- ghcide/src/Development/IDE/Core/Compile.hs | 2 +- .../src/Development/IDE/Plugin/CodeAction.hs | 1 - test/functional/Config.hs | 4 ++-- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 1ad641e086..54df1cdd12 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -190,7 +190,7 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do etcm <- let -- TODO: maybe setting ms_hspp_opts is unnecessary? - mod_summary' = modSummary { ms_hspp_opts = hsc_dflags session} + mod_summary' = modSummary { ms_hspp_opts = hsc_dflags hscEnv} in catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary'} diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 6c283e512a..ae58245734 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -2007,7 +2007,6 @@ smallerRangesForBindingExport lies b = | T.unpack (printOutputable thing) == b' = [] | otherwise = [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] -#endif ranges' _ = [] rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 222feac7c3..668056fdb6 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -110,7 +110,7 @@ type instance RuleResult GetTestDiagnostics = () expectDiagnosticsFail :: HasCallStack - => ExpectBroken 'Ideal [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] - -> ExpectBroken 'Current [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] + => ExpectBroken 'Ideal [(FilePath, [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text)])] + -> ExpectBroken 'Current [(FilePath, [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text)])] -> Session () expectDiagnosticsFail _ = expectDiagnostics . unCurrent From b627909a58ea75694f1a30468b56225ed1c01839 Mon Sep 17 00:00:00 2001 From: Jaro Reinders Date: Thu, 17 Oct 2024 11:23:25 +0200 Subject: [PATCH 44/44] stylish-haskell formatting --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- .../hls-stan-plugin/src/Ide/Plugin/Stan.hs | 83 +++++++++---------- 2 files changed, 40 insertions(+), 45 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 666f6777d7..ef569b7758 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -158,8 +158,8 @@ import Development.IDE.Types.Shake import qualified Focus import GHC.Fingerprint import GHC.Stack (HasCallStack) -import GHC.Types.Error (errMsgDiagnostic) import GHC.TypeLits (KnownSymbol) +import GHC.Types.Error (errMsgDiagnostic) import HieDb.Types import Ide.Logger hiding (Priority) import qualified Ide.Logger as Logger diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index 51e0055031..a1efb7f150 100644 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -2,51 +2,46 @@ {-# LANGUAGE PatternSynonyms #-} module Ide.Plugin.Stan (descriptor, Log) where -import Compat.HieTypes (HieFile (..)) -import Control.DeepSeq (NFData) -import Control.Monad (void) -import Control.Monad.IO.Class (liftIO) -import Data.Foldable (toList) -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as HM -import Data.Maybe (mapMaybe) -import qualified Data.Text as T +import Compat.HieTypes (HieFile (..)) +import Control.DeepSeq (NFData) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Foldable (toList) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (mapMaybe) +import qualified Data.Text as T import Development.IDE -import Development.IDE.Core.Rules (getHieFile) -import qualified Development.IDE.Core.Shake as Shake -import GHC.Generics (Generic) -import Ide.Plugin.Config (PluginConfig (..)) -import Ide.Types (PluginDescriptor (..), - PluginId, - configHasDiagnostics, - configInitialGenericConfig, - defaultConfigDescriptor, - defaultPluginDescriptor) -import qualified Language.LSP.Protocol.Types as LSP -import Stan (createCabalExtensionsMap, - getStanConfig) -import Stan.Analysis (Analysis (..), runAnalysis) -import Stan.Category (Category (..)) -import Stan.Cli (StanArgs (..)) -import Stan.Config (Config, ConfigP (..), - applyConfig) -import Stan.Config.Pretty (prettyConfigCli) -import Stan.Core.Id (Id (..)) -import Stan.EnvVars (EnvVars (..), envVarsToText) -import Stan.Inspection (Inspection (..)) -import Stan.Inspection.All (inspectionsIds, - inspectionsMap) -import Stan.Observation (Observation (..)) -import Stan.Report.Settings (OutputSettings (..), - ToggleSolution (..), - Verbosity (..)) -import Stan.Toml (usedTomlFiles) -import System.Directory (makeRelativeToCurrentDirectory) -import Trial (Fatality, Trial (..), - fiasco, pattern FiascoL, - pattern ResultL, - prettyTrial, - prettyTrialWith) +import Development.IDE.Core.Rules (getHieFile) +import qualified Development.IDE.Core.Shake as Shake +import GHC.Generics (Generic) +import Ide.Plugin.Config (PluginConfig (..)) +import Ide.Types (PluginDescriptor (..), PluginId, + configHasDiagnostics, + configInitialGenericConfig, + defaultConfigDescriptor, + defaultPluginDescriptor) +import qualified Language.LSP.Protocol.Types as LSP +import Stan (createCabalExtensionsMap, + getStanConfig) +import Stan.Analysis (Analysis (..), runAnalysis) +import Stan.Category (Category (..)) +import Stan.Cli (StanArgs (..)) +import Stan.Config (Config, ConfigP (..), applyConfig) +import Stan.Config.Pretty (prettyConfigCli) +import Stan.Core.Id (Id (..)) +import Stan.EnvVars (EnvVars (..), envVarsToText) +import Stan.Inspection (Inspection (..)) +import Stan.Inspection.All (inspectionsIds, inspectionsMap) +import Stan.Observation (Observation (..)) +import Stan.Report.Settings (OutputSettings (..), + ToggleSolution (..), + Verbosity (..)) +import Stan.Toml (usedTomlFiles) +import System.Directory (makeRelativeToCurrentDirectory) +import Trial (Fatality, Trial (..), fiasco, + pattern FiascoL, pattern ResultL, + prettyTrial, prettyTrialWith) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId desc)