Resolve 0: Generic support for resolve in hls packages (#3678)

joyfulmantis · web-flow · commit 7860df3e97ec · 2023-06-29T15:13:24.000Z
* Generic support for resolve in hls packages

* Add a new code action resolve helper that falls backs to commands

* add resolve capability set to hls-test-utils

* Add code lens resolve support
diff --git 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
@@ -12,6 +12,7 @@
 {-# LANGUAGE MonadComprehensions        #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE OverloadedLabels           #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE PolyKinds                  #-}
@@ -47,6 +48,9 @@ module Ide.Types
 , installSigUsr1Handler
 , responseError
 , lookupCommandProvider
+, OwnedResolveData(..)
+, mkCodeActionHandlerWithResolve
+, mkCodeActionWithResolveAndCommand
 )
     where
 
@@ -59,7 +63,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 +80,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 +92,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 +412,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 _ =
@@ -464,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)
@@ -535,6 +527,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
 
@@ -552,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
@@ -848,7 +876,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 +977,8 @@ instance HasTracing WorkspaceSymbolParams where
 instance HasTracing CallHierarchyIncomingCallsParams
 instance HasTracing CallHierarchyOutgoingCallsParams
 instance HasTracing CompletionItem
-
+instance HasTracing CodeAction
+instance HasTracing CodeLens
 -- ---------------------------------------------------------------------
 
 {-# NOINLINE pROCESS_ID #-}
@@ -983,3 +1012,107 @@ 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 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
+                           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 (unwrapCodeActionResolveData params)
+    in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod
+    <> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod
+    where
+        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
+
+-- |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
+-- 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
@@ -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
diff --git 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
 -- ---------------------------------------------------------------------
