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]>

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

@@ -41,6 +41,7 @@ where
 
 
 import           Control.Arrow                   ((&&&))
+import           Control.Lens                    ((^.))
 import           Control.Monad.Extra             (maybeM)
 import           Control.Monad.Trans.Class       (lift)
 import           Control.Monad.Trans.Except      (ExceptT, runExceptT, throwE)
@@ -63,6 +64,7 @@ import           Language.LSP.Types              hiding
                                                   SemanticTokensEdit (_start))
 import qualified Language.LSP.Types              as J
 import           Language.LSP.Types.Capabilities
+import qualified Language.LSP.Types.Lens         as J
 import qualified Text.Megaparsec                 as P
 import qualified Text.Megaparsec.Char            as P
 import qualified Text.Megaparsec.Char.Lexer      as P
@@ -98,7 +100,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 -> (VersionedTextDocumentIdentifier,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit
 diffText clientCaps old new withDeletions =
   let
     supports = clientSupportsDocumentChanges clientCaps
@@ -161,16 +163,16 @@ 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 -> (VersionedTextDocumentIdentifier,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit
+diffText' supports (verTxtDocId,fText) f2Text withDeletions =
   if supports
     then WorkspaceEdit Nothing (Just docChanges) Nothing
     else WorkspaceEdit (Just h) Nothing Nothing
   where
     diff = diffTextEdit fText f2Text withDeletions
-    h = H.singleton f diff
+    h = H.singleton (verTxtDocId ^. J.uri) diff
     docChanges = J.List [InL docEdit]
-    docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) $ fmap InL diff
+    docEdit = J.TextDocumentEdit verTxtDocId $ fmap InL diff
 
 -- ---------------------------------------------------------------------
 

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

@@ -42,7 +42,7 @@ addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsP
 addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do
     caps <- getClientCapabilities
     pluginResponse $ do
-        nfp <- getNormalizedFilePath uri
+        nfp <- getNormalizedFilePath (verTxtDocId ^. J.uri)
         pm <- handleMaybeM "Unable to GetParsedModule"
             $ liftIO
             $ runAction "classplugin.addMethodPlaceholders.GetParsedModule" state
@@ -65,7 +65,7 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do
         pure Null
     where
         toTextDocumentEdit edit =
-            TextDocumentEdit (VersionedTextDocumentIdentifier uri (Just 0)) (List [InL edit])
+            TextDocumentEdit verTxtDocId (List [InL edit])
 
         mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit
         mergeEdit WorkspaceEdit{..} edits = WorkspaceEdit
@@ -76,28 +76,29 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do
             }
 
         workspaceEdit caps old new
-            = diffText caps (uri, old) new IncludeDeletions
+            = diffText caps (verTxtDocId, old) new IncludeDeletions
 
 -- |
 -- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is
 -- sensitive to the format of diagnostic messages from GHC.
 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
+    verTxtDocId <- lift $ getVersionedTextDoc docId
+    nfp <- getNormalizedFilePath (verTxtDocId ^. J.uri)
+    actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags
     pure $ List actions
     where
-        uri = docId ^. J.uri
         List diags = context ^. J.diagnostics
 
         ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags
         methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags
 
         mkActions
             :: NormalizedFilePath
+            -> VersionedTextDocumentIdentifier
             -> Diagnostic
             -> ExceptT String (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction]
-        mkActions docPath diag = do
+        mkActions docPath verTxtDocId diag = do
             (HAR {hieAst = ast}, pmap) <- handleMaybeM "Unable to GetHieAst"
                 . liftIO
                 . runAction "classplugin.findClassIdentifier.GetHieAst" state
@@ -142,7 +143,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe
                         titleWithSig = title <> " with signature(s)"
 
                 mkCmdParams methodGroup withSig =
-                    [toJSON (AddMinimalMethodsParams uri range (List methodGroup) withSig)]
+                    [toJSON (AddMinimalMethodsParams verTxtDocId range (List methodGroup) withSig)]
 
                 mkCodeAction title cmd
                     = InR

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

