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

hls-plugin-api/src/Ide/Types.hs

@@ -403,32 +403,8 @@ 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 = pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)
 
 instance PluginMethod Request Method_TextDocumentDefinition where
   pluginEnabled _ msgParams pluginDesc _ =
@@ -535,6 +511,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
 
@@ -949,7 +957,8 @@ instance HasTracing WorkspaceSymbolParams where
 instance HasTracing CallHierarchyIncomingCallsParams
 instance HasTracing CallHierarchyOutgoingCallsParams
 instance HasTracing CompletionItem
-
+instance HasTracing CodeLens
+instance HasTracing CodeAction
 -- ---------------------------------------------------------------------
 
 {-# NOINLINE pROCESS_ID #-}

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,11 @@ test-suite tests
     build-depends:
       , base
       , filepath
+      , ghcide
       , text
       , hls-overloaded-record-dot-plugin
+      , lens
       , lsp-test
+      , lsp-types
       , hls-test-utils
 

plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs

@@ -13,16 +13,24 @@ module Ide.Plugin.OverloadedRecordDot
 
 -- based off of Berk Okzuturk's hls-explicit-records-fields-plugin
 
-import           Control.Lens                         ((^.))
+import           Control.Lens                         (_Just, (^.), (^?))
+import           Control.Monad                        (replicateM)
 import           Control.Monad.IO.Class               (MonadIO, liftIO)
+import           Control.Monad.Trans.Class            (lift)
 import           Control.Monad.Trans.Except           (ExceptT)
+import           Data.Aeson                           (FromJSON, Result (..),
+                                                       ToJSON, fromJSON, toJSON)
 import           Data.Generics                        (GenericQ, everything,
                                                        everythingBut, mkQ)
+import qualified Data.IntMap.Strict                   as IntMap
 import qualified Data.Map                             as Map
-import           Data.Maybe                           (mapMaybe, maybeToList)
+import           Data.Maybe                           (fromJust, mapMaybe,
+                                                       maybeToList)
 import           Data.Text                            (Text)
+import           Data.Unique                          (hashUnique, newUnique)
 import           Development.IDE                      (IdeState,
                                                        NormalizedFilePath,
+                                                       NormalizedUri,
                                                        Pretty (..), Range,
                                                        Recorder (..), Rules,
                                                        WithPriority (..),
@@ -76,17 +84,20 @@ import           Ide.Types                            (PluginDescriptor (..),
                                                        PluginMethodHandler,
                                                        defaultPluginDescriptor,
                                                        mkPluginHandler)
+import           Language.LSP.Protocol.Lens           (HasChanges (changes))
 import qualified Language.LSP.Protocol.Lens           as L
 import           Language.LSP.Protocol.Message        (Method (..),
                                                        SMethod (..))
 import           Language.LSP.Protocol.Types          (CodeAction (..),
                                                        CodeActionKind (CodeActionKind_RefactorRewrite),
                                                        CodeActionParams (..),
                                                        Command, TextEdit (..),
+                                                       Uri (..),
                                                        WorkspaceEdit (WorkspaceEdit),
                                                        fromNormalizedUri,
                                                        normalizedFilePathToUri,
                                                        type (|?) (..))
+import           Language.LSP.Server                  (getClientCapabilities)
 data Log
     = LogShake Shake.Log
     | LogCollectedRecordSelectors [RecordSelectorExpr]
@@ -105,7 +116,8 @@ instance Hashable CollectRecordSelectors
 instance NFData CollectRecordSelectors
 
 data CollectRecordSelectorsResult = CRSR
-    { recordInfos       :: RangeMap RecordSelectorExpr
+    { records           :: RangeMap Int
+    , recordInfos       :: IntMap.IntMap RecordSelectorExpr
     , enabledExtensions :: [Extension]
     }
     deriving (Generic)
@@ -135,56 +147,100 @@ instance Pretty RecordSelectorExpr where
 instance NFData RecordSelectorExpr where
   rnf = rwhnf
 
+data ORDResolveData = ORDRD {
+  uri      :: Uri
+, uniqueID :: Int
+} deriving (Generic, Show)
+instance ToJSON ORDResolveData
+instance FromJSON ORDResolveData
+
 descriptor :: Recorder (WithPriority Log) -> PluginId
                 -> PluginDescriptor IdeState
 descriptor recorder plId = (defaultPluginDescriptor plId)
     { pluginHandlers =
-        mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider
+      mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider
+      <> mkPluginHandler SMethod_CodeActionResolve resolveProvider
+
     , pluginRules = collectRecSelsRule recorder
     }
 
+resolveProvider :: PluginMethodHandler IdeState 'Method_CodeActionResolve
+resolveProvider ideState pId ca@(CodeAction _ _ _ _ _ _ _ (Just resData)) =
+    pluginResponse $ do
+        case fromJSON $ resData of
+            Success (ORDRD uri int) -> do
+                nfp <- getNormalizedFilePath uri
+                CRSR _ crsDetails exts <- collectRecSelResult ideState nfp
+                pragma <- getFirstPragma pId ideState nfp
+                let pragmaEdit =
+                        if OverloadedRecordDot `elem` exts
+                        then Nothing
+                        else Just $ insertNewPragma pragma OverloadedRecordDot
+                    edits (Just crs) = convertRecordSelectors crs : maybeToList pragmaEdit
+                    edits _ = []
+                    changes = Just $ WorkspaceEdit
+                                    (Just (Map.singleton (fromNormalizedUri
+                                            (normalizedFilePathToUri nfp))
+                                            (edits (IntMap.lookup int crsDetails))))
+                                    Nothing Nothing
+                pure $ ca {_edit = changes}
+            _ -> pure ca
+
 codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
 codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) =
     pluginResponse $ do
         nfp <- getNormalizedFilePath (caDocId ^. L.uri)
         pragma <- getFirstPragma pId ideState nfp
-        CRSR crsMap exts <- collectRecSelResult ideState nfp
-        let pragmaEdit =
+        caps <- lift getClientCapabilities
+        CRSR crsMap crsDetails exts <- collectRecSelResult ideState nfp
+        let supportsResolve :: Maybe Bool
+            supportsResolve = caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just
+            pragmaEdit =
                 if OverloadedRecordDot `elem` exts
                 then Nothing
                 else Just $ insertNewPragma pragma OverloadedRecordDot
-            edits crs = convertRecordSelectors crs : maybeToList pragmaEdit
-            changes crs =
-                Just $ Map.singleton (fromNormalizedUri
+            edits (Just crs) = convertRecordSelectors crs : maybeToList pragmaEdit
+            edits _ = []
+            changes crsM crsD =
+                case supportsResolve of
+                    Just False -> Just $ WorkspaceEdit
+                                    (Just (Map.singleton (fromNormalizedUri
                                             (normalizedFilePathToUri nfp))
-                                            (edits crs)
-            mkCodeAction crs = InR CodeAction
+                                            (edits (IntMap.lookup crsM crsD))))
+                                    Nothing Nothing
+                    _ -> Nothing
+            resolveData crsM =
+                case supportsResolve of
+                    Just True -> Just $ toJSON $ ORDRD (caDocId ^. L.uri) crsM
+                    _         -> Nothing
+            mkCodeAction crsD crsM  = InR CodeAction
                 { -- We pass the record selector to the title function, so that
                   -- we can have the name of the record selector in the title of
                   -- the codeAction. This allows the user can easily distinguish
                   -- between the different codeActions when using nested record
                   -- selectors, the disadvantage is we need to print out the
                   -- name of the record selector which will decrease performance
-                _title = mkCodeActionTitle exts crs
+                _title = mkCodeActionTitle exts crsM crsD
                 , _kind = Just CodeActionKind_RefactorRewrite
                 , _diagnostics = Nothing
                 , _isPreferred = Nothing
                 , _disabled = Nothing
-                , _edit = Just $ WorkspaceEdit (changes crs) Nothing Nothing
+                , _edit = changes crsM crsD
                 , _command = Nothing
-                , _data_ = Nothing
+                , _data_ = resolveData crsM
                 }
-            actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap)
+            actions = map (mkCodeAction crsDetails) (RangeMap.filterByRange caRange crsMap)
         pure $ InL actions
     where
-    mkCodeActionTitle :: [Extension] -> RecordSelectorExpr-> Text
-    mkCodeActionTitle exts (RecordSelectorExpr _ se _) =
+    mkCodeActionTitle :: [Extension] -> Int -> IntMap.IntMap RecordSelectorExpr-> Text
+    mkCodeActionTitle exts crsM crsD =
         if OverloadedRecordDot `elem` exts
             then title
             else title <> " (needs extension: OverloadedRecordDot)"
         where
-            title = "Convert `" <> name <> "` to record dot syntax"
-            name = printOutputable se
+            title = "Convert `" <> name (IntMap.lookup crsM crsD) <> "` to record dot syntax"
+            name (Just (RecordSelectorExpr _ se _)) = printOutputable se
+            name _                                  = ""
 
 collectRecSelsRule :: Recorder (WithPriority Log) -> Rules ()
 collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $
@@ -201,11 +257,15 @@ collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $
                 -- the OverloadedRecordDot pragma
                 exts = getEnabledExtensions tmr
                 recSels = mapMaybe (rewriteRange pm) (getRecordSelectors tmr)
+            uniques <- liftIO $ replicateM (length recSels) (hashUnique <$> newUnique)
             logWith recorder Debug (LogCollectedRecordSelectors recSels)
-            let -- We need the rangeMap to be able to filter by range later
-                crsMap :: RangeMap RecordSelectorExpr
-                crsMap = RangeMap.fromList location recSels
-            pure ([], CRSR <$> Just crsMap <*> Just exts)
+            let crsDetails = IntMap.fromList $ zip uniques recSels
+                -- We need the rangeMap to be able to filter by range later
+                rangeAndUnique = mapM (\x -> (, x) . location <$> IntMap.lookup x crsDetails) uniques
+                crsMap :: Maybe (RangeMap Int)
+                crsMap = RangeMap.fromList' <$> rangeAndUnique
+                crsDetails :: IntMap.IntMap RecordSelectorExpr
+            pure ([], CRSR <$> crsMap <*> Just crsDetails <*> Just exts)
     where getEnabledExtensions :: TcModuleResult -> [Extension]
           getEnabledExtensions = getExtensions . tmrParsed
           getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr]