Skip to content

Commit 0ecb2ad

Browse files
dyniecdyniec
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 0ecb2ad

File tree

2 files changed

+65
-12
lines changed

2 files changed

+65
-12
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: 64 additions & 12 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,34 @@ 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+
96+
97+
let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule
98+
nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents
99+
activeDiagnosticsInRange (shakeExtras state) normalizedFilePath caRange >>= \case
100+
Nothing -> pure $ LSP.InL []
101+
Just fileDiags -> do
102+
let actions = concatMap (mkSuggest parsedModuleDynFlags) fileDiags
103+
pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> nubOrdOn snd actions
104+
mkCodeActionProvider96 :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
105+
mkCodeActionProvider96 mkSuggest state _plId
79106
(LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do
80107
normalizedFilePath <- getNormalizedFilePathE uri
81108
-- ghc session to get some dynflags even if module isn't parsed
@@ -89,7 +116,6 @@ mkCodeActionProvider mkSuggest state _plId
89116
pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits
90117

91118

92-
93119
-- | Add a Pragma to the given URI at the top of the file.
94120
-- It is assumed that the pragma name is a valid pragma,
95121
-- thus, not validated.
@@ -115,15 +141,12 @@ pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdit
115141
Nothing
116142
Nothing
117143

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

122145
-- ---------------------------------------------------------------------
123146

124-
suggestDisableWarning :: Diagnostic -> [PragmaEdit]
147+
suggestDisableWarning :: FileDiagnostic -> [PragmaEdit]
125148
suggestDisableWarning diagnostic
126-
| Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? attachedReason
149+
| Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? fdLspDiagnosticL . attachedReason
127150
=
128151
[ ("Disable \"" <> w <> "\" warnings", OptGHC w)
129152
| JSON.String attachedReason <- Foldable.toList attachedReasons
@@ -142,10 +165,24 @@ warningBlacklist =
142165

143166
-- ---------------------------------------------------------------------
144167

168+
-- | Offer to add a missing Language Pragma to the top of a file.
169+
suggestAddPragma :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]
170+
suggestAddPragma mDynflags fd= [("Add \"" <> r <> "\"", LangExt r) | r <- map (T.pack . show) $ suggestsExtension fd, r `notElem` disabled]
171+
where
172+
disabled
173+
| Just dynFlags <- mDynflags =
174+
-- GHC does not export 'OnOff', so we have to view it as string
175+
mapMaybe (T.stripPrefix "Off " . printOutputable) (extensions dynFlags)
176+
| otherwise =
177+
-- When the module failed to parse, we don't have access to its
178+
-- dynFlags. In that case, simply don't disable any pragmas.
179+
[]
180+
145181
-- | Offer to add a missing Language Pragma to the top of a file.
146182
-- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'.
147-
suggestAddPragma :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
148-
suggestAddPragma mDynflags Diagnostic {_message, _source}
183+
-- Kept for compatibility with ghc9.6 - it is missing some structured diagnostics
184+
suggestAddPragma96 :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
185+
suggestAddPragma96 mDynflags Diagnostic {_message, _source}
149186
| _source == Just sourceTypecheck || _source == Just sourceParser = genPragma _message
150187
where
151188
genPragma target =
@@ -158,8 +195,7 @@ suggestAddPragma mDynflags Diagnostic {_message, _source}
158195
-- When the module failed to parse, we don't have access to its
159196
-- dynFlags. In that case, simply don't disable any pragmas.
160197
[]
161-
suggestAddPragma _ _ = []
162-
198+
suggestAddPragma96 _ _ = []
163199
-- | Find all Pragmas are an infix of the search term.
164200
findPragma :: T.Text -> [T.Text]
165201
findPragma str = concatMap check possiblePragmas
@@ -178,6 +214,22 @@ findPragma str = concatMap check possiblePragmas
178214
, "Strict" /= name
179215
]
180216

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

0 commit comments

Comments
 (0)