Update version while editing to conform lsp spec

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,16 +161,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 -> (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
   where
     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
 
 -- ---------------------------------------------------------------------
 

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

@@ -57,15 +57,15 @@ 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 ())
 
         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

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            (TextDocumentVersion)
 
 typeLensCommandId :: CommandId
 typeLensCommandId = "classplugin.typelens"
@@ -38,6 +38,7 @@ data AddMinimalMethodsParams = AddMinimalMethodsParams
     , methodGroup :: List (T.Text, T.Text)
     -- ^ (name text, signature text)
     , withSig     :: Bool
+    , textVersion :: TextDocumentVersion
     }
     deriving (Show, Eq, Generic, ToJSON, FromJSON)
 

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
+    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,22 +547,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 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))
       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 -> 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

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