Skip to content

Resolve 2: Support for resolve in hls-hlint-plugin #3679

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 16 commits into from
Jun 30, 2023
Merged

Resolve 2: Support for resolve in hls-hlint-plugin #3679

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
16 commits
Select commit Hold shift + click to select a range
355e95c
Generic support for resolve in hls packages
joyfulmantis Jun 27, 2023
fb49c31
Add a new code action resolve helper that falls backs to commands
joyfulmantis Jun 27, 2023
985340b
Merge branch 'resolve-support' into hlint-resolve
joyfulmantis Jun 27, 2023
9712ca5
move suppress hint from a workspaceEdit to a command
joyfulmantis Jun 27, 2023
26af22d
Add support for resolve in hlint
joyfulmantis Jun 28, 2023
d1d299b
add resolve capability set to hls-test-utils
joyfulmantis Jun 28, 2023
6b7754e
Merge branch 'resolve-support' into hlint-resolve
joyfulmantis Jun 28, 2023
5335f1d
Add hlint tests for resolve
joyfulmantis Jun 28, 2023
735feca
Add code lens resolve support
joyfulmantis Jun 29, 2023
6b3b915
Merge branch 'master' into resolve-support
michaelpj Jun 29, 2023
a57e5d9
WIP
joyfulmantis Jun 29, 2023
d2ba87e
Merge branch 'resolve-support' into hlint-resolve
joyfulmantis Jun 29, 2023
57119c4
Remove all commands handling logic from hlint.
joyfulmantis Jun 29, 2023
9f9e807
Merge remote-tracking branch 'upstream/master' into hlint-resolve
joyfulmantis Jun 29, 2023
68080fb
Use pure instead of singleton to work with ghc 8.10
joyfulmantis Jun 30, 2023
1ac3823
Merge branch 'master' into hlint-resolve
joyfulmantis Jun 30, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
49 changes: 35 additions & 14 deletions hls-plugin-api/src/Ide/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -67,6 +67,7 @@ import Control.Lens (_Just, (.~), (?~), (^.), (^?))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Data.Aeson hiding (Null, defaultOptions)
import qualified Data.Aeson
import Data.Default
import Data.Dependent.Map (DMap)
import qualified Data.Dependent.Map as DMap
Expand All @@ -93,8 +94,10 @@ import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server (LspM, LspT,
ProgressCancellable (Cancellable),
getClientCapabilities,
getVirtualFile)
getVirtualFile, sendRequest,
withIndefiniteProgress)
import Language.LSP.VFS
import Numeric.Natural
import OpenTelemetry.Eventlog
Expand Down Expand Up @@ -1051,30 +1054,48 @@ mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod =
-- support. This means you don't have to check whether the client supports resolve
-- and act accordingly in your own providers.
mkCodeActionWithResolveAndCommand
:: forall ideState. (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null)))
:: forall ideState.
PluginId
-> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null)))
-> (ideState -> PluginId -> CodeAction -> LspM Config (Either ResponseError CodeAction))
-> PluginHandlers ideState
mkCodeActionWithResolveAndCommand codeActionMethod codeResolveMethod =
-> ([PluginCommand ideState], PluginHandlers ideState)
mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod =
let newCodeActionMethod ideState pid params = runExceptT $
do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params
caps <- lift getClientCapabilities
case codeActionReturn of
r@(InR Null) -> pure r
(InL ls) | -- If the client supports resolve, we will wrap the resolve data in a owned
-- resolve data type to allow the server to know who to send the resolve request to
-- and dump the command fields.
supportsCodeActionResolve caps ->
pure $ InL (dropCommands . wrapCodeActionResolveData pid <$> ls)
-- If they do not we will drop the data field.
| otherwise -> pure $ InL $ dropData <$> ls
pure $ InL (wrapCodeActionResolveData pid <$> ls)
-- If they do not we will drop the data field, in addition we will populate the command
-- field with our command to execute the resolve, with the whole code action as it's argument.
| otherwise -> pure $ InL $ moveDataToCommand <$> ls
newCodeResolveMethod ideState pid params =
codeResolveMethod ideState pid (unwrapCodeActionResolveData params)
in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod
<> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod
where dropData :: Command |? CodeAction -> Command |? CodeAction
dropData ca = ca & _R . L.data_ .~ Nothing
dropCommands :: Command |? CodeAction -> Command |? CodeAction
dropCommands ca = ca & _R . L.command .~ Nothing
in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd plId codeResolveMethod)],
mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod
<> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod)
where moveDataToCommand :: Command |? CodeAction -> Command |? CodeAction
moveDataToCommand ca =
let dat = toJSON <$> ca ^? _R -- We need to take the whole codeAction
-- And put it in the argument for the Command, that way we can later
-- pas it to the resolve handler (which expects a whole code action)
cmd = mkLspCommand plId (CommandId "codeActionResolve") "Execute Code Action" (pure <$> dat)
in ca
& _R . L.data_ .~ Nothing -- Set the data field to nothing
& _R . L.command ?~ cmd -- And set the command to our previously created command
executeResolveCmd :: PluginId -> PluginMethodHandler ideState Method_CodeActionResolve -> CommandFunction ideState CodeAction
executeResolveCmd pluginId resolveProvider ideState ca = do
withIndefiniteProgress "Executing code action..." Cancellable $ do
resolveResult <- resolveProvider ideState pluginId ca
case resolveResult of
Right CodeAction {_edit = Just wedits } -> do
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

