Skip to content

Commit 1672a81

Browse files
dyniecdyniec
committed
WIP: Use structured diagnostics in pragmas plugin
1 parent 349ff6e commit 1672a81

File tree

2 files changed

+51
-24
lines changed

2 files changed

+51
-24
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: 50 additions & 24 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,23 @@ 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 (_TcRnMessage,
32+
msgEnvelopeErrorL,
33+
stripTcRnMessageContext)
3234
import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority)
3335
import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope)
3436
import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))
3537
import qualified Development.IDE.Spans.Pragmas as Pragmas
38+
import GHC.Types.Error (GhcHint (SuggestExtension),
39+
LanguageExtensionHint (..),
40+
diagnosticHints)
3641
import Ide.Plugin.Error
3742
import Ide.Types
3843
import qualified Language.LSP.Protocol.Lens as L
@@ -74,19 +79,27 @@ suggestPragmaProvider = mkCodeActionProvider suggest
7479
suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
7580
suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning
7681

77-
mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
82+
mkCodeActionProvider :: (Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction
7883
mkCodeActionProvider mkSuggest state _plId
79-
(LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do
84+
(LSP.CodeActionParams _ _ docId@LSP.TextDocumentIdentifier{ _uri = uri } caRange _) = do
85+
verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId
8086
normalizedFilePath <- getNormalizedFilePathE uri
8187
-- ghc session to get some dynflags even if module isn't parsed
8288
(hscEnv -> hsc_dflags -> sessionDynFlags, _) <-
8389
runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath
8490
fileContents <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath
8591
parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath
92+
93+
8694
let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule
8795
nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents
88-
pedits = nubOrdOn snd $ concatMap (mkSuggest parsedModuleDynFlags) diags
89-
pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits
96+
activeDiagnosticsInRange (shakeExtras state) normalizedFilePath caRange >>= \case
97+
Nothing -> pure $ LSP.InL []
98+
Just fileDiags -> do
99+
let actions = concatMap (mkSuggest parsedModuleDynFlags) fileDiags
100+
pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> actions
101+
-- pedits = nubOrdOn snd $ concatMap (mkSuggest parsedModuleDynFlags) diags
102+
-- pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits
90103

91104

92105

@@ -115,22 +128,23 @@ pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdit
115128
Nothing
116129
Nothing
117130

118-
suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit]
131+
suggest :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]
119132
suggest dflags diag =
120133
suggestAddPragma dflags diag
121134

122135
-- ---------------------------------------------------------------------
123136

124-
suggestDisableWarning :: Diagnostic -> [PragmaEdit]
125-
suggestDisableWarning diagnostic
126-
| Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? attachedReason
127-
=
128-
[ ("Disable \"" <> w <> "\" warnings", OptGHC w)
129-
| JSON.String attachedReason <- Foldable.toList attachedReasons
130-
, Just w <- [T.stripPrefix "-W" attachedReason]
131-
, w `notElem` warningBlacklist
132-
]
133-
| otherwise = []
137+
suggestDisableWarning :: FileDiagnostic -> [PragmaEdit]
138+
suggestDisableWarning _ = []
139+
-- suggestDisableWarning diagnostic
140+
-- | Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? attachedReason
141+
-- =
142+
-- [ ("Disable \"" <> w <> "\" warnings", OptGHC w)
143+
-- | JSON.String attachedReason <- Foldable.toList attachedReasons
144+
-- , Just w <- [T.stripPrefix "-W" attachedReason]
145+
-- , w `notElem` warningBlacklist
146+
-- ]
147+
-- | otherwise = []
134148

135149
warningBlacklist :: [T.Text]
136150
warningBlacklist =
@@ -144,12 +158,11 @@ warningBlacklist =
144158

145159
-- | Offer to add a missing Language Pragma to the top of a file.
146160
-- 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
161+
suggestAddPragma :: Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]
162+
suggestAddPragma mDynflags fd= filterPragma fd
150163
where
151-
genPragma target =
152-
[("Add \"" <> r <> "\"", LangExt r) | r <- findPragma target, r `notElem` disabled]
164+
filterPragma fd =
165+
[("Add \"" <> r <> "\"", LangExt r) | r <- map (T.pack . show) $ suggestsExtension fd, r `notElem` disabled]
153166
disabled
154167
| Just dynFlags <- mDynflags =
155168
-- GHC does not export 'OnOff', so we have to view it as string
@@ -158,7 +171,20 @@ suggestAddPragma mDynflags Diagnostic {_message, _source}
158171
-- When the module failed to parse, we don't have access to its
159172
-- dynFlags. In that case, simply don't disable any pragmas.
160173
[]
161-
suggestAddPragma _ _ = []
174+
175+
suggestsExtension :: FileDiagnostic -> [Extension]
176+
suggestsExtension message = case stripTcRnMessageContext <$> (message ^? fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage) of
177+
Just s -> concat $ mapMaybe (\case
178+
SuggestExtension s -> Just $ ghcHintSuggestsExtension s
179+
_ -> Nothing) (diagnosticHints s)
180+
_ -> []
181+
182+
ghcHintSuggestsExtension :: LanguageExtensionHint -> [Extension]
183+
ghcHintSuggestsExtension (SuggestSingleExtension _ ext) = [ext]
184+
ghcHintSuggestsExtension (SuggestAnyExtension _ (ext:_)) = [ext] -- ghc suggests any of those, we pick first
185+
ghcHintSuggestsExtension (SuggestAnyExtension _ []) = []
186+
ghcHintSuggestsExtension (SuggestExtensions _ ext) = ext
187+
ghcHintSuggestsExtension (SuggestExtensionInOrderTo _ ext) = [ext]
162188

163189
-- | Find all Pragmas are an infix of the search term.
164190
findPragma :: T.Text -> [T.Text]

0 commit comments

Comments
 (0)