Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 305eaab

Browse files
committed
Use structured diagnostics in pragmas plugin
Changes suggestion provider in pragmas plugin to use structured diagnostics and ghc machinery to generate hints
1 parent 349ff6e commit 305eaab

File tree

2 files changed

+39
-34
lines changed

2 files changed

+39
-34
lines changed

‎haskell-language-server.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -905,6 +905,7 @@ library hls-pragmas-plugin
905905
, text
906906
, transformers
907907
, containers
908+
, ghc
908909

909910
test-suite hls-pragmas-plugin-tests
910911
import: defaults, pedantic, test-defaults, warnings

‎plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs

Lines changed: 38 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE CPP #-}
22
{-# LANGUAGE DataKinds #-}
33
{-# LANGUAGE DuplicateRecordFields #-}
4+
{-# LANGUAGE LambdaCase #-}
45
{-# LANGUAGE MultiWayIf #-}
56
{-# LANGUAGE OverloadedStrings #-}
67
{-# LANGUAGE ViewPatterns #-}
@@ -25,14 +26,17 @@ import qualified Data.Map as M
2526
import Data.Maybe (mapMaybe)
2627
import qualified Data.Text as T
2728
import Development.IDE hiding (line)
28-
import Development.IDE.Core.Compile (sourceParser,
29-
sourceTypecheck)
29+
import Development.IDE.Core.FileStore (getVersionedTextDoc)
3030
import Development.IDE.Core.PluginUtils
3131
import Development.IDE.GHC.Compat
32+
import Development.IDE.GHC.Compat.Error (msgEnvelopeErrorL)
3233
import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority)
3334
import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope)
3435
import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))
3536
import qualified Development.IDE.Spans.Pragmas as Pragmas
37+
import GHC.Types.Error (GhcHint (SuggestExtension),
38+
LanguageExtensionHint (..),
39+
diagnosticHints)
3640
import Ide.Plugin.Error
3741
import Ide.Types
3842
import qualified Language.LSP.Protocol.Lens as L
@@ -74,19 +78,25 @@ suggestPragmaProvider = mkCodeActionProvider suggest
7478
suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
7579
suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning
7680

77-
mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
81+
mkCodeActionProvider :: (Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
7882
mkCodeActionProvider mkSuggest state _plId
79-
(LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do
80-
normalizedFilePath <- getNormalizedFilePathE uri
83+
(LSP.CodeActionParams _ _ docId@LSP.TextDocumentIdentifier{ _uri = uri } caRange _) = do
84+
verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId
85+
normalizedFilePath <- getNormalizedFilePathE (verTxtDocId ^. L.uri)
8186
-- ghc session to get some dynflags even if module isn't parsed
8287
(hscEnv -> hsc_dflags -> sessionDynFlags, _) <-
8388
runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath
8489
fileContents <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath
8590
parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath
91+
92+
8693
let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule
8794
nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents
88-
pedits = nubOrdOn snd $ concatMap (mkSuggest parsedModuleDynFlags) diags
89-
pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits
95+
activeDiagnosticsInRange (shakeExtras state) normalizedFilePath caRange >>= \case
96+
Nothing -> pure $ LSP.InL []
97+
Just fileDiags -> do
98+
let actions = concatMap (mkSuggest parsedModuleDynFlags) fileDiags
99+
pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> nubOrdOn snd actions
90100

91101

92102

@@ -115,15 +125,15 @@ pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdit
115125
Nothing
116126
Nothing
117127

118-
suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
128+
suggest :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]
119129
suggest dflags diag =
120130
suggestAddPragma dflags diag
121131

122132
-- ---------------------------------------------------------------------
123133

124-
suggestDisableWarning :: Diagnostic -> [PragmaEdit]
134+
suggestDisableWarning :: FileDiagnostic -> [PragmaEdit]
125135
suggestDisableWarning diagnostic
126-
| Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? attachedReason
136+
| Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? fdLspDiagnosticL .attachedReason
127137
=
128138
[ ("Disable \"" <> w <> "\" warnings", OptGHC w)
129139
| JSON.String attachedReason <- Foldable.toList attachedReasons
@@ -143,13 +153,10 @@ warningBlacklist =
143153
-- ---------------------------------------------------------------------
144154

145155
-- | Offer to add a missing Language Pragma to the top of a file.
146-
-- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'.
147-
suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
148-
suggestAddPragma mDynflags Diagnostic {_message, _source}
149-
| _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message
156+
-- Pragmas are defined by a cuNewrated list of known pragmas, see 'possiblePragmas'.
157+
suggestAddPragma :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]
158+
suggestAddPragma mDynflags fd= [("Add \"" <> r <> "\"", LangExt r) | r <- map (T.pack . show) $ suggestsExtension fd, r `notElem` disabled]
150159
where
151-
genPragma target =
152-
[("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled]
153160
disabled
154161
| Just dynFlags <- mDynflags =
155162
-- GHC does not export 'OnOff', so we have to view it as string
@@ -158,25 +165,22 @@ suggestAddPragma mDynflags Diagnostic {_message, _source}
158165
-- When the module failed to parse, we don't have access to its
159166
-- dynFlags. In that case, simply don't disable any pragmas.
160167
[]
161-
suggestAddPragma _ _ = []
162168

163-
-- | Find all Pragmas are an infix of the search term.
164-
findPragma :: T.Text -> [T.Text]
165-
findPragma str = concatMap check possiblePragmas
166-
where
167-
check p = [p | T.isInfixOf p str]
168-
169-
-- We exclude the Strict extension as it causes many false positives, see
170-
-- the discussion at https://github.com/haskell/ghcide/pull/638
171-
--
172-
-- We don't include the No- variants, as GHC never suggests disabling an
173-
-- extension in an error message.
174-
possiblePragmas :: [T.Text]
175-
possiblePragmas =
176-
[ name
177-
| FlagSpec{flagSpecName = T.pack -> name} <- xFlags
178-
, "Strict" /= name
179-
]
169+
suggestsExtension :: FileDiagnostic -> [Extension]
170+
suggestsExtension message = case message ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL of
171+
Just s -> concat $ mapMaybe (\case
172+
SuggestExtension s -> Just $ ghcHintSuggestsExtension s
173+
_ -> Nothing) (diagnosticHints s)
174+
_ -> []
175+
176+
ghcHintSuggestsExtension :: LanguageExtensionHint -> [Extension]
177+
ghcHintSuggestsExtension (SuggestSingleExtension _ ext) = [ext]
178+
ghcHintSuggestsExtension (SuggestAnyExtension _ (ext:_)) = [ext] -- ghc suggests any of those, we pick first
179+
ghcHintSuggestsExtension (SuggestAnyExtension _ []) = []
180+
ghcHintSuggestsExtension (SuggestExtensions _ ext) = ext
181+
ghcHintSuggestsExtension (SuggestExtensionInOrderTo _ ext) = [ext]
182+
183+
180184

181185
-- | All language pragmas, including the No- variants
182186
allPragmas :: [T.Text]

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /