Skip to content

Commit bb742b3

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

File tree

3 files changed

+135
-37
lines changed

3 files changed

+135
-37
lines changed

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

+50-14
Original file line numberDiff line numberDiff line change
@@ -403,19 +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))]
406+
instance PluginMethod Request Method_CodeActionResolve where
407+
pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)
419408

420409
wasRequested :: (Command |? CodeAction) -> Bool
421410
wasRequested (InL _) = True
@@ -464,6 +453,10 @@ instance PluginMethod Request Method_TextDocumentCodeLens where
464453
where
465454
uri = msgParams ^. L.textDocument . L.uri
466455

456+
instance PluginMethod Request Method_CodeLensResolve where
457+
pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCodeLensOn (configForPlugin config pluginDesc)
458+
459+
467460
instance PluginMethod Request Method_TextDocumentRename where
468461
pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc
469462
&& pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc)
@@ -535,6 +528,44 @@ instance PluginMethod Request (Method_CustomMethod m) where
535528
pluginEnabled _ _ _ _ = True
536529

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

@@ -552,6 +583,10 @@ instance PluginRequestMethod Method_WorkspaceSymbol where
552583

553584
instance PluginRequestMethod Method_TextDocumentCodeLens where
554585

586+
instance PluginRequestMethod Method_CodeLensResolve where
587+
-- TODO: Make a more serious combineResponses function
588+
combineResponses _ _ _ _ (x :| _) = x
589+
555590
instance PluginRequestMethod Method_TextDocumentRename where
556591

557592
instance PluginRequestMethod Method_TextDocumentHover where
@@ -949,7 +984,8 @@ instance HasTracing WorkspaceSymbolParams where
949984
instance HasTracing CallHierarchyIncomingCallsParams
950985
instance HasTracing CallHierarchyOutgoingCallsParams
951986
instance HasTracing CompletionItem
952-
987+
instance HasTracing CodeLens
988+
instance HasTracing CodeAction
953989
-- ---------------------------------------------------------------------
954990

955991
{-# 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)