Skip to content

Commit d404a25

Browse files
joyfulmantisjoyfulmantis
committed
resolve for overloaded-record-dot (checkpoint)
1 parent a483607 commit d404a25

File tree

3 files changed

+135
-57
lines changed

3 files changed

+135
-57
lines changed

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

+50-34
Original file line numberDiff line numberDiff line change
@@ -403,39 +403,8 @@ instance PluginMethod Request Method_TextDocumentCodeAction where
403403
where
404404
uri = msgParams ^. L.textDocument . L.uri
405405

406-
instance PluginRequestMethod Method_TextDocumentCodeAction where
407-
combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps =
408-
InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps
409-
where
410-
compat :: (Command |? CodeAction) -> (Command |? CodeAction)
411-
compat x@(InL _) = x
412-
compat x@(InR action)
413-
| Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport
414-
= x
415-
| otherwise = InL cmd
416-
where
417-
cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. L.title) (Just cmdParams)
418-
cmdParams = [toJSON (FallbackCodeActionParams (action ^. L.edit) (action ^. L.command))]
419-
420-
wasRequested :: (Command |? CodeAction) -> Bool
421-
wasRequested (InL _) = True
422-
wasRequested (InR ca)
423-
| Nothing <- _only context = True
424-
| Just allowed <- _only context
425-
-- See https://github.com/microsoft/language-server-protocol/issues/970
426-
-- This is somewhat vague, but due to the hierarchical nature of action kinds, we
427-
-- should check whether the requested kind is a *prefix* of the action kind.
428-
-- That means, for example, we will return actions with kinds `quickfix.import` and
429-
-- `quickfix.somethingElse` if the requested kind is `quickfix`.
430-
, Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed
431-
| otherwise = False
432-
433-
-- Copied form lsp-types 1.6 to get compilation working. May make more
434-
-- sense to add it back to lsp-types 2.0
435-
-- | Does the first 'CodeActionKind' subsume the other one, hierarchically. Reflexive.
436-
codeActionKindSubsumes :: CodeActionKind -> CodeActionKind -> Bool
437-
-- Simple but ugly implementation: prefix on the string representation
438-
codeActionKindSubsumes parent child = toEnumBaseType parent `T.isPrefixOf` toEnumBaseType child
406+
instance PluginMethod Request Method_CodeActionResolve where
407+
pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)
439408

440409
instance PluginMethod Request Method_TextDocumentDefinition where
441410
pluginEnabled _ msgParams pluginDesc _ =
@@ -471,6 +440,10 @@ instance PluginMethod Request Method_TextDocumentCodeLens where
471440
where
472441
uri = msgParams ^. L.textDocument . L.uri
473442

443+
instance PluginMethod Request Method_CodeLensResolve where
444+
pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCodeLensOn (configForPlugin config pluginDesc)
445+
446+
474447
instance PluginMethod Request Method_TextDocumentRename where
475448
pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc
476449
&& pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc)
@@ -542,6 +515,44 @@ instance PluginMethod Request (Method_CustomMethod m) where
542515
pluginEnabled _ _ _ _ = True
543516

544517
---
518+
instance PluginRequestMethod Method_TextDocumentCodeAction where
519+
combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps =
520+
InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps
521+
where
522+
compat :: (Command |? CodeAction) -> (Command |? CodeAction)
523+
compat x@(InL _) = x
524+
compat x@(InR action)
525+
| Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport
526+
= x
527+
| otherwise = InL cmd
528+
where
529+
cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. L.title) (Just cmdParams)
530+
cmdParams = [toJSON (FallbackCodeActionParams (action ^. L.edit) (action ^. L.command))]
531+
532+
wasRequested :: (Command |? CodeAction) -> Bool
533+
wasRequested (InL _) = True
534+
wasRequested (InR ca)
535+
| Nothing <- _only context = True
536+
| Just allowed <- _only context
537+
-- See https://github.com/microsoft/language-server-protocol/issues/970
538+
-- This is somewhat vague, but due to the hierarchical nature of action kinds, we
539+
-- should check whether the requested kind is a *prefix* of the action kind.
540+
-- That means, for example, we will return actions with kinds `quickfix.import` and
541+
-- `quickfix.somethingElse` if the requested kind is `quickfix`.
542+
, Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed
543+
| otherwise = False
544+
545+
-- Copied form lsp-types 1.6 to get compilation working. May make more
546+
-- sense to add it back to lsp-types 2.0
547+
-- | Does the first 'CodeActionKind' subsume the other one, hierarchically. Reflexive.
548+
codeActionKindSubsumes :: CodeActionKind -> CodeActionKind -> Bool
549+
-- Simple but ugly implementation: prefix on the string representation
550+
codeActionKindSubsumes parent child = toEnumBaseType parent `T.isPrefixOf` toEnumBaseType child
551+
552+
instance PluginRequestMethod Method_CodeActionResolve where
553+
-- TODO: Make a more serious combineResponses function
554+
combineResponses _ _ _ _ (x :| _) = x
555+
545556
instance PluginRequestMethod Method_TextDocumentDefinition where
546557
combineResponses _ _ _ _ (x :| _) = x
547558

@@ -559,6 +570,10 @@ instance PluginRequestMethod Method_WorkspaceSymbol where
559570

560571
instance PluginRequestMethod Method_TextDocumentCodeLens where
561572

573+
instance PluginRequestMethod Method_CodeLensResolve where
574+
-- TODO: Make a more serious combineResponses function
575+
combineResponses _ _ _ _ (x :| _) = x
576+
562577
instance PluginRequestMethod Method_TextDocumentRename where
563578

564579
instance PluginRequestMethod Method_TextDocumentHover where
@@ -956,7 +971,8 @@ instance HasTracing WorkspaceSymbolParams where
956971
instance HasTracing CallHierarchyIncomingCallsParams
957972
instance HasTracing CallHierarchyOutgoingCallsParams
958973
instance HasTracing CompletionItem
959-
974+
instance HasTracing CodeLens
975+
instance HasTracing CodeAction
960976
-- ---------------------------------------------------------------------
961977