What happens if it has the command set? It probably shouldn't, right? But maybe we should fail or at least log there.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Also, if it's cheap it would be nice to check that all the other fields of the code action are the same as the input one, i.e. the resolve handler only gave us an edit. In the more generalized case, we should check that the only fields that differ are the ones that the client says it can resolve. Then we can log if the handler does something wrong there.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Well, I guess also the command and data fields should be unset?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think, according to the spec, we can only change the set of resolvable fields, so even though it would make sense to dump the data field, it still needs to stay the same as when we received it. (We also don't have the client capabilities so can't do anything with that). Finally in this case the only thing we can execute on is the returned WorkspaceEdit. We can return an error if any other field is changed, but not sure about the performance penalty of doing that.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Can't we pass in the client caps here?

I don't know if it's worth doing the checking of field setting, it just seems like a way to sanity check plugins, which seems somewhat useful.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Okay, I guess we can't pass in the client capabilities here, but we should be able to pull them from the monad itself, since the plugin handler is effectively in the Lsp monad already

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ah I see, this is exactly the sort of thing we could do if we had the client caps when making the handlers!

_ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ())
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It seems like we probably should care a little about the response? e.g. we probably want to do something if we fail, like at least log

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

That's quite hard here, as we can't use a recorder (That's defined in the ghcide package, so cyclic dependency), and we only have a callback to work with.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ugh. Okay, I guess we can't do much here, but that's rather unsatisfying. Maybe we need to move some of the recorder stuff into hls-plugin-api as the "lowest" package.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I would really like to be able to do some logging in the generic functions you're defining, that way we can get somewhat-decent logging for lots of plugins by defining it in one place.

pure $ Right Data.Aeson.Null
Right _ -> pure $ Left $ responseError "No edit in CodeAction"
Left err -> pure $ Left err

supportsCodeActionResolve :: ClientCapabilities -> Bool
supportsCodeActionResolve caps =
Expand Down
156 changes: 67 additions & 89 deletions plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -40,7 +40,7 @@ import Control.Arrow ((&&&))
import Control.Concurrent.STM
import Control.DeepSeq
import Control.Exception
import Control.Lens ((^.))
import Control.Lens ((?~), (^.))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
Expand Down Expand Up @@ -127,10 +127,7 @@ import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types hiding
(Null)
import qualified Language.LSP.Protocol.Types as LSP
import Language.LSP.Server (ProgressCancellable (Cancellable),
getVersionedTextDoc,
sendRequest,
withIndefiniteProgress)
import Language.LSP.Server (getVersionedTextDoc)

import qualified Development.IDE.Core.Shake as Shake
import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits),
Expand All @@ -146,6 +143,8 @@ import GHC.Generics (Generic)
import System.Environment (setEnv,
unsetEnv)
#endif
import Data.Aeson (Result (Error, Success),
fromJSON)
import Text.Regex.TDFA.Text ()
-- ---------------------------------------------------------------------

Expand Down Expand Up @@ -188,13 +187,12 @@ fromStrictMaybe Strict.Nothing = Nothing
#endif

descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor recorder plId = (defaultPluginDescriptor plId)
descriptor recorder plId =
let (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand plId codeActionProvider (resolveProvider recorder)
in (defaultPluginDescriptor plId)
{ pluginRules = rules recorder plId
, pluginCommands =
[ PluginCommand "applyOne" "Apply a single hint" (applyOneCmd recorder)
, PluginCommand "applyAll" "Apply all hints to the file" (applyAllCmd recorder)
]
, pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider
, pluginCommands = pluginCommands
, pluginHandlers = pluginHandlers
, pluginConfigDescriptor = defaultConfigDescriptor
{ configHasDiagnostics = True
, configCustomConfig = mkCustomConfig properties
Expand Down Expand Up @@ -396,21 +394,9 @@ getHlintConfig pId =
Config
<$> usePropertyAction #flags pId properties

runHlintAction
:: (Eq k, Hashable k, Show k, Show (RuleResult k), Typeable k, Typeable (RuleResult k), NFData k, NFData (RuleResult k))
=> IdeState
-> NormalizedFilePath -> String -> k -> IO (Maybe (RuleResult k))
runHlintAction ideState normalizedFilePath desc rule = runAction desc ideState $ use rule normalizedFilePath

runGetFileContentsAction :: IdeState -> NormalizedFilePath -> IO (Maybe (FileVersion, Maybe T.Text))
runGetFileContentsAction ideState normalizedFilePath = runHlintAction ideState normalizedFilePath "Hlint.GetFileContents" GetFileContents

runGetModSummaryAction :: IdeState -> NormalizedFilePath -> IO (Maybe ModSummaryResult)
runGetModSummaryAction ideState normalizedFilePath = runHlintAction ideState normalizedFilePath "Hlint.GetModSummary" GetModSummary

-- ---------------------------------------------------------------------
codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction
codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context)
codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context)
| let TextDocumentIdentifier uri = documentId
, Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri)
= do
Expand All @@ -427,16 +413,7 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context)
[diagnostic | diagnostic <- diags
, validCommand diagnostic
]
file <- runGetFileContentsAction ideState docNormalizedFilePath
singleHintCodeActions <-
if | Just (_, source) <- file -> do
modSummaryResult <- runGetModSummaryAction ideState docNormalizedFilePath
pure if | Just modSummaryResult <- modSummaryResult
, Just source <- source
, let dynFlags = ms_hspp_opts $ msrModSummary modSummaryResult ->
diags >>= diagnosticToCodeActions dynFlags source pluginId verTxtDocId
| otherwise -> []
| otherwise -> pure []
let singleHintCodeActions = diags >>= diagnosticToCodeActions verTxtDocId
if numHintsInDoc > 1 && numHintsInContext > 0 then do
pure $ singleHintCodeActions ++ [applyAllAction verTxtDocId]
else
Expand All @@ -446,9 +423,8 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context)

where
applyAllAction verTxtDocId =
let args = Just [toJSON verTxtDocId]
cmd = mkLspCommand pluginId "applyAll" "Apply all hints" args
in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionKind_QuickFix) Nothing Nothing Nothing Nothing (Just cmd) Nothing
let args = Just $ toJSON (AA verTxtDocId)
in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionKind_QuickFix) Nothing Nothing Nothing Nothing Nothing args

-- |Some hints do not have an associated refactoring
validCommand (LSP.Diagnostic _ _ (Just (InR code)) _ (Just "hlint") _ _ _ _) =
Expand All @@ -458,44 +434,57 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context)

diags = context ^. LSP.diagnostics

resolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_CodeActionResolve
resolveProvider recorder ideState _pluginId ca@CodeAction {_data_ = Just data_} = pluginResponse $ do
case fromJSON data_ of
(Success (AA verTxtDocId@(VersionedTextDocumentIdentifier uri _))) -> do
file <- getNormalizedFilePath uri
edit <- ExceptT $ liftIO $ applyHint recorder ideState file Nothing verTxtDocId
pure $ ca & LSP.edit ?~ edit
(Success (AO verTxtDocId@(VersionedTextDocumentIdentifier uri _) pos hintTitle)) -> do
let oneHint = OneHint pos hintTitle
file <- getNormalizedFilePath uri
edit <- ExceptT $ liftIO $ applyHint recorder ideState file (Just oneHint) verTxtDocId
pure $ ca & LSP.edit ?~ edit
(Success (IH verTxtDocId@(VersionedTextDocumentIdentifier uri _) hintTitle )) -> do
file <- getNormalizedFilePath uri
edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle
pure $ ca & LSP.edit ?~ edit
Error s-> throwE ("JSON decoding error: " <> s)
resolveProvider _ _ _ _ = pluginResponse $ throwE "CodeAction with no data field"

-- | Convert a hlint diagnostic into an apply and an ignore code action
-- if applicable
diagnosticToCodeActions :: DynFlags -> T.Text -> PluginId -> VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]
diagnosticToCodeActions dynFlags fileContents pluginId verTxtDocId diagnostic
diagnosticToCodeActions :: VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]
diagnosticToCodeActions verTxtDocId diagnostic
| LSP.Diagnostic{ _source = Just "hlint", _code = Just (InR code), _range = LSP.Range start _ } <- diagnostic
, let isHintApplicable = "refact:" `T.isPrefixOf` code
, let hint = T.replace "refact:" "" code
, let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module"
, let suppressHintTextEdits = mkSuppressHintTextEdits dynFlags fileContents hint
, let suppressHintWorkspaceEdit =
LSP.WorkspaceEdit
(Just (M.singleton (verTxtDocId ^. LSP.uri) suppressHintTextEdits))
Nothing
Nothing
, let suppressHintArguments = IH verTxtDocId hint
= catMaybes
-- Applying the hint is marked preferred because it addresses the underlying error.
-- Disabling the rule isn't, because less often used and configuration can be adapted.
[ if | isHintApplicable
, let applyHintTitle = "Apply hint \"" <> hint <> "\""
applyHintArguments = [toJSON (AOP verTxtDocId start hint)]
applyHintCommand = mkLspCommand pluginId "applyOne" applyHintTitle (Just applyHintArguments) ->
Just (mkCodeAction applyHintTitle diagnostic Nothing (Just applyHintCommand) True)
applyHintArguments = AO verTxtDocId start hint ->
Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON applyHintArguments)) True)
| otherwise -> Nothing
, Just (mkCodeAction suppressHintTitle diagnostic (Just suppressHintWorkspaceEdit) Nothing False)
, Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON suppressHintArguments)) False)
]
| otherwise = []

mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe LSP.WorkspaceEdit -> Maybe LSP.Command -> Bool -> LSP.CodeAction
mkCodeAction title diagnostic workspaceEdit command isPreferred =
mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe Value -> Bool -> LSP.CodeAction
mkCodeAction title diagnostic data_ isPreferred =
LSP.CodeAction
{ _title = title
, _kind = Just LSP.CodeActionKind_QuickFix
, _diagnostics = Just [diagnostic]
, _isPreferred = Just isPreferred
, _disabled = Nothing
, _edit = workspaceEdit
, _command = command
, _data_ = Nothing
, _edit = Nothing
, _command = Nothing
, _data_ = data_
}

mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit]
Expand All @@ -519,28 +508,32 @@ mkSuppressHintTextEdits dynFlags fileContents hint =
combinedTextEdit : lineSplitTextEditList
-- ---------------------------------------------------------------------

applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState VersionedTextDocumentIdentifier
applyAllCmd recorder ide verTxtDocId = do
let file = maybe (error $ show (verTxtDocId ^. LSP.uri) ++ " is not a file.")
toNormalizedFilePath'
(uriToFilePath' (verTxtDocId ^. LSP.uri))
withIndefiniteProgress "Applying all hints" Cancellable $ do
res <- liftIO $ applyHint recorder ide file Nothing verTxtDocId
logWith recorder Debug $ LogApplying file res
case res of
Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err))
Right fs -> do
_ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ())
pure $ Right Null
ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either String WorkspaceEdit)
ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = do
(_, fileContents) <- runAction "Hlint.GetFileContents" ideState $ getFileContents nfp
(msr, _) <- runAction "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStale_ GetModSummaryWithoutTimestamps nfp
case fileContents of
Just contents -> do
let dynFlags = ms_hspp_opts $ msrModSummary msr
textEdits = mkSuppressHintTextEdits dynFlags contents ignoreHintTitle
workspaceEdit =
LSP.WorkspaceEdit
(Just (M.singleton (verTxtDocId ^. LSP.uri) textEdits))
Nothing
Nothing
pure $ Right workspaceEdit
Nothing -> pure $ Left "Unable to get fileContents"

-- ---------------------------------------------------------------------

data ApplyOneParams = AOP
{ verTxtDocId :: VersionedTextDocumentIdentifier
, start_pos :: Position
-- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
, hintTitle :: HintTitle
} deriving (Eq,Show,Generic,FromJSON,ToJSON)
data HlintResolveCommands = AA { verTxtDocId :: VersionedTextDocumentIdentifier}
| AO { verTxtDocId :: VersionedTextDocumentIdentifier
, start_pos :: Position
-- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
, hintTitle :: HintTitle
}
| IH { verTxtDocId :: VersionedTextDocumentIdentifier
, ignoreHintTitle :: HintTitle
} deriving (Generic, ToJSON, FromJSON)

type HintTitle = T.Text

Expand All @@ -549,21 +542,6 @@ data OneHint = OneHint
, oneHintTitle :: HintTitle
} deriving (Eq, Show)

applyOneCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState ApplyOneParams
applyOneCmd recorder ide (AOP verTxtDocId pos title) = do
let oneHint = OneHint pos title
let file = maybe (error $ show (verTxtDocId ^. LSP.uri) ++ " is not a file.") toNormalizedFilePath'
(uriToFilePath' (verTxtDocId ^. LSP.uri))
let progTitle = "Applying hint: " <> title
withIndefiniteProgress progTitle Cancellable $ do
res <- liftIO $ applyHint recorder ide file (Just oneHint) verTxtDocId
logWith recorder Debug $ LogApplying file res
case res of
Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err))
Right fs -> do
_ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ())
pure $ Right Null

applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either String WorkspaceEdit)
applyHint recorder ide nfp mhint verTxtDocId =
runExceptT $ do
Expand Down
Loading