Resolve 1: Support for resolve in overloaded-record-dot

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

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,55 @@ 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
+  :: (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) -> do
+                    let mapper :: (Command |? CodeAction) -> ExceptT ResponseError (LspT Config IO) (Command |? CodeAction)
+                        mapper c@(InL _) = pure c
+                        mapper (InR codeAction) = fmap (InR . dropData) $ ExceptT $ codeResolveMethod ideState pid codeAction
+                    if supportsResolve caps
+                        then pure $ InL ls
+                        else InL <$> traverse mapper ls --This is the actual part where we fill in the edit data for the client
+    in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod
+    <> mkPluginHandler SMethod_CodeActionResolve codeResolveMethod
+    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
+
+-- |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

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

plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal

@@ -30,6 +30,7 @@ library
     exposed-modules:  Ide.Plugin.OverloadedRecordDot
     build-depends:
       , base                  >=4.16 && <5
+      , aeson
       , ghcide
       , hls-plugin-api
       , lsp
@@ -58,8 +59,12 @@ test-suite tests
     build-depends:
       , base
       , filepath
+      , ghcide
       , text
       , hls-overloaded-record-dot-plugin
+      , lens
       , lsp-test
+      , lsp-types
+      , row-types
       , hls-test-utils