Resolve 1: Support for resolve in overloaded-record-dot (#3658)

* resolve for overloaded-record-dot (checkpoint)

* resolve support works on VSCode (tests need to be redone)

* Tests for both resolve and non resolve variants

* Added more tests

* Fix merge mistakes; move function to hls-test-utils

* Remove codeLens resolve
Fix codeActionResolve combine responses

* Don't use partial functions

* Implement michaelpj's suggestions

* Make owned resolve data transparent to the plugins

* Improve ord's resolve handler's error handling

* Oh well, if only we had MonadFail

* 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

* use caps defined at hls-test-utils

* Add code lens resolve support

* Improve comments

* remove Benchmark as it wasn't that useful and triggered a lsp-test bug

---------

Co-authored-by: Michael Peyton Jones <[email protected]>

Author: joyfulmantis

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
 

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.Except           (ExceptT)
+import           Control.Monad.Trans.Class            (lift)
+import           Control.Monad.Trans.Except           (ExceptT, throwE)
+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 (..),
@@ -75,18 +83,22 @@ import           Ide.Types                            (PluginDescriptor (..),
                                                        PluginId (..),
                                                        PluginMethodHandler,
                                                        defaultPluginDescriptor,
+                                                       mkCodeActionHandlerWithResolve,
                                                        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 (..),
-                                                       WorkspaceEdit (WorkspaceEdit),
+                                                       Uri (..),
+                                                       WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),
                                                        fromNormalizedUri,
                                                        normalizedFilePathToUri,
                                                        type (|?) (..))
+import           Language.LSP.Server                  (getClientCapabilities)
 data Log
     = LogShake Shake.Log
     | LogCollectedRecordSelectors [RecordSelectorExpr]
@@ -105,7 +117,14 @@ instance Hashable CollectRecordSelectors
 instance NFData CollectRecordSelectors
 
 data CollectRecordSelectorsResult = CRSR
