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 079ed08

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 079ed08

File tree

2 files changed

+43
-35
lines changed

2 files changed

+43
-35
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: 42 additions & 35 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 #-}
@@ -20,19 +21,21 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
2021
import qualified Data.Aeson as JSON
2122
import Data.Char (isAlphaNum)
2223
import qualified Data.Foldable as Foldable
23-
import Data.List.Extra (nubOrdOn)
2424
import qualified Data.Map as M
2525
import Data.Maybe (mapMaybe)
2626
import qualified Data.Text as T
2727
import Development.IDE hiding (line)
28-
import Development.IDE.Core.Compile (sourceParser,
29-
sourceTypecheck)
28+
import Development.IDE.Core.FileStore (getVersionedTextDoc)
3029
import Development.IDE.Core.PluginUtils
3130
import Development.IDE.GHC.Compat
31+
import Development.IDE.GHC.Compat.Error (msgEnvelopeErrorL)
3232
import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority)
3333
import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope)
3434
import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))
3535
import qualified Development.IDE.Spans.Pragmas as Pragmas
36+
import GHC.Types.Error (GhcHint (SuggestExtension),
37+
LanguageExtensionHint (..),
38+
diagnosticHints)
3639
import Ide.Plugin.Error
3740
import Ide.Types
3841
import qualified Language.LSP.Protocol.Lens as L
@@ -74,19 +77,27 @@ suggestPragmaProvider = mkCodeActionProvider suggest
7477
suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
7578
suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning
7679

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

91102

92103

@@ -115,15 +126,15 @@ pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdit
115126
Nothing
116127
Nothing
117128

118-
suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
129+
suggest :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]
119130
suggest dflags diag =
120131
suggestAddPragma dflags diag
121132

122133
-- ---------------------------------------------------------------------
123134

124-
suggestDisableWarning :: Diagnostic -> [PragmaEdit]
135+
suggestDisableWarning :: FileDiagnostic -> [PragmaEdit]
125136
suggestDisableWarning diagnostic
126-
| Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? attachedReason
137+
| Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? fdLspDiagnosticL .attachedReason
127138
=
128139
[ ("Disable \"" <> w <> "\" warnings", OptGHC w)
129140
| JSON.String attachedReason <- Foldable.toList attachedReasons
@@ -143,13 +154,12 @@ warningBlacklist =
143154
-- ---------------------------------------------------------------------
144155

145156
-- | 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
157+
-- Pragmas are defined by a cuNewrated list of known pragmas, see 'possiblePragmas'.
158+
suggestAddPragma :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]
159+
suggestAddPragma mDynflags fd= filterPragma fd
150160
where
151-
genPragma target =
152-
[("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled]
161+
filterPragma fd =
162+
[("Add \"" <> r <> "\"", LangExt r) | r <- map (T.pack .show) $ suggestsExtension fd, r `notElem` disabled]--NOCOMMIT
153163
disabled
154164
| Just dynFlags <- mDynflags =
155165
-- GHC does not export 'OnOff', so we have to view it as string
@@ -158,25 +168,22 @@ suggestAddPragma mDynflags Diagnostic {_message, _source}
158168
-- When the module failed to parse, we don't have access to its
159169
-- dynFlags. In that case, simply don't disable any pragmas.
160170
[]
161-
suggestAddPragma _ _ = []
162171

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-
]
172+
suggestsExtension :: FileDiagnostic -> [Extension]
173+
suggestsExtension message = case message ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL of
174+
Just s -> concat $ mapMaybe (\case
175+
SuggestExtension s -> Just $ ghcHintSuggestsExtension s
176+
_ -> Nothing) (diagnosticHints s)
177+
_ -> []
178+
179+
ghcHintSuggestsExtension :: LanguageExtensionHint -> [Extension]
180+
ghcHintSuggestsExtension (SuggestSingleExtension _ ext) = [ext]
181+
ghcHintSuggestsExtension (SuggestAnyExtension _ (ext:_)) = [ext] -- ghc suggests any of those, we pick first
182+
ghcHintSuggestsExtension (SuggestAnyExtension _ []) = []
183+
ghcHintSuggestsExtension (SuggestExtensions _ ext) = ext
184+
ghcHintSuggestsExtension (SuggestExtensionInOrderTo _ ext) = [ext]
185+
186+
180187

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

0 commit comments

Comments
(0)

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