@@ -4,7 +4,6 @@
 {-# LANGUAGE LambdaCase       #-}
 {-# LANGUAGE TypeFamilies     #-}
 {-# LANGUAGE ViewPatterns     #-}
-{-# LANGUAGE BangPatterns     #-}
 
 module Ide.Plugin.Class.Types where
 
@@ -21,6 +20,7 @@ import           Development.IDE.Graph.Classes
 import           GHC.Generics
 import           Ide.Plugin.Class.Utils
 import           Ide.Types
+import           Language.LSP.Types            (VersionedTextDocumentIdentifier)
 
 typeLensCommandId :: CommandId
 typeLensCommandId = "classplugin.typelens"
@@ -33,7 +33,7 @@ defaultIndent :: Int
 defaultIndent = 2
 
 data AddMinimalMethodsParams = AddMinimalMethodsParams
-    { uri         :: Uri
+    { verTxtDocId :: VersionedTextDocumentIdentifier
     , range       :: Range
     , methodGroup :: List (T.Text, T.Text)
     -- ^ (name text, signature text)

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 "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
+
+    -- 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

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
+    verTxtDocId <- 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 verTxtDocId
                        | otherwise -> []
            | otherwise -> pure []
       if numHintsInDoc > 1 && numHintsInContext > 0 then do
-        pure $ singleHintCodeActions ++ [applyAllAction]
+        pure $ singleHintCodeActions ++ [applyAllAction verTxtDocId]
       else
         pure singleHintCodeActions
   | otherwise
   = pure $ Right $ LSP.List []
 
   where
-    applyAllAction =
-      let args = Just [toJSON (documentId ^. LSP.uri)]
+    applyAllAction verTxtDocId =
+      let args = Just [toJSON verTxtDocId]
           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,25 +455,24 @@ 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 -> VersionedTextDocumentIdentifier -> LSP.Diagnostic -> [LSP.CodeAction]
+diagnosticToCodeActions dynFlags fileContents pluginId verTxtDocId 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
   , let hint = T.replace "refact:" "" code
   , let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module"
   , let suppressHintTextEdits = mkSuppressHintTextEdits dynFlags fileContents hint
   , let suppressHintWorkspaceEdit =
           LSP.WorkspaceEdit
-            (Just (Map.singleton uri (List suppressHintTextEdits)))
+            (Just (Map.singleton (verTxtDocId ^. LSP.uri) (List suppressHintTextEdits)))
             Nothing
             Nothing
   = catMaybes
       -- Applying the hint is marked preferred because it addresses the underlying error.
       -- 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 verTxtDocId start hint)]
                  applyHintCommand = mkLspCommand pluginId "applyOne" applyHintTitle (Just applyHintArguments) ->
                Just (mkCodeAction applyHintTitle diagnostic Nothing (Just applyHintCommand) True)
            | otherwise -> Nothing
@@ -511,13 +514,13 @@ mkSuppressHintTextEdits dynFlags fileContents hint =
     combinedTextEdit : lineSplitTextEditList
 -- ---------------------------------------------------------------------
 
-applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
-applyAllCmd recorder ide uri = do
-  let file = maybe (error $ show uri ++ " is not a file.")
+applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState VersionedTextDocumentIdentifier
+applyAllCmd recorder ide verTxtDocId = do
+  let file = maybe (error $ show (verTxtDocId ^. LSP.uri) ++ " is not a file.")
                     toNormalizedFilePath'
-                   (uriToFilePath' uri)
+                   (uriToFilePath' (verTxtDocId ^. LSP.uri))
   withIndefiniteProgress "Applying all hints" Cancellable $ do
-    res <- liftIO $ applyHint recorder ide file Nothing
+    res <- liftIO $ applyHint recorder ide file Nothing verTxtDocId
     logWith recorder Debug $ LogApplying file res
     case res of
       Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err))
@@ -528,10 +531,10 @@ applyAllCmd recorder ide uri = do
 -- ---------------------------------------------------------------------
 
 data ApplyOneParams = AOP
-  { file      :: Uri
-  , start_pos :: Position
+  { verTxtDocId :: VersionedTextDocumentIdentifier
+  , 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
   } deriving (Eq,Show,Generic,FromJSON,ToJSON)
 
 type HintTitle = T.Text
@@ -542,22 +545,22 @@ 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 verTxtDocId pos title) = do
   let oneHint = OneHint pos title
-  let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath'
-                   (uriToFilePath' uri)
+  let file = maybe (error $ show (verTxtDocId ^. LSP.uri)  ++ " is not a file.") toNormalizedFilePath'
+                   (uriToFilePath' (verTxtDocId ^. LSP.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) verTxtDocId
     logWith recorder Debug $ LogApplying file res
     case res of
       Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err))
       Right fs -> 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 -> VersionedTextDocumentIdentifier -> IO (Either String WorkspaceEdit)
+applyHint recorder ide nfp mhint verTxtDocId =
   runExceptT $ do
     let runAction' :: Action a -> IO a
         runAction' = runAction "applyHint" ide
@@ -614,8 +617,7 @@ applyHint recorder ide nfp mhint =
 #endif
     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 (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions
         ExceptT $ return (Right wsEdit)
       Left err ->
         throwE err

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

@@ -210,15 +210,15 @@ instance Monad m => Monoid (Graft m a) where
 transform ::
     DynFlags ->
     ClientCapabilities ->
-    Uri ->
+    VersionedTextDocumentIdentifier ->
     Graft (Either String) ParsedSource ->
     Annotated ParsedSource ->
     Either String WorkspaceEdit
-transform dflags ccs uri f a = do
+transform dflags ccs verTxtDocId 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 (verTxtDocId, T.pack src) (T.pack res) IncludeDeletions
 
 ------------------------------------------------------------------------------
 
@@ -227,16 +227,16 @@ transformM ::
     Monad m =>
     DynFlags ->
     ClientCapabilities ->
-    Uri ->
+    VersionedTextDocumentIdentifier ->
     Graft (ExceptStringT m) ParsedSource ->
     Annotated ParsedSource ->
     m (Either String WorkspaceEdit)
-transformM dflags ccs uri f a = runExceptT $
+transformM dflags ccs verTextDocId 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 (verTextDocId, T.pack src) (T.pack res) IncludeDeletions
 
 
 -- | Returns whether or not this node requires its immediate children to have

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

@@ -35,6 +35,7 @@ library
     , hie-compat
     , hls-plugin-api        == 2.0.0.0
     , hls-refactor-plugin
+    , lens
     , lsp
     , lsp-types
     , mod