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
@@ -404,7 +412,9 @@ instance PluginMethod Request Method_TextDocumentCodeAction where
       uri = msgParams ^. L.textDocument . L.uri
 
 instance PluginMethod Request Method_CodeActionResolve where
-  pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)
+  pluginEnabled _ msgParams pluginDesc config =
+    pluginResolverResponsible (msgParams ^. L.data_) pluginDesc
+    && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)
 
 instance PluginMethod Request Method_TextDocumentDefinition where
   pluginEnabled _ msgParams pluginDesc _ =
@@ -856,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
@@ -957,7 +967,6 @@ instance HasTracing WorkspaceSymbolParams where
 instance HasTracing CallHierarchyIncomingCallsParams
 instance HasTracing CallHierarchyOutgoingCallsParams
 instance HasTracing CompletionItem
-instance HasTracing CodeLens
 instance HasTracing CodeAction
 -- ---------------------------------------------------------------------
 
@@ -992,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

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

@@ -65,5 +65,6 @@ test-suite tests
       , lens
       , lsp-test
       , lsp-types
+      , row-types
       , hls-test-utils
 

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

@@ -17,7 +17,7 @@ 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           Control.Monad.Trans.Except           (ExceptT, throwE)
 import           Data.Aeson                           (FromJSON, Result (..),
                                                        ToJSON, fromJSON, toJSON)
 import           Data.Generics                        (GenericQ, everything,
@@ -79,10 +79,12 @@ import qualified Ide.Plugin.RangeMap                  as RangeMap
 import           Ide.PluginUtils                      (getNormalizedFilePath,
                                                        handleMaybeM,
                                                        pluginResponse)
-import           Ide.Types                            (PluginDescriptor (..),
+import           Ide.Types                            (OwnedResolveData (..),
+                                                       PluginDescriptor (..),
                                                        PluginId (..),
                                                        PluginMethodHandler,
                                                        defaultPluginDescriptor,
+                                                       mkCodeActionHandlerWithResolve,
                                                        mkPluginHandler)
 import           Language.LSP.Protocol.Lens           (HasChanges (changes))
 import qualified Language.LSP.Protocol.Lens           as L
@@ -93,7 +95,7 @@ import           Language.LSP.Protocol.Types          (CodeAction (..),
                                                        CodeActionParams (..),
                                                        Command, TextEdit (..),
                                                        Uri (..),
-                                                       WorkspaceEdit (WorkspaceEdit),
+                                                       WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),
                                                        fromNormalizedUri,
                                                        normalizedFilePathToUri,
                                                        type (|?) (..))
@@ -116,7 +118,13 @@ instance Hashable CollectRecordSelectors
 instance NFData CollectRecordSelectors
 
 data CollectRecordSelectorsResult = CRSR
-    { records           :: RangeMap Int
+    { -- |We store everything in here that we need to create the unresolved
+      -- codeAction, the range, an uniquely identifiable int, and the expression
+      -- for the selector expression 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]
     }
@@ -147,8 +155,12 @@ 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
@@ -158,89 +170,65 @@ descriptor :: Recorder (WithPriority Log) -> PluginId
                 -> PluginDescriptor IdeState
 descriptor recorder plId = (defaultPluginDescriptor plId)
     { pluginHandlers =
-      mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider
-      <> mkPluginHandler SMethod_CodeActionResolve resolveProvider
-
+      mkCodeActionHandlerWithResolve codeActionProvider resolveProvider
     , pluginRules = collectRecSelsRule recorder
     }
 
 resolveProvider :: PluginMethodHandler IdeState 'Method_CodeActionResolve
 resolveProvider ideState pId ca@(CodeAction _ _ _ _ _ _ _ (Just resData)) =
     pluginResponse $ do
-        case fromJSON $ resData of
+        case fromJSON resData >>= \x -> fromJSON $ value x 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
+                pure $ ca {_edit = mkWorkspaceEdit uri int crsDetails exts pragma}
+            _ -> 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
-        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 (Just crs) = convertRecordSelectors crs : maybeToList pragmaEdit
-            edits _ = []
-            changes crsM crsD =
-                case supportsResolve of
-                    Just False -> Just $ WorkspaceEdit
-                                    (Just (Map.singleton (fromNormalizedUri
-                                            (normalizedFilePathToUri nfp))
-                                            (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
+        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 crsM crsD
+                  _title = mkCodeActionTitle exts crsM nse
                 , _kind = Just CodeActionKind_RefactorRewrite
                 , _diagnostics = Nothing
                 , _isPreferred = Nothing
                 , _disabled = Nothing
-                , _edit = changes crsM crsD
+                , _edit = Nothing
                 , _command = Nothing
-                , _data_ = resolveData crsM
+                , _data_ = Just $ toJSON $ ORD pId $ toJSON $ ORDRD (caDocId ^. L.uri) crsM
                 }
-            actions = map (mkCodeAction crsDetails) (RangeMap.filterByRange caRange crsMap)
+            actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap)
         pure $ InL actions
     where
-    mkCodeActionTitle :: [Extension] -> Int -> IntMap.IntMap RecordSelectorExpr-> Text
-    mkCodeActionTitle exts crsM crsD =
+    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 (IntMap.lookup crsM crsD) <> "` to record dot syntax"
-            name (Just (RecordSelectorExpr _ se _)) = printOutputable se
-            name _                                  = ""
+            title = "Convert `" <> printOutputable se <> "` to record dot syntax"
+
+mkWorkspaceEdit:: Uri -> Int -> IntMap.IntMap RecordSelectorExpr -> [Extension] -> NextPragmaInfo-> Maybe WorkspaceEdit
+mkWorkspaceEdit uri crsM crsD exts pragma =
+    Just $ WorkspaceEdit
+    { _changes = Just (Map.singleton uri (edits (IntMap.lookup crsM crsD)))
+    , _documentChanges = Nothing
+    , _changeAnnotations = Nothing}
+    where pragmaEdit =
+            if OverloadedRecordDot `elem` exts
+            then Nothing
+            else Just $ insertNewPragma pragma OverloadedRecordDot
+          edits (Just crs) = convertRecordSelectors crs : maybeToList pragmaEdit
+          edits _          = []
 
 collectRecSelsRule :: Recorder (WithPriority Log) -> Rules ()
 collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $
@@ -259,13 +247,12 @@ collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $
                 recSels = mapMaybe (rewriteRange pm) (getRecordSelectors tmr)
             uniques <- liftIO $ replicateM (length recSels) (hashUnique <$> newUnique)
             logWith recorder Debug (LogCollectedRecordSelectors recSels)
-            let crsDetails = IntMap.fromList $ zip uniques recSels
+            let crsUniquesAndDetails =  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)
+                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]
@@ -277,6 +264,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) =