962978
{-# NOINLINE pROCESS_ID #-}

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

+1
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ library
3030
exposed-modules: Ide.Plugin.OverloadedRecordDot
3131
build-depends:
3232
, base >=4.16 && <5
33+
, aeson
3334
, ghcide
3435
, hls-plugin-api
3536
, lsp

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

+84-23
Original file line numberDiff line numberDiff line change
@@ -13,16 +13,24 @@ module Ide.Plugin.OverloadedRecordDot
1313

1414
-- based off of Berk Okzuturk's hls-explicit-records-fields-plugin
1515

16-
import Control.Lens ((^.))
16+
import Control.Lens (_Just, (^.), (^?))
17+
import Control.Monad (replicateM)
1718
import Control.Monad.IO.Class (MonadIO, liftIO)
19+
import Control.Monad.Trans.Class (lift)
1820
import Control.Monad.Trans.Except (ExceptT)
21+
import Data.Aeson (FromJSON, ToJSON, decode,
22+
encode, fromJSON, toJSON)
1923
import Data.Generics (GenericQ, everything,
2024
everythingBut, mkQ)
25+
import qualified Data.IntMap.Strict as IntMap
2126
import qualified Data.Map as Map
22-
import Data.Maybe (mapMaybe, maybeToList)
27+
import Data.Maybe (fromJust, mapMaybe,
28+
maybeToList)
2329
import Data.Text (Text)
30+
import Data.Unique
2431
import Development.IDE (IdeState,
2532
NormalizedFilePath,
33+
NormalizedUri,
2634
Pretty (..), Range,
2735
Recorder (..), Rules,
2836
WithPriority (..),
@@ -76,17 +84,20 @@ import Ide.Types (PluginDescriptor (..),
7684
PluginMethodHandler,
7785
defaultPluginDescriptor,
7886
mkPluginHandler)
87+
import Language.LSP.Protocol.Lens (HasChanges (changes))
7988
import qualified Language.LSP.Protocol.Lens as L
8089
import Language.LSP.Protocol.Message (Method (..),
8190
SMethod (..))
8291
import Language.LSP.Protocol.Types (CodeAction (..),
8392
CodeActionKind (CodeActionKind_RefactorRewrite),
8493
CodeActionParams (..),
8594
Command, TextEdit (..),
95+
Uri (..),
8696
WorkspaceEdit (WorkspaceEdit),
8797
fromNormalizedUri,
8898
normalizedFilePathToUri,
8999
type (|?) (..))
100+
import Language.LSP.Server (getClientCapabilities)
90101
data Log
91102
= LogShake Shake.Log
92103
| LogCollectedRecordSelectors [RecordSelectorExpr]
@@ -105,7 +116,8 @@ instance Hashable CollectRecordSelectors
105116
instance NFData CollectRecordSelectors
106117

107118
data CollectRecordSelectorsResult = CRSR
108-
{ recordInfos :: RangeMap RecordSelectorExpr
119+
{ records :: RangeMap Int
120+
, recordInfos :: IntMap.IntMap RecordSelectorExpr
109121
, enabledExtensions :: [Extension]
110122
}
111123
deriving (Generic)
@@ -135,56 +147,102 @@ instance Pretty RecordSelectorExpr where
135147
instance NFData RecordSelectorExpr where
136148
rnf = rwhnf
137149

150+
data ORDResolveData = ORDRD {
151+
uri :: NormalizedFilePath
152+
, uniqueID :: Int
153+
} deriving (Generic, Show)
154+
instance ToJSON ORDResolveData
155+
instance FromJSON ORDResolveData
156+
157+
-- TODO: move the orphans to their packages
158+
instance ToJSON NormalizedFilePath
159+
instance FromJSON NormalizedFilePath
160+
instance ToJSON NormalizedUri
161+
instance FromJSON NormalizedUri
138162
descriptor :: Recorder (WithPriority Log) -> PluginId
139163
-> PluginDescriptor IdeState
140164
descriptor recorder plId = (defaultPluginDescriptor plId)
141165
{ pluginHandlers =
142-
mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider
166+
mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider <> mkPluginHandler SMethod_CodeActionResolve resolveProvider
143167
, pluginRules = collectRecSelsRule recorder
144168
}
145169

170+
resolveProvider :: PluginMethodHandler IdeState 'Method_CodeActionResolve
171+
resolveProvider ideState pId ca@(CodeAction _ _ _ _ _ _ _ (Just resData)) =
172+
pluginResponse $ do
173+
case decode . encode $ resData of
174+
Just (ORDRD nfp int) -> do
175+
CRSR _ crsDetails exts <- collectRecSelResult ideState nfp
176+
pragma <- getFirstPragma pId ideState nfp
177+
let pragmaEdit =
178+
if OverloadedRecordDot `elem` exts
179+
then Nothing
180+
else Just $ insertNewPragma pragma OverloadedRecordDot
181+
edits (Just crs) = convertRecordSelectors crs : maybeToList pragmaEdit
182+
edits _ = []
183+
changes = Just $ WorkspaceEdit
184+
(Just (Map.singleton (fromNormalizedUri
185+
(normalizedFilePathToUri nfp))
186+
(edits (IntMap.lookup int crsDetails))))
187+
Nothing Nothing
188+
pure $ ca {_edit = changes}
189+
_ -> pure ca
190+
146191
codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
147192
codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) =
148193
pluginResponse $ do
149194
nfp <- getNormalizedFilePath (caDocId ^. L.uri)
150195
pragma <- getFirstPragma pId ideState nfp
151-
CRSR crsMap exts <- collectRecSelResult ideState nfp
152-
let pragmaEdit =
196+
caps <- lift getClientCapabilities
197+
CRSR crsMap crsDetails exts <- collectRecSelResult ideState nfp
198+
let supportsResolve :: Maybe Bool
199+
supportsResolve = caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just
200+
pragmaEdit =
153201
if OverloadedRecordDot `elem` exts
154202
then Nothing
155203
else Just $ insertNewPragma pragma OverloadedRecordDot
156-
edits crs = convertRecordSelectors crs : maybeToList pragmaEdit
157-
changes crs =
158-
Just $ Map.singleton (fromNormalizedUri
204+
edits (Just crs) = convertRecordSelectors crs : maybeToList pragmaEdit
205+
edits _ = []
206+
changes crsM crsD =
207+
case supportsResolve of
208+
Just True -> Just $ WorkspaceEdit
209+
(Just (Map.singleton (fromNormalizedUri
159210
(normalizedFilePathToUri nfp))
160-
(edits crs)
161-
mkCodeAction crs = InR CodeAction
211+
(edits (IntMap.lookup crsM crsD))))
212+
Nothing Nothing
213+
_ -> Nothing
214+
resolveData crsM =
215+
case supportsResolve of
216+
Just True -> Just $ toJSON $ ORDRD nfp crsM
217+
_ -> Nothing
218+
mkCodeAction crsD crsM = InR CodeAction
162219
{ -- We pass the record selector to the title function, so that
163220
-- we can have the name of the record selector in the title of
164221
-- the codeAction. This allows the user can easily distinguish
165222
-- between the different codeActions when using nested record
166223
-- selectors, the disadvantage is we need to print out the
167224
-- name of the record selector which will decrease performance
168-
_title = mkCodeActionTitle exts crs
225+
_title = mkCodeActionTitle exts crsM crsD
169226
, _kind = Just CodeActionKind_RefactorRewrite
170227
, _diagnostics = Nothing
171228
, _isPreferred = Nothing
172229
, _disabled = Nothing
173-
, _edit = Just $ WorkspaceEdit (changes crs) Nothing Nothing
230+
, _edit = changes crsM crsD
174231
, _command = Nothing
175-
, _data_ = Nothing
232+
, _data_ = resolveData crsM
176233
}
177-
actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap)
234+
actions = map (mkCodeAction crsDetails) (RangeMap.filterByRange caRange crsMap)
178235
pure $ InL actions
179236
where
180-
mkCodeActionTitle :: [Extension] -> RecordSelectorExpr-> Text
181-
mkCodeActionTitle exts (RecordSelectorExpr _ se _) =
237+
mkCodeActionTitle :: [Extension] -> Int -> IntMap.IntMap RecordSelectorExpr-> Text
238+
mkCodeActionTitle exts crsM crsD =
182239
if OverloadedRecordDot `elem` exts
183240
then title
184241
else title <> " (needs extension: OverloadedRecordDot)"
185242
where
186-
title = "Convert `" <> name <> "` to record dot syntax"
187-
name = printOutputable se
243+
title = "Convert `" <> name (IntMap.lookup crsM crsD) <> "` to record dot syntax"
244+
name (Just (RecordSelectorExpr _ se _)) = printOutputable se
245+
name _ = ""
188246

189247
collectRecSelsRule :: Recorder (WithPriority Log) -> Rules ()
190248
collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $
@@ -201,11 +259,14 @@ collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $
201259
-- the OverloadedRecordDot pragma
202260
exts = getEnabledExtensions tmr
203261
recSels = mapMaybe (rewriteRange pm) (getRecordSelectors tmr)
262+
uniques <- liftIO $ replicateM (length recSels) (hashUnique <$> newUnique)
204263
logWith recorder Debug (LogCollectedRecordSelectors recSels)
205-
let -- We need the rangeMap to be able to filter by range later
206-
crsMap :: RangeMap RecordSelectorExpr
207-
crsMap = RangeMap.fromList location recSels
208-
pure ([], CRSR <$> Just crsMap <*> Just exts)
264+
let crsDetails = IntMap.fromList $ zip uniques recSels
265+
-- We need the rangeMap to be able to filter by range later
266+
crsMap :: RangeMap Int
267+
crsMap = RangeMap.fromList (location . (\x-> fromJust $ IntMap.lookup x crsDetails)) uniques
268+
crsDetails :: IntMap.IntMap RecordSelectorExpr
269+
pure ([], CRSR <$> Just crsMap <*> Just crsDetails <*> Just exts)
209270
where getEnabledExtensions :: TcModuleResult -> [Extension]
210271
getEnabledExtensions = getExtensions . tmrParsed
211272
getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr]

0 commit comments

Comments
 (0)