Skip to content

Commit 423c3a5

Browse files
maralornJuly541
maralorn
and
July541
authored
Correctly pass VersionedTextDocumentIdentifier through hls (#3643)
* Update version while editing to conform lsp spec * Init fields * Remove the empty line * modify for hls-tactics-plugin * name test * Pass VersionedTextDocumentIdentifier through * Also use VersionedTextDocumentIdentifier in wingman --------- Co-authored-by: Lei Zhu <[email protected]>
1 parent 8176fb8 commit 423c3a5

File tree

15 files changed

+136
-89
lines changed

15 files changed

+136
-89
lines changed

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

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,7 @@ where
4141

4242

4343
import Control.Arrow ((&&&))
44+
import Control.Lens ((^.))
4445
import Control.Monad.Extra (maybeM)
4546
import Control.Monad.Trans.Class (lift)
4647
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
@@ -63,6 +64,7 @@ import Language.LSP.Types hiding
6364
SemanticTokensEdit (_start))
6465
import qualified Language.LSP.Types as J
6566
import Language.LSP.Types.Capabilities
67+
import qualified Language.LSP.Types.Lens as J
6668
import qualified Text.Megaparsec as P
6769
import qualified Text.Megaparsec.Char as P
6870
import qualified Text.Megaparsec.Char.Lexer as P
@@ -98,7 +100,7 @@ data WithDeletions = IncludeDeletions | SkipDeletions
98100
deriving Eq
99101

100102
-- | Generate a 'WorkspaceEdit' value from a pair of source Text
101-
diffText :: ClientCapabilities -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit
103+
diffText :: ClientCapabilities -> (VersionedTextDocumentIdentifier,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit
102104
diffText clientCaps old new withDeletions =
103105
let
104106
supports = clientSupportsDocumentChanges clientCaps
@@ -161,16 +163,16 @@ diffTextEdit fText f2Text withDeletions = J.List r
161163

162164

163165
-- | A pure version of 'diffText' for testing
164-
diffText' :: Bool -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit
165-
diffText' supports (f,fText) f2Text withDeletions =
166+
diffText' :: Bool -> (VersionedTextDocumentIdentifier,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit
167+
diffText' supports (verTxtDocId,fText) f2Text withDeletions =
166168
if supports
167169
then WorkspaceEdit Nothing (Just docChanges) Nothing
168170
else WorkspaceEdit (Just h) Nothing Nothing
169171
where
170172
diff = diffTextEdit fText f2Text withDeletions
171-
h = H.singleton f diff
173+
h = H.singleton (verTxtDocId ^. J.uri) diff
172174
docChanges = J.List [InL docEdit]
173-
docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) $ fmap InL diff
175+
docEdit = J.TextDocumentEdit verTxtDocId $ fmap InL diff
174176

175177
-- ---------------------------------------------------------------------
176178

‎plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs‎

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,7 @@ addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsP
4242
addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do
4343
caps <- getClientCapabilities
4444
pluginResponse $ do
45-
nfp <- getNormalizedFilePath uri
45+
nfp <- getNormalizedFilePath (verTxtDocId ^. J.uri)
4646
pm <- handleMaybeM "Unable to GetParsedModule"
4747
$ liftIO
4848
$ runAction "classplugin.addMethodPlaceholders.GetParsedModule" state
@@ -65,7 +65,7 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do
6565
pure Null
6666
where
6767
toTextDocumentEdit edit =
68-
TextDocumentEdit (VersionedTextDocumentIdentifier uri (Just 0)) (List [InL edit])
68+
TextDocumentEdit verTxtDocId (List [InL edit])
6969

7070
mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit
7171
mergeEdit WorkspaceEdit{..} edits = WorkspaceEdit
@@ -76,28 +76,29 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do
7676
}
7777

7878
workspaceEdit caps old new
79-
= diffText caps (uri, old) new IncludeDeletions
79+
= diffText caps (verTxtDocId, old) new IncludeDeletions
8080

8181
-- |
8282
-- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is
8383
-- sensitive to the format of diagnostic messages from GHC.
8484
codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeAction
8585
codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginResponse $ do
86-
nfp <- getNormalizedFilePath uri
87-
actions <- join <$> mapM (mkActions nfp) methodDiags
86+
verTxtDocId <- lift $ getVersionedTextDoc docId
87+
nfp <- getNormalizedFilePath (verTxtDocId ^. J.uri)
88+
actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags
8889
pure $ List actions
8990
where
90-
uri = docId ^. J.uri
9191
List diags = context ^. J.diagnostics
9292

9393
ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags
9494
methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags
9595

9696
mkActions
9797
:: NormalizedFilePath
98+
-> VersionedTextDocumentIdentifier
9899
-> Diagnostic
99100
-> ExceptT String (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction]
100-
mkActions docPath diag = do
101+
mkActions docPath verTxtDocId diag = do
101102
(HAR {hieAst = ast}, pmap) <- handleMaybeM "Unable to GetHieAst"
102103
. liftIO
103104
. runAction "classplugin.findClassIdentifier.GetHieAst" state
@@ -142,7 +143,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe
142143
titleWithSig = title <> " with signature(s)"
143144

144145
mkCmdParams methodGroup withSig =
145-
[toJSON (AddMinimalMethodsParams uri range (List methodGroup) withSig)]
146+
[toJSON (AddMinimalMethodsParams verTxtDocId range (List methodGroup) withSig)]
146147

147148
mkCodeAction title cmd
148149
= InR

‎plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,6 @@
44
{-# LANGUAGE LambdaCase #-}
55
{-# LANGUAGE TypeFamilies #-}
66
{-# LANGUAGE ViewPatterns #-}
7-
{-# LANGUAGE BangPatterns #-}
87

98
module Ide.Plugin.Class.Types where
109

@@ -21,6 +20,7 @@ import Development.IDE.Graph.Classes
2120
import GHC.Generics
2221
import Ide.Plugin.Class.Utils
2322
import Ide.Types
23+
import Language.LSP.Types (VersionedTextDocumentIdentifier)
2424

2525
typeLensCommandId :: CommandId
2626
typeLensCommandId = "classplugin.typelens"
@@ -33,7 +33,7 @@ defaultIndent :: Int
3333
defaultIndent = 2
3434

3535
data AddMinimalMethodsParams = AddMinimalMethodsParams
36-
{ uri :: Uri
36+
{ verTxtDocId :: VersionedTextDocumentIdentifier
3737
, range :: Range
3838
, methodGroup :: List (T.Text, T.Text)
3939
-- ^ (name text, signature text)

‎plugins/hls-class-plugin/test/Main.hs‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -76,6 +76,30 @@ codeActionTests = testGroup
7676
[ "Add placeholders for 'f','g'"
7777
, "Add placeholders for 'f','g' with signature(s)"
7878
]
79+
, testCase "Update text document version" $ runSessionWithServer classPlugin testDataDir $ do
80+
doc <- createDoc "Version.hs" "haskell" "module Version where"
81+
ver1 <- (^.J.version) <$> getVersionedDoc doc
82+
liftIO $ ver1 @?= Just 0
83+
84+
-- Change the doc to ensure the version is not 0
85+
changeDoc doc
86+
[ TextDocumentContentChangeEvent
87+
Nothing
88+
Nothing
89+
(T.unlines ["module Version where", "data A a = A a", "instance Functor A where"])
90+
]
91+
ver2 <- (^.J.version) <$> getVersionedDoc doc
92+
_ <- waitForDiagnostics
93+
liftIO $ ver2 @?= Just 1
94+
95+
-- Execute the action and see what the version is
96+
action <- head . concatMap (^.. _CACodeAction) <$> getAllCodeActions doc
97+
executeCodeAction action
98+
_ <- waitForDiagnostics
99+
-- TODO: uncomment this after lsp-test fixed
100+
-- ver3 <- (^.J.version) <$> getVersionedDoc doc
101+
-- liftIO $ ver3 @?= Just 3
102+
pure mempty
79103
]
80104

81105
codeLensTests :: TestTree

‎plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs‎

Lines changed: 28 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -121,6 +121,7 @@ import Ide.Types hiding
121121
import Language.Haskell.HLint as Hlint hiding
122122
(Error)
123123
import Language.LSP.Server (ProgressCancellable (Cancellable),
124+
getVersionedTextDoc,
124125
sendRequest,
125126
withIndefiniteProgress)
126127
import Language.LSP.Types hiding
@@ -407,8 +408,11 @@ codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
407408
codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context)
408409
| let TextDocumentIdentifier uri = documentId
409410
, Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri)
410-
= liftIO $ fmap (Right . LSP.List . map LSP.InR) $ do
411+
= do
412+
verTxtDocId <- getVersionedTextDoc documentId
413+
liftIO $ fmap (Right . LSP.List . map LSP.InR) $ do
411414
allDiagnostics <- atomically $ getDiagnostics ideState
415+
412416
let numHintsInDoc = length
413417
[diagnostic | (diagnosticNormalizedFilePath, _, diagnostic) <- allDiagnostics
414418
, validCommand diagnostic
@@ -425,19 +429,19 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context)
425429
pure if | Just modSummaryResult <- modSummaryResult
426430
, Just source <- source
427431
, let dynFlags = ms_hspp_opts $ msrModSummary modSummaryResult ->
428-
diags >>= diagnosticToCodeActions dynFlags source pluginId documentId
432+
diags >>= diagnosticToCodeActions dynFlags source pluginId verTxtDocId
429433
| otherwise -> []
430434
| otherwise -> pure []
431435
if numHintsInDoc > 1 && numHintsInContext > 0 then do
432-
pure $ singleHintCodeActions ++ [applyAllAction]
436+
pure $ singleHintCodeActions ++ [applyAllAction verTxtDocId]
433437
else
434438
pure singleHintCodeActions
435439
| otherwise
436440
= pure $ Right $ LSP.List []
437441

438442
where
439-
applyAllAction =
440-
let args = Just [toJSON (documentId ^. LSP.uri)]
443+
applyAllAction verTxtDocId =
444+
let args = Just [toJSON verTxtDocId]
441445
cmd = mkLspCommand pluginId "applyAll" "Apply all hints" args
442446
in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) Nothing
443447

@@ -451,25 +455,24 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context)
451455

452456
-- | Convert a hlint diagnostic into an apply and an ignore code action
453457
-- if applicable
454-
diagnosticToCodeActions :: DynFlags -> T.Text -> PluginId -> TextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]
455-
diagnosticToCodeActions dynFlags fileContents pluginId documentId diagnostic
458+
diagnosticToCodeActions :: DynFlags -> T.Text -> PluginId -> VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]
459+
diagnosticToCodeActions dynFlags fileContents pluginId verTxtDocId diagnostic
456460
| LSP.Diagnostic{ _source = Just "hlint", _code = Just (InR code), _range = LSP.Range start _ } <- diagnostic
457-
, let TextDocumentIdentifier uri = documentId
458461
, let isHintApplicable = "refact:" `T.isPrefixOf` code
459462
, let hint = T.replace "refact:" "" code
460463
, let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module"
461464
, let suppressHintTextEdits = mkSuppressHintTextEdits dynFlags fileContents hint
462465
, let suppressHintWorkspaceEdit =
463466
LSP.WorkspaceEdit
464-
(Just (Map.singleton uri (List suppressHintTextEdits)))
467+
(Just (Map.singleton (verTxtDocId ^. LSP.uri) (List suppressHintTextEdits)))
465468
Nothing
466469
Nothing
467470
= catMaybes
468471
-- Applying the hint is marked preferred because it addresses the underlying error.
469472
-- Disabling the rule isn't, because less often used and configuration can be adapted.
470473
[ if | isHintApplicable
471474
, let applyHintTitle = "Apply hint \"" <> hint <> "\""
472-
applyHintArguments = [toJSON (AOP (documentId ^. LSP.uri) start hint)]
475+
applyHintArguments = [toJSON (AOP verTxtDocId start hint)]
473476
applyHintCommand = mkLspCommand pluginId "applyOne" applyHintTitle (Just applyHintArguments) ->
474477
Just (mkCodeAction applyHintTitle diagnostic Nothing (Just applyHintCommand) True)
475478
| otherwise -> Nothing
@@ -511,13 +514,13 @@ mkSuppressHintTextEdits dynFlags fileContents hint =
511514
combinedTextEdit : lineSplitTextEditList
512515
-- ---------------------------------------------------------------------
513516

514-
applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
515-
applyAllCmd recorder ide uri = do
516-
let file = maybe (error $ show uri ++ " is not a file.")
517+
applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState VersionedTextDocumentIdentifier
518+
applyAllCmd recorder ide verTxtDocId = do
519+
let file = maybe (error $ show (verTxtDocId ^. LSP.uri) ++ " is not a file.")
517520
toNormalizedFilePath'
518-
(uriToFilePath' uri)
521+
(uriToFilePath' (verTxtDocId ^. LSP.uri))
519522
withIndefiniteProgress "Applying all hints" Cancellable $ do
520-
res <- liftIO $ applyHint recorder ide file Nothing
523+
res <- liftIO $ applyHint recorder ide file Nothing verTxtDocId
521524
logWith recorder Debug $ LogApplying file res
522525
case res of
523526
Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err))
@@ -528,10 +531,10 @@ applyAllCmd recorder ide uri = do
528531
-- ---------------------------------------------------------------------
529532

530533
data ApplyOneParams = AOP
531-
{ file :: Uri
532-
, start_pos :: Position
534+
{ verTxtDocId :: VersionedTextDocumentIdentifier
535+
, start_pos :: Position
533536
-- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
534-
, hintTitle :: HintTitle
537+
, hintTitle :: HintTitle
535538
} deriving (Eq,Show,Generic,FromJSON,ToJSON)
536539

537540
type HintTitle = T.Text
@@ -542,22 +545,22 @@ data OneHint = OneHint
542545
} deriving (Eq, Show)
543546

544547
applyOneCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState ApplyOneParams
545-
applyOneCmd recorder ide (AOP uri pos title) = do
548+
applyOneCmd recorder ide (AOP verTxtDocId pos title) = do
546549
let oneHint = OneHint pos title
547-
let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath'
548-
(uriToFilePath' uri)
550+
let file = maybe (error $ show (verTxtDocId ^. LSP.uri) ++ " is not a file.") toNormalizedFilePath'
551+
(uriToFilePath' (verTxtDocId ^. LSP.uri))
549552
let progTitle = "Applying hint: " <> title
550553
withIndefiniteProgress progTitle Cancellable $ do
551-
res <- liftIO $ applyHint recorder ide file (Just oneHint)
554+
res <- liftIO $ applyHint recorder ide file (Just oneHint) verTxtDocId
552555
logWith recorder Debug $ LogApplying file res
553556
case res of
554557
Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err))
555558
Right fs -> do
556559
_ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ())
557560
pure $ Right Null
558561