-    { recordInfos       :: RangeMap RecordSelectorExpr
+    { -- |We store everything in here that we need to create the unresolved
+      -- codeAction: the range, an uniquely identifiable int, and the selector
+      --selector expression  (HSExpr) that we use to generate the name
+      records           :: RangeMap (Int, HsExpr (GhcPass 'Renamed))
+      -- |This is for when we need to fully generate a textEdit. It contains the
+      -- whole expression we are interested in indexed to the unique id we got
+      -- from the previous field
+    , recordInfos       :: IntMap.IntMap RecordSelectorExpr
     , enabledExtensions :: [Extension]
     }
     deriving (Generic)
@@ -135,56 +154,85 @@ instance Pretty RecordSelectorExpr where
 instance NFData RecordSelectorExpr where
   rnf = rwhnf
 
+-- |The data that is serialized and placed in the data field of resolvable
+-- code actions
+data ORDResolveData = ORDRD {
+  -- |We need the uri to get shake results
+  uri      :: Uri
+  -- |The unique id that allows us to find the specific codeAction we want
+, 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
+      mkCodeActionHandlerWithResolve codeActionProvider 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
+                case IntMap.lookup int crsDetails of
+                    Just rse -> pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma}
+                    -- We need to throw a content modified error here, see
+                    -- https://github.com/microsoft/language-server-protocol/issues/1738
+                    -- but we need fendor's plugin error response pr to make it
+                    -- convenient to use here, so we will wait to do that till that's merged
+                    _        -> throwE "Content Modified Error"
+            _ -> throwE "Unable to deserialize the data"
+
 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 =
-                if OverloadedRecordDot `elem` exts
-                then Nothing
-                else Just $ insertNewPragma pragma OverloadedRecordDot
-            edits crs = convertRecordSelectors crs : maybeToList pragmaEdit
-            changes crs =
-                Just $ Map.singleton (fromNormalizedUri
-                                            (normalizedFilePathToUri nfp))
-                                            (edits crs)
-            mkCodeAction crs = InR CodeAction
+        CRSR crsMap crsDetails exts <- collectRecSelResult ideState nfp
+        let mkCodeAction (crsM, nse)  = 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 nse
                 , _kind = Just CodeActionKind_RefactorRewrite
                 , _diagnostics = Nothing
                 , _isPreferred = Nothing
                 , _disabled = Nothing
-                , _edit = Just $ WorkspaceEdit (changes crs) Nothing Nothing
+                , _edit = Nothing
                 , _command = Nothing
-                , _data_ = Nothing
+                , _data_ = Just $ toJSON $ ORDRD (caDocId ^. L.uri) crsM
                 }
             actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap)
         pure $ InL actions
     where
-    mkCodeActionTitle :: [Extension] -> RecordSelectorExpr-> Text
-    mkCodeActionTitle exts (RecordSelectorExpr _ se _) =
+    mkCodeActionTitle :: [Extension] -> Int -> HsExpr (GhcPass 'Renamed) -> Text
+    mkCodeActionTitle exts crsM se =
         if OverloadedRecordDot `elem` exts
             then title
             else title <> " (needs extension: OverloadedRecordDot)"
         where
-            title = "Convert `" <> name <> "` to record dot syntax"
-            name = printOutputable se
+            title = "Convert `" <> printOutputable se <> "` to record dot syntax"
+
+mkWorkspaceEdit:: Uri -> RecordSelectorExpr -> [Extension] -> NextPragmaInfo-> Maybe WorkspaceEdit
+mkWorkspaceEdit uri recSel exts pragma =
+    Just $ WorkspaceEdit
+    { _changes =
+        Just (Map.singleton uri (convertRecordSelectors recSel : maybeToList pragmaEdit))
+    , _documentChanges = Nothing
+    , _changeAnnotations = Nothing}
+    where pragmaEdit =
+            if OverloadedRecordDot `elem` exts
+            then Nothing
+            else Just $ insertNewPragma pragma OverloadedRecordDot
 
 collectRecSelsRule :: Recorder (WithPriority Log) -> Rules ()
 collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $
@@ -201,11 +249,17 @@ collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $
                 -- the OverloadedRecordDot pragma
                 exts = getEnabledExtensions tmr
                 recSels = mapMaybe (rewriteRange pm) (getRecordSelectors tmr)
+            -- We are creating a list as long as our rec selectors of unique int s
+            -- created by calling hashUnique on a Unique. The reason why we are
+            -- extracting the ints is because they don't need any work to serialize.
+            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 crsUniquesAndDetails =  zip uniques recSels
+                -- We need the rangeMap to be able to filter by range later
+                rangeAndUnique = toRangeAndUnique <$> crsUniquesAndDetails
+                crsMap :: RangeMap (Int,  HsExpr (GhcPass 'Renamed))
+                crsMap = RangeMap.fromList' rangeAndUnique
+            pure ([], CRSR <$> Just crsMap <*> Just (IntMap.fromList crsUniquesAndDetails) <*> Just exts)
     where getEnabledExtensions :: TcModuleResult -> [Extension]
           getEnabledExtensions = getExtensions . tmrParsed
           getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr]
@@ -217,6 +271,7 @@ collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $
             case toCurrentRange pm (location recSel) of
                 Just newLoc -> Just $ recSel{location = newLoc}
                 Nothing     -> Nothing
+          toRangeAndUnique (id, RecordSelectorExpr l (unLoc -> se) _) = (l, (id, se))
 
 convertRecordSelectors :: RecordSelectorExpr ->  TextEdit
 convertRecordSelectors (RecordSelectorExpr l se re) =

plugins/hls-overloaded-record-dot-plugin/test/Main.hs

@@ -5,37 +5,64 @@
 
 module Main ( main ) where
 
+import           Control.Lens                   ((^.))
 import           Data.Either                    (rights)
+import           Data.Functor                   (void)
+import           Data.Maybe                     (isNothing)
+import           Data.Row
 import qualified Data.Text                      as T
+import qualified Data.Text.Lazy                 as TL
+import qualified Data.Text.Lazy.Encoding        as TL
+import           Development.IDE.Types.Logger   (Doc, Logger (Logger),
+                                                 Pretty (pretty),
+                                                 Priority (Debug),
+                                                 Recorder (Recorder, logger_),
+                                                 WithPriority (WithPriority, priority),
+                                                 cfilter, cmapWithPrio,
+                                                 makeDefaultStderrRecorder)
 import qualified Ide.Plugin.OverloadedRecordDot as OverloadedRecordDot
-import           System.FilePath                ((</>))
+import           Language.LSP.Protocol.Lens     as L
+import           System.FilePath                ((<.>), (</>))
 import           Test.Hls
-
+import           Test.Hls.Util                  (codeActionNoResolveCaps,
+                                                 codeActionResolveCaps)
 
 main :: IO ()
-main = defaultTestRunner test
+main =
+  defaultTestRunner test
 
 plugin :: PluginTestDescriptor OverloadedRecordDot.Log
 plugin = mkPluginTestDescriptor OverloadedRecordDot.descriptor "overloaded-record-dot"
 
 test :: TestTree
 test = testGroup "overloaded-record-dot"
-  [ mkTest "Simple" "Simple" "name" 10 7 10 15,
-    mkTest "NoPragmaNeeded" "NoPragmaNeeded" "name" 11 7 11 15,
-    mkTest "NestedParens" "NestedParens" "name" 15 7 15 24,
-    mkTest "NestedDot" "NestedDot" "name" 17 7 17 22,
-    mkTest "NestedDollar" "NestedDollar" "name" 15 7 15 24,
-    mkTest "MultilineCase" "MultilineCase" "name" 10 7 12 15,
-    mkTest "Multiline" "Multiline" "name" 10 7 11 15,
-    mkTest "MultilineExpanded" "MultilineExpanded" "owner" 28 8 28 19
-  ]
-
-mkTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree
+      (mkTest "Simple" "Simple" "name" 10 7 10 15
+    <> mkTest "NoPragmaNeeded" "NoPragmaNeeded" "name" 11 7 11 15
+    <> mkTest "NestedParens" "NestedParens" "name" 15 7 15 24
+    <> mkTest "NestedDot" "NestedDot" "name" 17 7 17 22
+    <> mkTest "NestedDollar" "NestedDollar" "name" 15 7 15 24
+    <> mkTest "MultilineCase" "MultilineCase" "name" 10 7 12 15
+    <> mkTest "Multiline" "Multiline" "name" 10 7 11 15
+    <> mkTest "MultilineExpanded" "MultilineExpanded" "owner" 28 8 28 19)
+
+mkTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> [TestTree]
 mkTest title fp selectorName x1 y1 x2 y2 =
-  goldenWithHaskellDoc plugin title testDataDir fp "expected" "hs" $ \doc -> do
+    [mkNoResolveTest (title <> " without resolve") fp selectorName x1 y1 x2 y2,
+    mkResolveTest (title <> " with resolve") fp selectorName x1 y1 x2 y2]
+
+mkNoResolveTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree
+mkNoResolveTest title fp selectorName x1 y1 x2 y2 =
+  goldenWithHaskellAndCaps codeActionNoResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do
     (act:_) <- getExplicitFieldsActions doc selectorName x1 y1 x2 y2
     executeCodeAction act
 
+mkResolveTest :: TestName -> FilePath -> T.Text -> UInt -> UInt -> UInt -> UInt -> TestTree
+mkResolveTest title fp selectorName x1 y1 x2 y2 =
+  goldenWithHaskellAndCaps codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do
+    ((Right act):_) <- getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2
+    executeCodeAction act
+
+
 getExplicitFieldsActions
   :: TextDocumentIdentifier
   -> T.Text
@@ -46,6 +73,19 @@ getExplicitFieldsActions doc selectorName x1 y1 x2 y2 =
   where
     range = Range (Position x1 y1) (Position x2 y2)
 
+getAndResolveExplicitFieldsActions
+  :: TextDocumentIdentifier
+  -> T.Text
+  -> UInt -> UInt -> UInt -> UInt
+  -> Session [Either ResponseError CodeAction]
+getAndResolveExplicitFieldsActions doc selectorName x1 y1 x2 y2 = do
+    actions <- findExplicitFieldsAction selectorName <$> getCodeActions doc range
+    rsp <- mapM (request SMethod_CodeActionResolve) (filter (\x -> isNothing (x ^. L.edit)) actions)
+    pure $ (^. L.result) <$> rsp
+
+  where
+    range = Range (Position x1 y1) (Position x2 y2)
+
 findExplicitFieldsAction :: T.Text  -> [a |? CodeAction] -> [CodeAction]
 findExplicitFieldsAction selectorName = filter (isExplicitFieldsCodeAction selectorName) . rights . map toEither