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 90eb271

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 90eb271

File tree

2 files changed

+62
-13
lines changed

2 files changed

+62
-13
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: 61 additions & 13 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 #-}
@@ -27,12 +28,17 @@ import qualified Data.Text as T
2728
import Development.IDE hiding (line)
2829
import Development.IDE.Core.Compile (sourceParser,
2930
sourceTypecheck)
31+
import Development.IDE.Core.FileStore (getVersionedTextDoc)
3032
import Development.IDE.Core.PluginUtils
3133
import Development.IDE.GHC.Compat
34+
import Development.IDE.GHC.Compat.Error (msgEnvelopeErrorL)
3235
import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority)
3336
import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope)
3437
import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))
3538
import qualified Development.IDE.Spans.Pragmas as Pragmas
39+
import GHC.Types.Error (GhcHint (SuggestExtension),
40+
LanguageExtensionHint (..),
41+
diagnosticHints)
3642
import Ide.Plugin.Error
3743
import Ide.Types
3844
import qualified Language.LSP.Protocol.Lens as L
@@ -69,13 +75,33 @@ data Pragma = LangExt T.Text | OptGHC T.Text
6975
deriving (Show, Eq, Ord)
7076

7177
suggestPragmaProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
72-
suggestPragmaProvider = mkCodeActionProvider suggest
78+
suggestPragmaProvider = if ghcVersion /= GHC96 then
79+
mkCodeActionProvider suggestAddPragma
80+
else mkCodeActionProvider96 suggestAddPragma96
7381

7482
suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
7583
suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning
7684

77-
mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
85+
mkCodeActionProvider :: (Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
7886
mkCodeActionProvider mkSuggest state _plId
87+
(LSP.CodeActionParams _ _ docId@LSP.TextDocumentIdentifier{ _uri = uri } caRange _) = do
88+
verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId
89+
normalizedFilePath <- getNormalizedFilePathE (verTxtDocId ^. L.uri)
90+
-- ghc session to get some dynflags even if module isn't parsed
91+
(hscEnv -> hsc_dflags -> sessionDynFlags, _) <-
92+
runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath
93+
fileContents <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath
94+
parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath
95+
let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule
96+
nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents
97+
activeDiagnosticsInRange (shakeExtras state) normalizedFilePath caRange >>= \case
98+
Nothing -> pure $ LSP.InL []
99+
Just fileDiags -> do
100+
let actions = concatMap (mkSuggest parsedModuleDynFlags) fileDiags
101+
pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> nubOrdOn snd actions
102+
103+
mkCodeActionProvider96 :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
104+
mkCodeActionProvider96 mkSuggest state _plId
79105
(LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do
80106
normalizedFilePath <- getNormalizedFilePathE uri
81107
-- ghc session to get some dynflags even if module isn't parsed
@@ -89,7 +115,6 @@ mkCodeActionProvider mkSuggest state _plId
89115
pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits
90116

91117

92-
93118
-- | Add a Pragma to the given URI at the top of the file.
94119
-- It is assumed that the pragma name is a valid pragma,
95120
-- thus, not validated.
@@ -108,22 +133,17 @@ pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdit
108133
, let LSP.TextEdit{ _range, _newText } = insertTextEdit ->
109134
[LSP.TextEdit _range (render p <> _newText), deleteTextEdit]
110135
| otherwise -> [LSP.TextEdit pragmaInsertRange (render p)]
111-
112136
edit =
113137
LSP.WorkspaceEdit
114138
(Just $ M.singleton uri textEdits)
115139
Nothing
116140
Nothing
117141

118-
suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
119-
suggest dflags diag =
120-
suggestAddPragma dflags diag
121-
122142
-- ---------------------------------------------------------------------
123143

124-
suggestDisableWarning :: Diagnostic -> [PragmaEdit]
144+
suggestDisableWarning :: FileDiagnostic -> [PragmaEdit]
125145
suggestDisableWarning diagnostic
126-
| Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? attachedReason
146+
| Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? fdLspDiagnosticL .attachedReason
127147
=
128148
[ ("Disable \"" <> w <> "\" warnings", OptGHC w)
129149
| JSON.String attachedReason <- Foldable.toList attachedReasons
@@ -142,10 +162,24 @@ warningBlacklist =
142162

143163
-- ---------------------------------------------------------------------
144164

165+
-- | Offer to add a missing Language Pragma to the top of a file.
166+
suggestAddPragma :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]
167+
suggestAddPragma mDynflags fd= [("Add \"" <> r <> "\"", LangExt r) | r <- map (T.pack . show) $ suggestsExtension fd, r `notElem` disabled]
168+
where
169+
disabled
170+
| Just dynFlags <- mDynflags =
171+
-- GHC does not export 'OnOff', so we have to view it as string
172+
mapMaybe (T.stripPrefix "Off " . printOutputable) (extensions dynFlags)
173+
| otherwise =
174+
-- When the module failed to parse, we don't have access to its
175+
-- dynFlags. In that case, simply don't disable any pragmas.
176+
[]
177+
145178
-- | Offer to add a missing Language Pragma to the top of a file.
146179
-- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'.
147-
suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
148-
suggestAddPragma mDynflags Diagnostic {_message, _source}
180+
-- Kept for compatibility with ghc9.6 - it is missing some structured diagnostics
181+
suggestAddPragma96 :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
182+
suggestAddPragma96 mDynflags Diagnostic {_message, _source}
149183
| _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message
150184
where
151185
genPragma target =
@@ -158,7 +192,7 @@ suggestAddPragma mDynflags Diagnostic {_message, _source}
158192
-- When the module failed to parse, we don't have access to its
159193
-- dynFlags. In that case, simply don't disable any pragmas.
160194
[]
161-
suggestAddPragma _ _ = []
195+
suggestAddPragma96 _ _ = []
162196

163197
-- | Find all Pragmas are an infix of the search term.
164198
findPragma :: T.Text -> [T.Text]
@@ -178,6 +212,20 @@ findPragma str = concatMap check possiblePragmas
178212
, "Strict" /= name
179213
]
180214

215+
suggestsExtension :: FileDiagnostic -> [Extension]
216+
suggestsExtension message = case message ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL of
217+
Just s -> concat $ map (\case
218+
SuggestExtension s -> ghcHintSuggestsExtension s
219+
_ -> []) (diagnosticHints s)
220+
_ -> []
221+
222+
ghcHintSuggestsExtension :: LanguageExtensionHint -> [Extension]
223+
ghcHintSuggestsExtension (SuggestSingleExtension _ ext) = [ext]
224+
ghcHintSuggestsExtension (SuggestAnyExtension _ (ext:_)) = [ext] -- ghc suggests any of those, we pick first
225+
ghcHintSuggestsExtension (SuggestAnyExtension _ []) = []
226+
ghcHintSuggestsExtension (SuggestExtensions _ ext) = ext
227+
ghcHintSuggestsExtension (SuggestExtensionInOrderTo _ ext) = [ext]
228+
181229
-- | All language pragmas, including the No- variants
182230
allPragmas :: [T.Text]
183231
allPragmas =

0 commit comments

Comments
(0)

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