From 6df1c768b3fbe84c8da6c3f01c233ffa885fde18 Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Wed, 19 Apr 2023 22:21:30 +0800 Subject: [PATCH 1/5] Update version while editing to conform lsp spec --- .../src/Ide/Plugin/Class/CodeAction.hs | 22 +++++++++-------- .../src/Ide/Plugin/Class/Types.hs | 4 +++- plugins/hls-class-plugin/test/Main.hs | 24 +++++++++++++++++++ 3 files changed, 39 insertions(+), 11 deletions(-) diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index 6b18a8e1df..3f50b982d7 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -65,7 +65,7 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do pure Null where toTextDocumentEdit edit = - TextDocumentEdit (VersionedTextDocumentIdentifier uri (Just 0)) (List [InL edit]) + TextDocumentEdit (VersionedTextDocumentIdentifier uri textVersion) (List [InL edit]) mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit mergeEdit WorkspaceEdit{..} edits = WorkspaceEdit @@ -84,7 +84,8 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeAction codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginResponse $ do nfp <- getNormalizedFilePath uri - actions <- join <$> mapM (mkActions nfp) methodDiags + version <- lift $ (^. J.version) <$> getVersionedTextDoc docId + actions <- join <$> mapM (mkActions nfp version) methodDiags pure $ List actions where uri = docId ^. J.uri @@ -95,9 +96,10 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe mkActions :: NormalizedFilePath + -> TextDocumentVersion -> Diagnostic -> ExceptT String (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] - mkActions docPath diag = do + mkActions docPath textVersion diag = do (HAR {hieAst = ast}, pmap) <- handleMaybeM "Unable to GetHieAst" . liftIO . runAction "classplugin.findClassIdentifier.GetHieAst" state @@ -114,7 +116,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe implemented <- findImplementedMethods ast instancePosition logWith recorder Info (LogImplementedMethods cls implemented) pure - $ concatMap mkAction + $ concatMap (mkAction textVersion) $ nubOrdOn snd $ filter ((/=) mempty . snd) $ fmap (second (filter (\(bind, _) -> bind `notElem` implemented))) @@ -128,21 +130,21 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe minimalDef = minDefToMethodGroups range sigs $ classMinimalDef cls allClassMethods = ("all missing methods", makeMethodDefinitions range sigs) - mkAction :: MethodGroup -> [Command |? CodeAction] - mkAction (name, methods) + mkAction :: TextDocumentVersion -> MethodGroup -> [Command |? CodeAction] + mkAction textVersion (name, methods) = [ mkCodeAction title $ mkLspCommand plId codeActionCommandId title - (Just $ mkCmdParams methods False) + (Just $ mkCmdParams methods textVersion False) , mkCodeAction titleWithSig $ mkLspCommand plId codeActionCommandId titleWithSig - (Just $ mkCmdParams methods True) + (Just $ mkCmdParams methods textVersion True) ] where title = "Add placeholders for " <> name titleWithSig = title <> " with signature(s)" - mkCmdParams methodGroup withSig = - [toJSON (AddMinimalMethodsParams uri range (List methodGroup) withSig)] + mkCmdParams methodGroup textVersion withSig = + [toJSON (AddMinimalMethodsParams uri range (List methodGroup) withSig textVersion)] mkCodeAction title cmd = InR diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index 8530b0f18f..8eddce1df7 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -1,10 +1,10 @@ + {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE BangPatterns #-} module Ide.Plugin.Class.Types where @@ -21,6 +21,7 @@ import Development.IDE.Graph.Classes import GHC.Generics import Ide.Plugin.Class.Utils import Ide.Types +import Language.LSP.Types (TextDocumentVersion) typeLensCommandId :: CommandId typeLensCommandId = "classplugin.typelens" @@ -38,6 +39,7 @@ data AddMinimalMethodsParams = AddMinimalMethodsParams , methodGroup :: List (T.Text, T.Text) -- ^ (name text, signature text) , withSig :: Bool + , textVersion :: TextDocumentVersion } deriving (Show, Eq, Generic, ToJSON, FromJSON) diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index b8c8cfaebc..c8215dbbf3 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -76,6 +76,30 @@ codeActionTests = testGroup [ "Add placeholders for 'f','g'" , "Add placeholders for 'f','g' with signature(s)" ] + , testCase "" $ runSessionWithServer classPlugin testDataDir $ do + doc <- createDoc "Version.hs" "haskell" "module Version where" + ver1 <- (^.J.version) <$> getVersionedDoc doc + liftIO $ ver1 @?= Just 0 + + -- Change the doc to ensure the version is not 0 + changeDoc doc + [ TextDocumentContentChangeEvent + Nothing + Nothing + (T.unlines ["module Version where", "data A a = A a", "instance Functor A where"]) + ] + ver2 <- (^.J.version) <$> getVersionedDoc doc + _ <- waitForDiagnostics + liftIO $ ver2 @?= Just 1 + + -- Execute the action and see what the version is + action <- head . concatMap (^.. _CACodeAction) <$> getAllCodeActions doc + executeCodeAction action + _ <- waitForDiagnostics + -- TODO: uncomment this after lsp-test fixed + -- ver3 <- (^.J.version) <$> getVersionedDoc doc + -- liftIO $ ver3 @?= Just 3 + pure mempty ] codeLensTests :: TestTree From 21f5cda64ad9c593a97662828fa1cd498f39fbe0 Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 18:25:54 +0800 Subject: [PATCH 2/5] Init fields --- hls-plugin-api/src/Ide/PluginUtils.hs | 8 ++-- .../src/Ide/Plugin/Class/CodeAction.hs | 4 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 43 +++++++++++-------- .../src/Development/IDE/GHC/ExactPrint.hs | 10 +++-- .../src/Ide/Plugin/Rename.hs | 21 +++++---- .../src/Ide/Plugin/Splice.hs | 11 +++-- .../src/Ide/Plugin/Splice/Types.hs | 2 + 7 files changed, 57 insertions(+), 42 deletions(-) diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index f98b38ff80..4230decc12 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -98,7 +98,7 @@ data WithDeletions = IncludeDeletions | SkipDeletions deriving Eq -- | Generate a 'WorkspaceEdit' value from a pair of source Text -diffText :: ClientCapabilities -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit +diffText :: ClientCapabilities -> (Uri,T.Text) -> T.Text -> WithDeletions -> TextDocumentVersion -> WorkspaceEdit diffText clientCaps old new withDeletions = let supports = clientSupportsDocumentChanges clientCaps @@ -161,8 +161,8 @@ diffTextEdit fText f2Text withDeletions = J.List r -- | A pure version of 'diffText' for testing -diffText' :: Bool -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit -diffText' supports (f,fText) f2Text withDeletions = +diffText' :: Bool -> (Uri,T.Text) -> T.Text -> WithDeletions -> TextDocumentVersion -> WorkspaceEdit +diffText' supports (f,fText) f2Text withDeletions version = if supports then WorkspaceEdit Nothing (Just docChanges) Nothing else WorkspaceEdit (Just h) Nothing Nothing @@ -170,7 +170,7 @@ diffText' supports (f,fText) f2Text withDeletions = diff = diffTextEdit fText f2Text withDeletions h = H.singleton f diff docChanges = J.List [InL docEdit] - docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) $ fmap InL diff + docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f version) $ fmap InL diff -- --------------------------------------------------------------------- diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index 3f50b982d7..010c6b9ebd 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -57,8 +57,8 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs let edit = if withSig - then mergeEdit (workspaceEdit caps old new) pragmaInsertion - else workspaceEdit caps old new + then mergeEdit (workspaceEdit caps old new textVersion) pragmaInsertion + else workspaceEdit caps old new textVersion void $ lift $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 89c07e55f1..f34a2786ca 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -121,6 +121,7 @@ import Ide.Types hiding import Language.Haskell.HLint as Hlint hiding (Error) import Language.LSP.Server (ProgressCancellable (Cancellable), + getVersionedTextDoc, sendRequest, withIndefiniteProgress) import Language.LSP.Types hiding @@ -407,8 +408,11 @@ codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) | let TextDocumentIdentifier uri = documentId , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) - = liftIO $ fmap (Right . LSP.List . map LSP.InR) $ do + = do + version <- (^. LSP.version) <$> getVersionedTextDoc documentId + liftIO $ fmap (Right . LSP.List . map LSP.InR) $ do allDiagnostics <- atomically $ getDiagnostics ideState + let numHintsInDoc = length [diagnostic | (diagnosticNormalizedFilePath, _, diagnostic) <- allDiagnostics , validCommand diagnostic @@ -425,19 +429,19 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) pure if | Just modSummaryResult <- modSummaryResult , Just source <- source , let dynFlags = ms_hspp_opts $ msrModSummary modSummaryResult -> - diags >>= diagnosticToCodeActions dynFlags source pluginId documentId + diags >>= diagnosticToCodeActions dynFlags source pluginId documentId version | otherwise -> [] | otherwise -> pure [] if numHintsInDoc > 1 && numHintsInContext > 0 then do - pure $ singleHintCodeActions ++ [applyAllAction] + pure $ singleHintCodeActions ++ [applyAllAction version] else pure singleHintCodeActions | otherwise = pure $ Right $ LSP.List [] where - applyAllAction = - let args = Just [toJSON (documentId ^. LSP.uri)] + applyAllAction version = + let args = Just [toJSON (documentId ^. LSP.uri, version)] cmd = mkLspCommand pluginId "applyAll" "Apply all hints" args in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) Nothing @@ -451,8 +455,8 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) -- | Convert a hlint diagnostic into an apply and an ignore code action -- if applicable -diagnosticToCodeActions :: DynFlags -> T.Text -> PluginId -> TextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction] -diagnosticToCodeActions dynFlags fileContents pluginId documentId diagnostic +diagnosticToCodeActions :: DynFlags -> T.Text -> PluginId -> TextDocumentIdentifier -> TextDocumentVersion -> LSP.Diagnostic -> [LSP.CodeAction] +diagnosticToCodeActions dynFlags fileContents pluginId documentId version diagnostic | LSP.Diagnostic{ _source = Just "hlint", _code = Just (InR code), _range = LSP.Range start _ } <- diagnostic , let TextDocumentIdentifier uri = documentId , let isHintApplicable = "refact:" `T.isPrefixOf` code @@ -469,7 +473,7 @@ diagnosticToCodeActions dynFlags fileContents pluginId documentId diagnostic -- Disabling the rule isn't, because less often used and configuration can be adapted. [ if | isHintApplicable , let applyHintTitle = "Apply hint \"" <> hint <> "\"" - applyHintArguments = [toJSON (AOP (documentId ^. LSP.uri) start hint)] + applyHintArguments = [toJSON (AOP (documentId ^. LSP.uri) start hint version)] applyHintCommand = mkLspCommand pluginId "applyOne" applyHintTitle (Just applyHintArguments) -> Just (mkCodeAction applyHintTitle diagnostic Nothing (Just applyHintCommand) True) | otherwise -> Nothing @@ -511,13 +515,13 @@ mkSuppressHintTextEdits dynFlags fileContents hint = combinedTextEdit : lineSplitTextEditList -- --------------------------------------------------------------------- -applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri -applyAllCmd recorder ide uri = do +applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState (Uri, TextDocumentVersion) +applyAllCmd recorder ide (uri, version) = do let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) withIndefiniteProgress "Applying all hints" Cancellable $ do - res <- liftIO $ applyHint recorder ide file Nothing + res <- liftIO $ applyHint recorder ide file Nothing version logWith recorder Debug $ LogApplying file res case res of Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)) @@ -528,10 +532,11 @@ applyAllCmd recorder ide uri = do -- --------------------------------------------------------------------- data ApplyOneParams = AOP - { file :: Uri - , start_pos :: Position + { file :: Uri + , start_pos :: Position -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them. - , hintTitle :: HintTitle + , hintTitle :: HintTitle + , textVersion :: TextDocumentVersion } deriving (Eq,Show,Generic,FromJSON,ToJSON) type HintTitle = T.Text @@ -542,13 +547,13 @@ data OneHint = OneHint } deriving (Eq, Show) applyOneCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState ApplyOneParams -applyOneCmd recorder ide (AOP uri pos title) = do +applyOneCmd recorder ide (AOP uri pos title version) = do let oneHint = OneHint pos title let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) let progTitle = "Applying hint: " <> title withIndefiniteProgress progTitle Cancellable $ do - res <- liftIO $ applyHint recorder ide file (Just oneHint) + res <- liftIO $ applyHint recorder ide file (Just oneHint) version logWith recorder Debug $ LogApplying file res case res of Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)) @@ -556,8 +561,8 @@ applyOneCmd recorder ide (AOP uri pos title) = do _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) pure $ Right Null -applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) -applyHint recorder ide nfp mhint = +applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> TextDocumentVersion -> IO (Either String WorkspaceEdit) +applyHint recorder ide nfp mhint version = runExceptT $ do let runAction' :: Action a -> IO a runAction' = runAction "applyHint" ide @@ -615,7 +620,7 @@ applyHint recorder ide nfp mhint = case res of Right appliedFile -> do let uri = fromNormalizedUri (filePathToUri' nfp) - let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions + let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions version ExceptT $ return (Right wsEdit) Left err -> throwE err diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index a265a1b505..6782c4e45a 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -211,14 +211,15 @@ transform :: DynFlags -> ClientCapabilities -> Uri -> + TextDocumentVersion -> Graft (Either String) ParsedSource -> Annotated ParsedSource -> Either String WorkspaceEdit -transform dflags ccs uri f a = do +transform dflags ccs uri version f a = do let src = printA a a' <- transformA a $ runGraft f dflags let res = printA a' - pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions + pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions version ------------------------------------------------------------------------------ @@ -228,15 +229,16 @@ transformM :: DynFlags -> ClientCapabilities -> Uri -> + TextDocumentVersion -> Graft (ExceptStringT m) ParsedSource -> Annotated ParsedSource -> m (Either String WorkspaceEdit) -transformM dflags ccs uri f a = runExceptT $ +transformM dflags ccs uri version f a = runExceptT $ runExceptString $ do let src = printA a a' <- transformA a $ runGraft f dflags let res = printA a' - pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions + pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions version -- | Returns whether or not this node requires its immediate children to have diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index f711eea36a..375be9fa11 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -6,9 +6,9 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Rename (descriptor, E.Log) where @@ -17,20 +17,21 @@ import GHC.Parser.Annotation (AnnContext, AnnList, AnnParen, AnnPragma) #endif +import Compat.HieTypes import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except -import Data.Generics import Data.Bifunctor (first) +import Data.Generics import Data.Hashable import Data.HashSet (HashSet) import qualified Data.HashSet as HS import Data.List.Extra hiding (length) import qualified Data.Map as M -import qualified Data.Set as S import Data.Maybe import Data.Mod.Word +import qualified Data.Set as S import qualified Data.Text as T import Development.IDE (Recorder, WithPriority, usePropertyAction) @@ -54,7 +55,7 @@ import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types -import Compat.HieTypes +import qualified Language.LSP.Types.Lens as J instance Hashable (Mod a) where hash n = hash (unMod n) @@ -66,9 +67,10 @@ descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultP } renameProvider :: PluginMethodHandler IdeState TextDocumentRename -renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _prog newNameText) = +renameProvider state pluginId (RenameParams docId@(TextDocumentIdentifier uri) pos _prog newNameText) = pluginResponse $ do nfp <- handleUriToNfp uri + VersionedTextDocumentIdentifier{_version = version} <- lift $ getVersionedTextDoc docId directOldNames <- getNamesAtPos state nfp pos directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames @@ -78,7 +80,7 @@ renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _pr See the `IndirectPuns` test for an example. -} indirectOldNames <- concat . filter ((>1) . Prelude.length) <$> mapM (uncurry (getNamesAtPos state) . locToFilePos) directRefs - let oldNames = (filter matchesDirect indirectOldNames) ++ directOldNames + let oldNames = filter matchesDirect indirectOldNames ++ directOldNames matchesDirect n = occNameFS (nameOccName n) `elem` directFS where directFS = map (occNameFS. nameOccName) directOldNames @@ -92,7 +94,7 @@ renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _pr -- Perform rename let newName = mkTcOcc $ T.unpack newNameText filesRefs = collectWith locToUri refs - getFileEdit = flip $ getSrcEdit state . replaceRefs newName + getFileEdit = flip $ getSrcEdit state version . replaceRefs newName fileEdits <- mapM (uncurry getFileEdit) filesRefs pure $ foldl' (<>) mempty fileEdits @@ -125,10 +127,11 @@ failWhenImportOrExport state nfp refLocs names = do getSrcEdit :: (MonadLsp config m) => IdeState -> + TextDocumentVersion -> (ParsedSource -> ParsedSource) -> Uri -> ExceptT String m WorkspaceEdit -getSrcEdit state updatePs uri = do +getSrcEdit state version updatePs uri = do ccs <- lift getClientCapabilities nfp <- handleUriToNfp uri annAst <- handleMaybeM ("No parsed source for: " ++ show nfp) $ liftIO $ runAction @@ -143,7 +146,7 @@ getSrcEdit state updatePs uri = do let src = T.pack $ exactPrint ps res = T.pack $ exactPrint (updatePs ps) #endif - pure $ diffText ccs (uri, src) res IncludeDeletions + pure $ diffText ccs (uri, src) res IncludeDeletions version -- | Replace names at every given `Location` (in a given `ParsedSource`) with a given new name. replaceRefs :: diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 6cd0b9ab7a..8c00100573 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -151,6 +151,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do dflags clientCapabilities uri + textVersion (graft (RealSrcSpan spliceSpan Nothing) expanded) ps maybe (throwE "No splice information found") (either throwE pure) $ @@ -167,6 +168,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do dflags clientCapabilities uri + textVersion (graftDecls (RealSrcSpan spliceSpan Nothing) expanded) ps <&> @@ -377,7 +379,7 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e initTcWithGbl hscEnv typechkd srcSpan $ case classifyAST spliceContext of IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $ - flip (transformM dflags clientCapabilities uri) ps $ + flip (transformM dflags clientCapabilities uri textVersion) ps $ graftDeclsWithM (RealSrcSpan srcSpan Nothing) $ \case (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do eExpr <- @@ -390,7 +392,7 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e pure $ Just eExpr _ -> pure Nothing OneToOneAST astP -> - flip (transformM dflags clientCapabilities uri) ps $ + flip (transformM dflags clientCapabilities uri textVersion) ps $ graftWithM (RealSrcSpan srcSpan Nothing) $ \case (L _spn (matchSplice astP -> Just spl)) -> do eExpr <- @@ -484,8 +486,9 @@ fromSearchResult _ = Nothing -- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) -- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction -codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ - fmap (maybe (Right $ List []) Right) $ +codeAction state plId (CodeActionParams _ _ docId ran _) = do + textVersion <- (^. J.version) <$> getVersionedTextDoc docId + liftIO $ fmap (maybe (Right $ List []) Right) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri ParsedModule {..} <- diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs index b9e2124196..75395e8a4f 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs @@ -11,12 +11,14 @@ import Development.IDE (Uri) import Development.IDE.GHC.Compat (RealSrcSpan) import GHC.Generics (Generic) import Ide.Types (CommandId) +import Language.LSP.Types (TextDocumentVersion) -- | Parameter for the addMethods PluginCommand. data ExpandSpliceParams = ExpandSpliceParams { uri :: Uri , spliceSpan :: RealSrcSpan , spliceContext :: SpliceContext + , textVersion :: TextDocumentVersion } deriving (Show, Eq, Generic) deriving anyclass (ToJSON, FromJSON) From d38f515807d7e70194a4d98eb6fa8de2cca573ea Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 18:27:51 +0800 Subject: [PATCH 3/5] Remove the empty line --- plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index 8eddce1df7..e7caa99a90 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} From 4ce636b3b6503e044bfd3241454f63acbada872c Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 21:12:57 +0800 Subject: [PATCH 4/5] modify for hls-tactics-plugin --- .../old/src/Wingman/AbstractLSP.hs | 14 ++++++++++---- .../old/src/Wingman/AbstractLSP/Types.hs | 1 + .../old/src/Wingman/EmptyCase.hs | 2 +- .../old/src/Wingman/LanguageServer.hs | 5 +++-- 4 files changed, 15 insertions(+), 7 deletions(-) diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index 000e2f3740..430f49d196 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -23,14 +23,16 @@ import Development.IDE.Core.UseStale import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnnotatedParsedSource)) import qualified Ide.Plugin.Config as Plugin import Ide.Types -import Language.LSP.Server (LspM, sendRequest, getClientCapabilities) +import Language.LSP.Server (LspM, sendRequest, getClientCapabilities, getVersionedTextDoc) import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as J import Language.LSP.Types hiding (CodeLens, CodeAction) import Wingman.AbstractLSP.Types import Wingman.EmptyCase (fromMaybeT) import Wingman.LanguageServer (runIde, getTacticConfigAction, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams) import Wingman.StaticPlugin (enableQuasiQuotes) import Wingman.Types +import Control.Lens ((^.)) ------------------------------------------------------------------------------ @@ -111,7 +113,7 @@ runContinuation plId cont state (fc, b) = do GraftEdit gr -> do ccs <- lift getClientCapabilities TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource - case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of + case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (textVersion fc) (unTrack pm) gr of Left errs -> pure $ Just $ ResponseError { _code = InternalError @@ -176,11 +178,13 @@ codeActionProvider ) -> PluginMethodHandler IdeState TextDocumentCodeAction codeActionProvider sort k state plId - (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do + (CodeActionParams _ _ docId@(TextDocumentIdentifier uri) range _) = do + version <- (^. J.version) <$> getVersionedTextDoc docId fromMaybeT (Right $ List []) $ do let fc = FileContext { fc_uri = uri , fc_range = Just $ unsafeMkCurrent range + , textVersion = version } env <- buildEnv state plId fc args <- fetchTargetArgs @target env @@ -203,11 +207,13 @@ codeLensProvider ) -> PluginMethodHandler IdeState TextDocumentCodeLens codeLensProvider sort k state plId - (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do + (CodeLensParams _ _ docId@(TextDocumentIdentifier uri)) = do + version <- (^. J.version) <$> getVersionedTextDoc docId fromMaybeT (Right $ List []) $ do let fc = FileContext { fc_uri = uri , fc_range = Nothing + , textVersion = version } env <- buildEnv state plId fc args <- fetchTargetArgs @target env diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs index 750bdfaa2d..9301a0a17b 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs @@ -124,6 +124,7 @@ data FileContext = FileContext , fc_range :: Maybe (Tracked 'Current Range) -- ^ For code actions, this is 'Just'. For code lenses, you'll get -- a 'Nothing' in the request, and a 'Just' in the response. + , textVersion :: TextDocumentVersion } deriving stock (Eq, Ord, Show, Generic) deriving anyclass (A.ToJSON, A.FromJSON) diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs index a13d7c1a65..b65577ce4f 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs @@ -69,7 +69,7 @@ emptyCaseInteraction = Interaction $ (foldMap (hySingleton . occName . fst) bindings) ty edits <- liftMaybe $ hush $ - mkWorkspaceEdits le_dflags ccs fc_uri (unTrack pm) $ + mkWorkspaceEdits le_dflags ccs fc_uri textVersion (unTrack pm) $ graftMatchGroup (RealSrcSpan (unTrack ss) Nothing) $ noLoc matches pure diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs index ad6d1b3ca1..7ff17a2241 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs @@ -622,12 +622,13 @@ mkWorkspaceEdits :: DynFlags -> ClientCapabilities -> Uri + -> TextDocumentVersion -> Annotated ParsedSource -> Graft (Either String) ParsedSource -> Either UserFacingMessage WorkspaceEdit -mkWorkspaceEdits dflags ccs uri pm g = do +mkWorkspaceEdits dflags ccs uri version pm g = do let pm' = runIdentity $ transformA pm annotateMetaprograms - let response = transform dflags ccs uri g pm' + let response = transform dflags ccs uri version g pm' in first (InfrastructureError . T.pack) response From 75f9d120003e5a9b23971fb45532124a9a40c3ca Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 21:14:35 +0800 Subject: [PATCH 5/5] name test --- plugins/hls-class-plugin/test/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index c8215dbbf3..586b117cb9 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -76,7 +76,7 @@ codeActionTests = testGroup [ "Add placeholders for 'f','g'" , "Add placeholders for 'f','g' with signature(s)" ] - , testCase "" $ runSessionWithServer classPlugin testDataDir $ do + , testCase "Update text document version" $ runSessionWithServer classPlugin testDataDir $ do doc <- createDoc "Version.hs" "haskell" "module Version where" ver1 <- (^.J.version) <$> getVersionedDoc doc liftIO $ ver1 @?= Just 0