From 355e95c7ab58a097ca152be22245ca4e9180b3d6 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 27 Jun 2023 17:10:07 +0300 Subject: [PATCH 01/10] Generic support for resolve in hls packages --- hls-plugin-api/hls-plugin-api.cabal | 1 + hls-plugin-api/src/Ide/Types.hs | 146 ++++++++++++++++++++++------ hls-test-utils/src/Test/Hls.hs | 22 +++++ 3 files changed, 139 insertions(+), 30 deletions(-) diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 2762f335ff..64d1aa8263 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -62,6 +62,7 @@ library , opentelemetry >=0.4 , optparse-applicative , regex-tdfa >=1.3.1.0 + , row-types , text , transformers , unordered-containers diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index c32b7173d0..f993544edc 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -12,6 +12,7 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} @@ -47,6 +48,8 @@ module Ide.Types , installSigUsr1Handler , responseError , lookupCommandProvider +, OwnedResolveData(..) +, mkCodeActionHandlerWithResolve ) where @@ -59,7 +62,9 @@ import System.Posix.Signals #endif import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) -import Control.Lens ((.~), (^.)) +import Control.Lens (_Just, (.~), (?~), (^.), (^?)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson hiding (Null, defaultOptions) import Data.Default import Data.Dependent.Map (DMap) @@ -74,6 +79,7 @@ import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map import Data.Maybe import Data.Ord +import Data.Row ((.!)) import Data.Semigroup import Data.String import qualified Data.Text as T @@ -85,7 +91,9 @@ import Ide.Plugin.Properties import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Language.LSP.Server (LspM, getVirtualFile) +import Language.LSP.Server (LspM, LspT, + getClientCapabilities, + getVirtualFile) import Language.LSP.VFS import Numeric.Natural import OpenTelemetry.Eventlog @@ -403,32 +411,10 @@ instance PluginMethod Request Method_TextDocumentCodeAction where where uri = msgParams ^. L.textDocument . L.uri -instance PluginRequestMethod Method_TextDocumentCodeAction where - combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps = - InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps - where - compat :: (Command |? CodeAction) -> (Command |? CodeAction) - compat x@(InL _) = x - compat x@(InR action) - | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport - = x - | otherwise = InL cmd - where - cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. L.title) (Just cmdParams) - cmdParams = [toJSON (FallbackCodeActionParams (action ^. L.edit) (action ^. L.command))] - - wasRequested :: (Command |? CodeAction) -> Bool - wasRequested (InL _) = True - wasRequested (InR ca) - | Nothing <- _only context = True - | Just allowed <- _only context - -- See https://github.com/microsoft/language-server-protocol/issues/970 - -- This is somewhat vague, but due to the hierarchical nature of action kinds, we - -- should check whether the requested kind is a *prefix* of the action kind. - -- That means, for example, we will return actions with kinds `quickfix.import` and - -- `quickfix.somethingElse` if the requested kind is `quickfix`. - , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed - | otherwise = False +instance PluginMethod Request Method_CodeActionResolve where + pluginEnabled _ msgParams pluginDesc config = + pluginResolverResponsible (msgParams ^. L.data_) pluginDesc + && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc) instance PluginMethod Request Method_TextDocumentDefinition where pluginEnabled _ msgParams pluginDesc _ = @@ -535,6 +521,38 @@ instance PluginMethod Request (Method_CustomMethod m) where pluginEnabled _ _ _ _ = True --- +instance PluginRequestMethod Method_TextDocumentCodeAction where + combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps = + InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps + where + compat :: (Command |? CodeAction) -> (Command |? CodeAction) + compat x@(InL _) = x + compat x@(InR action) + | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport + = x + | otherwise = InL cmd + where + cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. L.title) (Just cmdParams) + cmdParams = [toJSON (FallbackCodeActionParams (action ^. L.edit) (action ^. L.command))] + + wasRequested :: (Command |? CodeAction) -> Bool + wasRequested (InL _) = True + wasRequested (InR ca) + | Nothing <- _only context = True + | Just allowed <- _only context + -- See https://github.com/microsoft/language-server-protocol/issues/970 + -- This is somewhat vague, but due to the hierarchical nature of action kinds, we + -- should check whether the requested kind is a *prefix* of the action kind. + -- That means, for example, we will return actions with kinds `quickfix.import` and + -- `quickfix.somethingElse` if the requested kind is `quickfix`. + , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed + | otherwise = False + +instance PluginRequestMethod Method_CodeActionResolve where + -- CodeAction resolve is currently only used to changed the edit field, thus + -- that's the only field we are combining. + combineResponses _ _ _ codeAction (toList -> codeActions) = codeAction & L.edit .~ mconcat ((^. L.edit) <$> codeActions) + instance PluginRequestMethod Method_TextDocumentDefinition where combineResponses _ _ _ _ (x :| _) = x @@ -848,7 +866,7 @@ type CommandFunction ideState a newtype PluginId = PluginId T.Text deriving (Show, Read, Eq, Ord) - deriving newtype (FromJSON, Hashable) + deriving newtype (ToJSON, FromJSON, Hashable) instance IsString PluginId where fromString = PluginId . T.pack @@ -949,7 +967,7 @@ instance HasTracing WorkspaceSymbolParams where instance HasTracing CallHierarchyIncomingCallsParams instance HasTracing CallHierarchyOutgoingCallsParams instance HasTracing CompletionItem - +instance HasTracing CodeAction -- --------------------------------------------------------------------- {-# NOINLINE pROCESS_ID #-} @@ -983,3 +1001,71 @@ getProcessID = fromIntegral <$> P.getProcessID installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif + +-- |When provided with both a codeAction provider and an affiliated codeAction +-- resolve provider, this function creates a handler that automatically uses +-- your resolve provider to fill out you original codeAction if the client doesn't +-- have codeAction resolve support. This means you don't have to check whether +-- the client supports resolve and act accordingly in your own providers. +mkCodeActionHandlerWithResolve + :: forall ideState. (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) + -> (ideState -> PluginId -> CodeAction -> LspM Config (Either ResponseError CodeAction)) + -> PluginHandlers ideState +mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = + let newCodeActionMethod ideState pid params = runExceptT $ + do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params + caps <- lift getClientCapabilities + case codeActionReturn of + r@(InR _) -> 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 + supportsResolve caps -> pure $ InL (wrapResolveData pid <$> ls) + --This is the actual part where we call resolveCodeAction which fills in the edit data for the client + | otherwise -> InL <$> traverse (resolveCodeAction ideState pid) ls + newCodeResolveMethod ideState pid params = + codeResolveMethod ideState pid (unwrapResolveData params) + in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + <> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod + where + supportsResolve :: ClientCapabilities -> Bool + supportsResolve caps = + caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True + && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of + Just row -> "edit" `elem` row .! #properties + _ -> False + dropData :: CodeAction -> CodeAction + dropData ca = ca & L.data_ .~ Nothing + resolveCodeAction :: ideState -> PluginId -> (Command |? CodeAction) -> ExceptT ResponseError (LspT Config IO) (Command |? CodeAction) + resolveCodeAction _ideState _pid c@(InL _) = pure c + resolveCodeAction ideState pid (InR codeAction) = + fmap (InR . dropData) $ ExceptT $ codeResolveMethod ideState pid codeAction + -- We don't wrap commands + wrapResolveData _pid c@(InL _) = c + wrapResolveData pid (InR c@(CodeAction{_data_=Just x})) = + InR $ c & L.data_ ?~ toJSON (ORD pid x) + -- Neither do we wrap code actions's without data fields, + wrapResolveData _pid c@(InR (CodeAction{_data_=Nothing})) = c + unwrapResolveData c@CodeAction{_data_ = Just x} + | Success ORD {value = v} <- fromJSON x = c & L.data_ ?~ v + -- If we can't successfully decode the value as a ORD type than + -- we just return the codeAction untouched. + unwrapResolveData c = c + +-- |Allow plugins to "own" resolve data, allowing only them to be queried for +-- the resolve action. This design has added flexibility at the cost of nested +-- Value types +data OwnedResolveData = ORD { + owner :: PluginId +, value :: Value +} deriving (Generic, Show) +instance ToJSON OwnedResolveData +instance FromJSON OwnedResolveData + +pluginResolverResponsible :: Maybe Value -> PluginDescriptor c -> Bool +pluginResolverResponsible (Just val) pluginDesc = + case fromJSON val of + (Success (ORD o _)) -> pluginId pluginDesc == o + _ -> True -- We want to fail open in case our resolver is not using the ORD type +-- This is a wierd case, because anything that gets resolved should have a data +-- field, but in any case, failing open is safe enough. +pluginResolverResponsible Nothing _ = True diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 1864fdab49..97c0e03fe1 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -20,6 +20,7 @@ module Test.Hls defaultTestRunner, goldenGitDiff, goldenWithHaskellDoc, + goldenWithHaskellAndCaps, goldenWithCabalDoc, goldenWithHaskellDocFormatter, goldenWithCabalDocFormatter, @@ -143,6 +144,27 @@ goldenWithHaskellDoc -> TestTree goldenWithHaskellDoc = goldenWithDoc "haskell" +goldenWithHaskellAndCaps + :: Pretty b + => ClientCapabilities + -> PluginTestDescriptor b + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithHaskellAndCaps clientCaps plugin title testDataDir path desc ext act = + goldenGitDiff title (testDataDir path <.> desc <.> ext) + $ runSessionWithServerAndCaps plugin clientCaps testDataDir + $ TL.encodeUtf8 . TL.fromStrict + <$> do + doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue + act doc + documentContents doc + goldenWithCabalDoc :: Pretty b => PluginTestDescriptor b From fb49c3131cb98d16465b2aad6691453639fa3319 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 27 Jun 2023 17:18:28 +0300 Subject: [PATCH 02/10] Add a new code action resolve helper that falls backs to commands --- hls-plugin-api/src/Ide/Types.hs | 77 ++++++++++++++++++++++++--------- 1 file changed, 57 insertions(+), 20 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index f993544edc..04025b16ec 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -50,6 +50,7 @@ module Ide.Types , lookupCommandProvider , OwnedResolveData(..) , mkCodeActionHandlerWithResolve +, mkCodeActionWithResolveAndCommand ) where @@ -1016,40 +1017,76 @@ mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params caps <- lift getClientCapabilities case codeActionReturn of - r@(InR _) -> pure r + 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 - supportsResolve caps -> pure $ InL (wrapResolveData pid <$> ls) + supportsCodeActionResolve caps -> pure $ InL (wrapCodeActionResolveData pid <$> ls) --This is the actual part where we call resolveCodeAction which fills in the edit data for the client | otherwise -> InL <$> traverse (resolveCodeAction ideState pid) ls newCodeResolveMethod ideState pid params = - codeResolveMethod ideState pid (unwrapResolveData params) + codeResolveMethod ideState pid (unwrapCodeActionResolveData params) in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod <> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod where - supportsResolve :: ClientCapabilities -> Bool - supportsResolve caps = - caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True - && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of - Just row -> "edit" `elem` row .! #properties - _ -> False dropData :: CodeAction -> CodeAction dropData ca = ca & L.data_ .~ Nothing resolveCodeAction :: ideState -> PluginId -> (Command |? CodeAction) -> ExceptT ResponseError (LspT Config IO) (Command |? CodeAction) resolveCodeAction _ideState _pid c@(InL _) = pure c resolveCodeAction ideState pid (InR codeAction) = fmap (InR . dropData) $ ExceptT $ codeResolveMethod ideState pid codeAction - -- We don't wrap commands - wrapResolveData _pid c@(InL _) = c - wrapResolveData pid (InR c@(CodeAction{_data_=Just x})) = - InR $ c & L.data_ ?~ toJSON (ORD pid x) - -- Neither do we wrap code actions's without data fields, - wrapResolveData _pid c@(InR (CodeAction{_data_=Nothing})) = c - unwrapResolveData c@CodeAction{_data_ = Just x} - | Success ORD {value = v} <- fromJSON x = c & L.data_ ?~ v - -- If we can't successfully decode the value as a ORD type than - -- we just return the codeAction untouched. - unwrapResolveData c = c + +-- |When provided with both a codeAction provider that includes both a command +-- and a data field and a resolve provider, this function creates a handler that +-- defaults to using your command if the client doesn't have code action resolve +-- 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))) + -> (ideState -> PluginId -> CodeAction -> LspM Config (Either ResponseError CodeAction)) + -> PluginHandlers ideState +mkCodeActionWithResolveAndCommand 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 + 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 + +supportsCodeActionResolve :: ClientCapabilities -> Bool +supportsCodeActionResolve caps = + caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True + && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of + Just row -> "edit" `elem` row .! #properties + _ -> False + +-- We don't wrap commands +wrapCodeActionResolveData :: PluginId -> (a |? CodeAction) -> a |? CodeAction +wrapCodeActionResolveData _pid c@(InL _) = c +wrapCodeActionResolveData pid (InR c@(CodeAction{_data_=Just x})) = + InR $ c & L.data_ ?~ toJSON (ORD pid x) +-- Neither do we wrap code actions's without data fields, +wrapCodeActionResolveData _pid c@(InR (CodeAction{_data_=Nothing})) = c + +unwrapCodeActionResolveData :: CodeAction -> CodeAction +unwrapCodeActionResolveData c@CodeAction{_data_ = Just x} + | Success ORD {value = v} <- fromJSON x = c & L.data_ ?~ v +-- If we can't successfully decode the value as a ORD type than +-- we just return the codeAction untouched. +unwrapCodeActionResolveData c = c -- |Allow plugins to "own" resolve data, allowing only them to be queried for -- the resolve action. This design has added flexibility at the cost of nested From 9712ca581ba33ae9b6b6a777a98b3297bcd5d078 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 27 Jun 2023 20:55:10 +0300 Subject: [PATCH 03/10] move suppress hint from a workspaceEdit to a command --- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 67 ++++++++++--------- 1 file changed, 35 insertions(+), 32 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 1c4c4ee445..d042a933e1 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -190,8 +190,9 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = rules recorder plId , pluginCommands = - [ PluginCommand "applyOne" "Apply a single hint" (applyOneCmd recorder) + [ PluginCommand "applyOne" "Apply a single hint" (applyOneCmd recorder) , PluginCommand "applyAll" "Apply all hints to the file" (applyAllCmd recorder) + , PluginCommand "ignoreAll" "Ignore all hints for this file" (ignoreAllCmd recorder) ] , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider , pluginConfigDescriptor = defaultConfigDescriptor @@ -395,18 +396,6 @@ 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) @@ -426,16 +415,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 pluginId verTxtDocId if numHintsInDoc > 1 && numHintsInContext > 0 then do pure $ singleHintCodeActions ++ [applyAllAction verTxtDocId] else @@ -457,20 +437,19 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) diags = context ^. LSP.diagnostics +resolveProvider :: PluginMethodHandler IdeState Method_CodeActionResolve +resolveProvider = undefined + -- | 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 :: PluginId -> VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction] +diagnosticToCodeActions pluginId 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 = [toJSON (IHP verTxtDocId hint)] + , let suppressHintCommand = mkLspCommand pluginId "ignoreAll" suppressHintTitle (Just suppressHintArguments) = 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. @@ -480,7 +459,7 @@ diagnosticToCodeActions dynFlags fileContents pluginId verTxtDocId diagnostic applyHintCommand = mkLspCommand pluginId "applyOne" applyHintTitle (Just applyHintArguments) -> Just (mkCodeAction applyHintTitle diagnostic Nothing (Just applyHintCommand) True) | otherwise -> Nothing - , Just (mkCodeAction suppressHintTitle diagnostic (Just suppressHintWorkspaceEdit) Nothing False) + , Just (mkCodeAction suppressHintTitle diagnostic Nothing (Just suppressHintCommand) False) ] | otherwise = [] @@ -518,6 +497,25 @@ mkSuppressHintTextEdits dynFlags fileContents hint = combinedTextEdit : lineSplitTextEditList -- --------------------------------------------------------------------- +ignoreAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState IgnoreHintParams +ignoreAllCmd _recorder ideState IHP {verTxtDocId, ignoreHintTitle} = do + let nfp = maybe (error $ show (verTxtDocId ^. LSP.uri) ++ " is not a file.") toNormalizedFilePath' + (uriToFilePath' (verTxtDocId ^. LSP.uri)) + (_, fileContents) <- liftIO $ runAction "Hlint.GetFileContents" ideState $ getFileContents nfp + (msr, _) <- liftIO $ 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 + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing workspaceEdit) (\_ -> pure ()) + pure $ Right Null + Nothing -> pure $ Left $ responseError "Unable to get fileContents" + applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState VersionedTextDocumentIdentifier applyAllCmd recorder ide verTxtDocId = do let file = maybe (error $ show (verTxtDocId ^. LSP.uri) ++ " is not a file.") @@ -541,6 +539,11 @@ data ApplyOneParams = AOP , hintTitle :: HintTitle } deriving (Eq,Show,Generic,FromJSON,ToJSON) +data IgnoreHintParams = IHP + { verTxtDocId :: VersionedTextDocumentIdentifier + , ignoreHintTitle :: HintTitle + } deriving (Generic, ToJSON, FromJSON) + type HintTitle = T.Text data OneHint = OneHint From 26af22d024b3712e3e4add17fa3653b5ed5143e3 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 28 Jun 2023 16:44:16 +0300 Subject: [PATCH 04/10] Add support for resolve in hlint --- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 72 +++++++++++++------ 1 file changed, 50 insertions(+), 22 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index d042a933e1..0ea24451b4 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -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 @@ -145,6 +145,9 @@ import GHC.Generics (Generic) import System.Environment (setEnv, unsetEnv) #endif +import Data.Aeson (Result (Error, Success), + fromJSON) +import Ide.Types (mkCodeActionWithResolveAndCommand) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -194,7 +197,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) , PluginCommand "applyAll" "Apply all hints to the file" (applyAllCmd recorder) , PluginCommand "ignoreAll" "Ignore all hints for this file" (ignoreAllCmd recorder) ] - , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider + , pluginHandlers = mkCodeActionWithResolveAndCommand codeActionProvider (resolveProvider recorder) , pluginConfigDescriptor = defaultConfigDescriptor { configHasDiagnostics = True , configCustomConfig = mkCustomConfig properties @@ -427,7 +430,7 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) 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 + in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionKind_QuickFix) Nothing Nothing Nothing Nothing (Just cmd) (Just (toJSON (AA verTxtDocId))) -- |Some hints do not have an associated refactoring validCommand (LSP.Diagnostic _ _ (Just (InR code)) _ (Just "hlint") _ _ _ _) = @@ -437,8 +440,24 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) diags = context ^. LSP.diagnostics -resolveProvider :: PluginMethodHandler IdeState Method_CodeActionResolve -resolveProvider = undefined +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 (AOP 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 (IHP 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 @@ -448,32 +467,32 @@ diagnosticToCodeActions pluginId verTxtDocId diagnostic , let isHintApplicable = "refact:" `T.isPrefixOf` code , let hint = T.replace "refact:" "" code , let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module" - , let suppressHintArguments = [toJSON (IHP verTxtDocId hint)] - , let suppressHintCommand = mkLspCommand pluginId "ignoreAll" suppressHintTitle (Just suppressHintArguments) + , let suppressHintArguments = IHP verTxtDocId hint + , let suppressHintCommand = mkLspCommand pluginId "ignoreAll" suppressHintTitle (Just [toJSON suppressHintArguments]) = 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 = AOP verTxtDocId start hint + applyHintCommand = mkLspCommand pluginId "applyOne" applyHintTitle (Just [toJSON applyHintArguments]) -> + Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON (AO applyHintArguments))) (Just applyHintCommand) True) | otherwise -> Nothing - , Just (mkCodeAction suppressHintTitle diagnostic Nothing (Just suppressHintCommand) False) + , Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON (IH suppressHintArguments))) (Just suppressHintCommand) 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 -> Maybe LSP.Command -> Bool -> LSP.CodeAction +mkCodeAction title diagnostic data_ command isPreferred = LSP.CodeAction { _title = title , _kind = Just LSP.CodeActionKind_QuickFix , _diagnostics = Just [diagnostic] , _isPreferred = Just isPreferred , _disabled = Nothing - , _edit = workspaceEdit + , _edit = Nothing , _command = command - , _data_ = Nothing + , _data_ = data_ } mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit] @@ -498,11 +517,20 @@ mkSuppressHintTextEdits dynFlags fileContents hint = -- --------------------------------------------------------------------- ignoreAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState IgnoreHintParams -ignoreAllCmd _recorder ideState IHP {verTxtDocId, ignoreHintTitle} = do +ignoreAllCmd recorder ideState IHP {verTxtDocId, ignoreHintTitle} = do let nfp = maybe (error $ show (verTxtDocId ^. LSP.uri) ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' (verTxtDocId ^. LSP.uri)) - (_, fileContents) <- liftIO $ runAction "Hlint.GetFileContents" ideState $ getFileContents nfp - (msr, _) <- liftIO $ runAction "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStale_ GetModSummaryWithoutTimestamps nfp + wspaceEdit <- liftIO $ ignoreHint recorder ideState nfp verTxtDocId ignoreHintTitle + case wspaceEdit of + Right contents -> do + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing contents) (\_ -> pure ()) + pure $ Right Null + Left string -> pure $ Left $ responseError $ T.pack string + +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 @@ -512,9 +540,8 @@ ignoreAllCmd _recorder ideState IHP {verTxtDocId, ignoreHintTitle} = do (Just (M.singleton (verTxtDocId ^. LSP.uri) textEdits)) Nothing Nothing - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing workspaceEdit) (\_ -> pure ()) - pure $ Right Null - Nothing -> pure $ Left $ responseError "Unable to get fileContents" + pure $ Right workspaceEdit + Nothing -> pure $ Left $ "Unable to get fileContents" applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState VersionedTextDocumentIdentifier applyAllCmd recorder ide verTxtDocId = do @@ -531,7 +558,8 @@ applyAllCmd recorder ide verTxtDocId = do pure $ Right Null -- --------------------------------------------------------------------- - +data HlintResolveCommands = AA VersionedTextDocumentIdentifier | AO ApplyOneParams | IH IgnoreHintParams + deriving (Generic, ToJSON, FromJSON) data ApplyOneParams = AOP { verTxtDocId :: VersionedTextDocumentIdentifier , start_pos :: Position From d1d299b3a10805274f920a8ffa3410e5e109097d Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 28 Jun 2023 17:17:37 +0300 Subject: [PATCH 05/10] add resolve capability set to hls-test-utils --- hls-test-utils/src/Test/Hls/Util.hs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index d361b0a8ec..a3e2146743 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -10,7 +10,9 @@ {-# LANGUAGE DataKinds #-} module Test.Hls.Util ( -- * Test Capabilities - codeActionSupportCaps + codeActionResolveCaps + , codeActionNoResolveCaps + , codeActionSupportCaps , expectCodeAction -- * Environment specifications -- for ignoring tests @@ -51,7 +53,7 @@ where import Control.Applicative.Combinators (skipManyTill, (<|>)) import Control.Exception (catch, throwIO) -import Control.Lens ((&), (?~), (^.)) +import Control.Lens ((&), (?~), (^.), _Just, (.~)) import Control.Monad import Control.Monad.IO.Class import qualified Data.Aeson as A @@ -92,6 +94,15 @@ codeActionSupportCaps = def & L.textDocument ?~ textDocumentCaps codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing literalSupport = #codeActionKind .== (#valueSet .== []) +codeActionResolveCaps :: ClientCapabilities +codeActionResolveCaps = Test.fullCaps + & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ (#properties .== ["edit"]) + & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ True + +codeActionNoResolveCaps :: ClientCapabilities +codeActionNoResolveCaps = Test.fullCaps + & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing + & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False -- --------------------------------------------------------------------- -- Environment specification for ignoring tests -- --------------------------------------------------------------------- From 5335f1dd002a311f27f2f139be95b74a301433e9 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 28 Jun 2023 18:08:57 +0300 Subject: [PATCH 06/10] Add hlint tests for resolve --- plugins/hls-hlint-plugin/test/Main.hs | 45 +++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 2 deletions(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index a0790c89bf..130aad6620 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -36,6 +36,7 @@ tests = testGroup "hlint" [ , configTests , ignoreHintTests , applyHintTests + , resolveTests ] getIgnoreHintText :: T.Text -> T.Text @@ -44,6 +45,22 @@ getIgnoreHintText name = "Ignore hint \"" <> name <> "\" in this module" getApplyHintText :: T.Text -> T.Text getApplyHintText name = "Apply hint \"" <> name <> "\"" +resolveTests :: TestTree +resolveTests = testGroup "hlint resolve tests" + [ + ignoreHintGoldenResolveTest + "Resolve version of: Ignore hint in this module inserts -Wno-unrecognised-pragmas and hlint ignore pragma if warn unrecognized pragmas is off" + "UnrecognizedPragmasOff" + (Point 3 8) + "Eta reduce" + , applyHintGoldenResolveTest + "Resolve version of: [#2612] Apply hint works when operator fixities go right-to-left" + "RightToLeftFixities" + (Point 6 13) + "Avoid reverse" + ] + + ignoreHintTests :: TestTree ignoreHintTests = testGroup "hlint ignore hint tests" [ @@ -334,7 +351,7 @@ testDir = "test/testdata" runHlintSession :: FilePath -> Session a -> IO a runHlintSession subdir = - failIfSessionTimeout . runSessionWithServer hlintPlugin (testDir subdir) + failIfSessionTimeout . runSessionWithServerAndCaps hlintPlugin codeActionNoResolveCaps (testDir subdir) noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags = @@ -422,5 +439,29 @@ goldenTest testCaseName goldenFilename point hintText = setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path = - goldenWithHaskellDoc hlintPlugin testName testDir path "expected" "hs" + goldenWithHaskellAndCaps codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs" + +ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = + goldenResolveTest testCaseName goldenFilename point (getIgnoreHintText hintName) + +applyHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do + goldenResolveTest testCaseName goldenFilename point (getApplyHintText hintName) + +goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +goldenResolveTest testCaseName goldenFilename point hintText = + setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do + waitForDiagnosticsFromSource document "hlint" + actions <- getCodeActions document $ pointToRange point + case find ((== Just hintText) . getCodeActionTitle) actions of + Just (InR codeAction) -> do + rsp <- request SMethod_CodeActionResolve codeAction + case rsp ^. L.result of + Right ca -> executeCodeAction ca + Left re -> liftIO $ assertFailure $ show re + _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point +setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +setupGoldenHlintResolveTest testName path = + goldenWithHaskellAndCaps codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs" From 735feca0c5f7337237ea686ad5c376fbd9b2a755 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 29 Jun 2023 15:49:51 +0300 Subject: [PATCH 07/10] Add code lens resolve support --- hls-plugin-api/src/Ide/Types.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 04025b16ec..f752c17244 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -451,6 +451,11 @@ instance PluginMethod Request Method_TextDocumentCodeLens where where uri = msgParams ^. L.textDocument . L.uri +instance PluginMethod Request Method_CodeLensResolve where + pluginEnabled _ msgParams pluginDesc config = + pluginResolverResponsible (msgParams ^. L.data_) pluginDesc + && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc) + instance PluginMethod Request Method_TextDocumentRename where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc) @@ -571,6 +576,10 @@ instance PluginRequestMethod Method_WorkspaceSymbol where instance PluginRequestMethod Method_TextDocumentCodeLens where +instance PluginRequestMethod Method_CodeLensResolve where + -- A resolve request should only ever get one response + combineResponses _ _ _ _ (x :| _) = x + instance PluginRequestMethod Method_TextDocumentRename where instance PluginRequestMethod Method_TextDocumentHover where @@ -969,6 +978,7 @@ instance HasTracing CallHierarchyIncomingCallsParams instance HasTracing CallHierarchyOutgoingCallsParams instance HasTracing CompletionItem instance HasTracing CodeAction +instance HasTracing CodeLens -- --------------------------------------------------------------------- {-# NOINLINE pROCESS_ID #-} From a57e5d9edb24fbc23a4fe48d90879cb8826589c3 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 29 Jun 2023 20:34:23 +0300 Subject: [PATCH 08/10] WIP --- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 92 ++++++------------- 1 file changed, 29 insertions(+), 63 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 0ea24451b4..fd76bc63bb 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -147,7 +147,6 @@ import System.Environment (setEnv, #endif import Data.Aeson (Result (Error, Success), fromJSON) -import Ide.Types (mkCodeActionWithResolveAndCommand) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -190,12 +189,12 @@ fromStrictMaybe Strict.Nothing = Nothing #endif descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) +descriptor recorder plId = + let (plCommands, plHandlers) = mkCodeActionWithResolveAndCommand 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) - , PluginCommand "ignoreAll" "Ignore all hints for this file" (ignoreAllCmd recorder) + [ PluginCommand "executeResolve" "Executes resolve for code action" (executeResolveCmd recorder plId) ] , pluginHandlers = mkCodeActionWithResolveAndCommand codeActionProvider (resolveProvider recorder) , pluginConfigDescriptor = defaultConfigDescriptor @@ -447,12 +446,12 @@ resolveProvider recorder ideState _pluginId ca@CodeAction {_data_ = Just data_} file <- getNormalizedFilePath uri edit <- ExceptT $ liftIO $ applyHint recorder ideState file Nothing verTxtDocId pure $ ca & LSP.edit ?~ edit - (Success (AO (AOP verTxtDocId@(VersionedTextDocumentIdentifier uri _) pos hintTitle))) -> do + (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 (IHP verTxtDocId@(VersionedTextDocumentIdentifier uri _) hintTitle ))) -> do + (Success (IH verTxtDocId@(VersionedTextDocumentIdentifier uri _) hintTitle )) -> do file <- getNormalizedFilePath uri edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle pure $ ca & LSP.edit ?~ edit @@ -467,18 +466,18 @@ diagnosticToCodeActions pluginId verTxtDocId diagnostic , let isHintApplicable = "refact:" `T.isPrefixOf` code , let hint = T.replace "refact:" "" code , let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module" - , let suppressHintArguments = IHP verTxtDocId hint + , let suppressHintArguments = IH verTxtDocId hint , let suppressHintCommand = mkLspCommand pluginId "ignoreAll" suppressHintTitle (Just [toJSON suppressHintArguments]) = 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 = AOP verTxtDocId start hint + applyHintArguments = AO verTxtDocId start hint applyHintCommand = mkLspCommand pluginId "applyOne" applyHintTitle (Just [toJSON applyHintArguments]) -> - Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON (AO applyHintArguments))) (Just applyHintCommand) True) + Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON applyHintArguments)) (Just applyHintCommand) True) | otherwise -> Nothing - , Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON (IH suppressHintArguments))) (Just suppressHintCommand) False) + , Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON suppressHintArguments)) (Just suppressHintCommand) False) ] | otherwise = [] @@ -516,16 +515,16 @@ mkSuppressHintTextEdits dynFlags fileContents hint = combinedTextEdit : lineSplitTextEditList -- --------------------------------------------------------------------- -ignoreAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState IgnoreHintParams -ignoreAllCmd recorder ideState IHP {verTxtDocId, ignoreHintTitle} = do - let nfp = maybe (error $ show (verTxtDocId ^. LSP.uri) ++ " is not a file.") toNormalizedFilePath' - (uriToFilePath' (verTxtDocId ^. LSP.uri)) - wspaceEdit <- liftIO $ ignoreHint recorder ideState nfp verTxtDocId ignoreHintTitle - case wspaceEdit of - Right contents -> do - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing contents) (\_ -> pure ()) - pure $ Right Null - Left string -> pure $ Left $ responseError $ T.pack string +executeResolveCmd :: Recorder (WithPriority Log) -> PluginId -> CommandFunction IdeState CodeAction +executeResolveCmd recorder pluginId ideState ca = do + withIndefiniteProgress "Executing command..." Cancellable $ do + resolveResult <- resolveProvider recorder ideState pluginId ca + case resolveResult of + Right CodeAction {_edit = Just wedits } -> do + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) + pure $ Right Null + Right _ -> pure $ Left $ responseError "No edit in CodeAction" + Left err -> pure $ Left err ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either String WorkspaceEdit) ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = do @@ -543,34 +542,16 @@ ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = do pure $ Right workspaceEdit Nothing -> pure $ Left $ "Unable to get fileContents" -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 - -- --------------------------------------------------------------------- -data HlintResolveCommands = AA VersionedTextDocumentIdentifier | AO ApplyOneParams | IH IgnoreHintParams - deriving (Generic, ToJSON, FromJSON) -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 IgnoreHintParams = IHP - { verTxtDocId :: VersionedTextDocumentIdentifier - , ignoreHintTitle :: HintTitle - } deriving (Generic, ToJSON, FromJSON) +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 @@ -579,21 +560,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 From 57119c4211701b10095127014410cb4258e20833 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 29 Jun 2023 23:22:37 +0300 Subject: [PATCH 09/10] Remove all commands handling logic from hlint. Because the plugin-api does everything for us now. --- hls-plugin-api/src/Ide/Types.hs | 51 ++++++++++++------ .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 53 ++++++------------- 2 files changed, 53 insertions(+), 51 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index f752c17244..c47da1468f 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -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 @@ -75,7 +76,7 @@ import Data.GADT.Compare import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List.Extra (find, sortOn) +import Data.List.Extra (find, singleton, sortOn) import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map import Data.Maybe @@ -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 @@ -1051,10 +1054,12 @@ 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 @@ -1062,19 +1067,35 @@ mkCodeActionWithResolveAndCommand codeActionMethod codeResolveMethod = 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" (singleton <$> 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 + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) + pure $ Right Data.Aeson.Null + Right _ -> pure $ Left $ responseError "No edit in CodeAction" + Left err -> pure $ Left err supportsCodeActionResolve :: ClientCapabilities -> Bool supportsCodeActionResolve caps = diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 2391f54645..4faefa7a24 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -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), @@ -191,13 +188,11 @@ fromStrictMaybe Strict.Nothing = Nothing descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = - let (plCommands, plHandlers) = mkCodeActionWithResolveAndCommand codeActionProvider (resolveProvider recorder) + let (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand plId codeActionProvider (resolveProvider recorder) in (defaultPluginDescriptor plId) { pluginRules = rules recorder plId - , pluginCommands = - [ PluginCommand "executeResolve" "Executes resolve for code action" (executeResolveCmd recorder plId) - ] - , pluginHandlers = mkCodeActionWithResolveAndCommand codeActionProvider (resolveProvider recorder) + , pluginCommands = pluginCommands + , pluginHandlers = pluginHandlers , pluginConfigDescriptor = defaultConfigDescriptor { configHasDiagnostics = True , configCustomConfig = mkCustomConfig properties @@ -401,7 +396,7 @@ getHlintConfig pId = -- --------------------------------------------------------------------- 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 @@ -418,7 +413,7 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) [diagnostic | diagnostic <- diags , validCommand diagnostic ] - let singleHintCodeActions = diags >>= diagnosticToCodeActions pluginId verTxtDocId + let singleHintCodeActions = diags >>= diagnosticToCodeActions verTxtDocId if numHintsInDoc > 1 && numHintsInContext > 0 then do pure $ singleHintCodeActions ++ [applyAllAction verTxtDocId] else @@ -428,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) (Just (toJSON (AA verTxtDocId))) + 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") _ _ _ _) = @@ -461,29 +455,27 @@ resolveProvider _ _ _ _ = pluginResponse $ throwE "CodeAction with no data field -- | Convert a hlint diagnostic into an apply and an ignore code action -- if applicable -diagnosticToCodeActions :: PluginId -> VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction] -diagnosticToCodeActions 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 suppressHintArguments = IH verTxtDocId hint - , let suppressHintCommand = mkLspCommand pluginId "ignoreAll" suppressHintTitle (Just [toJSON suppressHintArguments]) = 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 = AO verTxtDocId start hint - applyHintCommand = mkLspCommand pluginId "applyOne" applyHintTitle (Just [toJSON applyHintArguments]) -> - Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON applyHintArguments)) (Just applyHintCommand) True) + applyHintArguments = AO verTxtDocId start hint -> + Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON applyHintArguments)) True) | otherwise -> Nothing - , Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON suppressHintArguments)) (Just suppressHintCommand) False) + , Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON suppressHintArguments)) False) ] | otherwise = [] -mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe Value -> Maybe LSP.Command -> Bool -> LSP.CodeAction -mkCodeAction title diagnostic data_ 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 @@ -491,7 +483,7 @@ mkCodeAction title diagnostic data_ command isPreferred = , _isPreferred = Just isPreferred , _disabled = Nothing , _edit = Nothing - , _command = command + , _command = Nothing , _data_ = data_ } @@ -516,17 +508,6 @@ mkSuppressHintTextEdits dynFlags fileContents hint = combinedTextEdit : lineSplitTextEditList -- --------------------------------------------------------------------- -executeResolveCmd :: Recorder (WithPriority Log) -> PluginId -> CommandFunction IdeState CodeAction -executeResolveCmd recorder pluginId ideState ca = do - withIndefiniteProgress "Executing command..." Cancellable $ do - resolveResult <- resolveProvider recorder ideState pluginId ca - case resolveResult of - Right CodeAction {_edit = Just wedits } -> do - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) - pure $ Right Null - Right _ -> pure $ Left $ responseError "No edit in CodeAction" - Left err -> pure $ Left err - 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 @@ -541,7 +522,7 @@ ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = do Nothing Nothing pure $ Right workspaceEdit - Nothing -> pure $ Left $ "Unable to get fileContents" + Nothing -> pure $ Left "Unable to get fileContents" -- --------------------------------------------------------------------- data HlintResolveCommands = AA { verTxtDocId :: VersionedTextDocumentIdentifier} From 68080fbf28f9ecec2d909697b9ba9d077b0c68d2 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 30 Jun 2023 19:00:55 +0300 Subject: [PATCH 10/10] Use pure instead of singleton to work with ghc 8.10 --- hls-plugin-api/src/Ide/Types.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index c47da1468f..b7aaa6e231 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -76,7 +76,7 @@ import Data.GADT.Compare import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List.Extra (find, singleton, sortOn) +import Data.List.Extra (find, sortOn) import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map import Data.Maybe @@ -1082,7 +1082,7 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = 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" (singleton <$> dat) + 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