559-
applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit)
560-
applyHint recorder ide nfp mhint =
562+
applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either String WorkspaceEdit)
563+
applyHint recorder ide nfp mhint verTxtDocId =
561564
runExceptT $ do
562565
let runAction' :: Action a -> IO a
563566
runAction' = runAction "applyHint" ide
@@ -614,8 +617,7 @@ applyHint recorder ide nfp mhint =
614617
#endif
615618
case res of
616619
Right appliedFile -> do
617-
let uri = fromNormalizedUri (filePathToUri' nfp)
618-
let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions
620+
let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions
619621
ExceptT $ return (Right wsEdit)
620622
Left err ->
621623
throwE err

‎plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -210,15 +210,15 @@ instance Monad m => Monoid (Graft m a) where
210210
transform ::
211211
DynFlags ->
212212
ClientCapabilities ->
213-
Uri ->
213+
VersionedTextDocumentIdentifier ->
214214
Graft (Either String) ParsedSource ->
215215
Annotated ParsedSource ->
216216
Either String WorkspaceEdit
217-
transform dflags ccs uri f a = do
217+
transform dflags ccs verTxtDocId f a = do
218218
let src = printA a
219219
a' <- transformA a $ runGraft f dflags
220220
let res = printA a'
221-
pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions
221+
pure $ diffText ccs (verTxtDocId, T.pack src) (T.pack res) IncludeDeletions
222222

223223
------------------------------------------------------------------------------
224224

@@ -227,16 +227,16 @@ transformM ::
227227
Monad m =>
228228
DynFlags ->
229229
ClientCapabilities ->
230-
Uri ->
230+
VersionedTextDocumentIdentifier ->
231231
Graft (ExceptStringT m) ParsedSource ->
232232
Annotated ParsedSource ->
233233
m (Either String WorkspaceEdit)
234-
transformM dflags ccs uri f a = runExceptT $
234+
transformM dflags ccs verTextDocId f a = runExceptT $
235235
runExceptString $ do
236236
let src = printA a
237237
a' <- transformA a $ runGraft f dflags
238238
let res = printA a'
239-
pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions
239+
pure $ diffText ccs (verTextDocId, T.pack src) (T.pack res) IncludeDeletions
240240

241241

242242
-- | Returns whether or not this node requires its immediate children to have

‎plugins/hls-rename-plugin/hls-rename-plugin.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ library
3535
, hie-compat
3636
, hls-plugin-api == 2.0.0.0
3737
, hls-refactor-plugin
38+
, lens
3839
, lsp
3940
, lsp-types
4041
, mod

0 commit comments

Comments
 (0)