From 683bbd9efe259e360deeeb2e71ff003b4eddc0fb Mon Sep 17 00:00:00 2001
From: Michael Peyton Jones <me@michaelpj.com>
Date: Thu, 2 Sep 2021 17:35:43 +0100
Subject: [PATCH] Filter code actions based on prefix, not equality

It's quite unclear in the spec, but in
microsoft/language-server-protocol#970
it's suggested that the intention is that the kinds given in `only`
should be used as *prefix* filters of the generated code action kinds.

That is to say, if the client asks for `only = [ CodeActionRefactor ]`,
we should give them all kinds of refactoring code actions, including
those whose kind is `CodeActionRefactorInline` (because as "hierarchical
strings" they are represented as `"refactor"` and `"refactor.inline"`).

This is quite important for the client: e.g. I hit this because I wanted
to ask for all the import quickfixes so I could present them to the user
to pick one. But they use various subkinds of `"quickfix.import"`, so
currently you cannot ask for them all (asking for `"quickfix.import"`
currentl returns nothing!).

The ipmlemention is a little ugly: this needs some helper funcitons in
`lsp`, which I'll make a PR for separately, but I didn't want to block
this.
---
 hls-plugin-api/src/Ide/Types.hs         | 11 ++++++++++-
 test/functional/FunctionalCodeAction.hs | 22 ++++++++++------------
 2 files changed, 20 insertions(+), 13 deletions(-)

diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs
index ef6153e3ce..ae3253f6f5 100644
--- a/hls-plugin-api/src/Ide/Types.hs
+++ b/hls-plugin-api/src/Ide/Types.hs
@@ -192,7 +192,16 @@ instance PluginMethod TextDocumentCodeAction where
       wasRequested (InR ca)
         | Nothing <- _only context = True
         | Just (List allowed) <- _only context
-        , Just caKind <- ca ^. kind = caKind `elem` allowed
+        -- 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`.
+        -- TODO: add helpers in `lsp` for handling code action hierarchies
+        -- For now we abuse the fact that the JSON representation gives us the hierarchical string.
+        , Just caKind <- ca ^. kind
+        , String caKindStr <- toJSON caKind =
+                any (\k -> k `T.isPrefixOf` caKindStr) [kstr | k <- allowed, let String kstr = toJSON k ]
         | otherwise = False
 
 instance PluginMethod TextDocumentCodeLens where
diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs
index 85264583ff..6c0bd95c4a 100644
--- a/test/functional/FunctionalCodeAction.hs
+++ b/test/functional/FunctionalCodeAction.hs
@@ -9,7 +9,7 @@ import           Control.Monad
 import           Data.Aeson
 import qualified Data.HashMap.Strict             as HM
 import           Data.List
-import qualified Data.Map as M
+import qualified Data.Map                        as M
 import           Data.Maybe
 import qualified Data.Text                       as T
 import           Ide.Plugin.Config
@@ -527,31 +527,29 @@ unusedTermTests = testGroup "unused term code actions" [
         _     <- waitForDiagnosticsFrom doc
         diags <- getCurrentDiagnostics doc
         let params = CodeActionParams Nothing Nothing doc (Range (Position 1 0) (Position 4 0)) caContext
-            caContext = CodeActionContext (List diags) (Just (List [CodeActionRefactorInline]))
+            caContext = CodeActionContext (List diags) (Just (List [CodeActionRefactor]))
             caContextAllActions = CodeActionContext (List diags) Nothing
         -- Verify that we get code actions of at least two different kinds.
-        ResponseMessage _ _ (Right (List allCodeActions))
+        ResponseMessage _ _ (Right (List res))
           <- request STextDocumentCodeAction (params & L.context .~ caContextAllActions)
         liftIO $ do
-            redundantId <- inspectCodeAction allCodeActions ["Redundant id"]
-            redundantId ^. L.kind @?= Just CodeActionQuickFix
-            unfoldFoo <- inspectCodeAction allCodeActions ["Unfold foo"]
-            unfoldFoo ^. L.kind @?= Just CodeActionRefactorInline
+            let cas = map fromAction res
+                kinds = map (^. L.kind) cas
+            nub kinds @?= [Just CodeActionRefactorInline, Just CodeActionRefactorExtract, Just CodeActionQuickFix]
         -- Verify that that when we set the only parameter, we only get actions
         -- of the right kind.
         ResponseMessage _ _ (Right (List res)) <- request STextDocumentCodeAction params
-        let cas = map fromAction res
-            kinds = map (^. L.kind) cas
         liftIO $ do
-            not (null kinds) @? "We found an action of kind RefactorInline"
-            all (Just CodeActionRefactorInline ==) kinds @? "All CodeActionRefactorInline"
+            let cas = map fromAction res
+                kinds = map (^. L.kind) cas
+            nub kinds @?= nub [Just CodeActionRefactorInline, Just CodeActionRefactorExtract]
     ]
 
 expectFailIfGhc9 :: String -> TestTree -> TestTree
 expectFailIfGhc9 reason =
   case ghcVersion of
     GHC90 -> expectFailBecause reason
-    _ -> id
+    _     -> id
 
 disableWingman :: Session ()
 disableWingman =