From d14d9e5dcc1a3758517b0abc6c6cf8aac5ac1f28 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 1 Jul 2023 02:18:48 +0300 Subject: [PATCH] Support for resolve in hls-hlint-plugin (#3679) --- hls-plugin-api/src/Ide/Types.hs | 49 ++++-- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 156 ++++++++---------- plugins/hls-hlint-plugin/test/Main.hs | 45 ++++- 3 files changed, 145 insertions(+), 105 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index f752c17244..b7aaa6e231 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 @@ -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" (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 + _ <- 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 d817de310d..4faefa7a24 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 @@ -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), @@ -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 () -- --------------------------------------------------------------------- @@ -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 @@ -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 @@ -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 @@ -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") _ _ _ _) = @@ -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] @@ -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 @@ -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 diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index fab38e4d7d..e58f8c85ee 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"