Fix for #374

lsp-test/src/Language/LSP/Test/Decoding.hs

@@ -82,7 +82,7 @@ decodeFromServerMsg reqMap bytes = unP $ parse p obj
               Just m -> Just $ (m, Pair m (Const newMap))
         unP (Success (FromServerMess m msg)) = (reqMap, FromServerMess m msg)
         unP (Success (FromServerRsp (Pair m (Const newMap)) msg)) = (newMap, FromServerRsp m msg)
-        unP (Error e) = error e
+        unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e
         {-
         WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
         WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"

lsp-test/src/Language/LSP/Test/Session.hs

@@ -354,7 +354,10 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do
   allChangeParams <- case r ^. params . edit . documentChanges of
     Just (List cs) -> do
       mapM_ (checkIfNeedsOpened . documentChangeUri) cs
-      return $ mapMaybe getParamsFromDocumentChange cs
+      -- replace the user provided version numbers with the VFS ones + 1
+      -- (technically we should check that the user versions match the VFS ones)
+      cs' <- traverseOf (traverse . _InL . textDocument) bumpNewestVersion cs
+      return $ mapMaybe getParamsFromDocumentChange cs'
     -- Then fall back to the changes field
     Nothing -> case r ^. params . edit . changes of
       Just cs -> do
@@ -376,12 +379,11 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do
   -- Update VFS to new document versions
   let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
       latestVersions = map ((^. textDocument) . last) sortedVersions
-      bumpedVersions = map (version . _Just +~ 1) latestVersions
 
-  forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
+  forM_ latestVersions $ \(VersionedTextDocumentIdentifier uri v) ->
     modify $ \s ->
       let oldVFS = vfs s
-          update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t
+          update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver +1) t
           newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS
       in s { vfs = newVFS }
 
@@ -401,7 +403,7 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do
               return $ s { vfs = newVFS }
 
         getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams
-        getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) =
+        getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
           DidChangeTextDocumentParams docId (List $ map editToChangeEvent edits)
 
         editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent
@@ -412,6 +414,8 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do
         getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit
         getParamsFromDocumentChange _ = Nothing
 
+        bumpNewestVersion (VersionedTextDocumentIdentifier uri _) =
+          head <$> textDocumentVersions uri
 
         -- For a uri returns an infinite list of versions [n,n+1,n+2,...]
         -- where n is the current version
@@ -425,7 +429,7 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do
           vers <- textDocumentVersions uri
           pure $ map (\(v, e) -> TextDocumentEdit v (List [InL e])) $ zip vers edits
 
-        getChangeParams uri (List edits) = do 
+        getChangeParams uri (List edits) = do
           map <$> pure getParamsFromTextDocumentEdit <*> textDocumentEdits uri (reverse edits)
 
         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams

lsp-test/test/DummyServer.hs

@@ -139,15 +139,36 @@ handlers =
                 do
                   Just token <- runInIO $ asks absRegToken >>= tryReadMVar
                   runInIO $ unregisterCapability token
+
+      -- this handler is used by the
+      -- "text document VFS / sends back didChange notifications (documentChanges)" test
+    , notificationHandler STextDocumentDidChange $ \noti -> do
+        let NotificationMessage _ _ params = noti
+        void $ sendNotification (SCustomMethod "custom/textDocument/didChange") (toJSON params)
+
      , requestHandler SWorkspaceExecuteCommand $ \req resp -> do
-        let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req
+       case req of
+        RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) -> do
+          let
             Success docUri = fromJSON val
             edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]
             params =
               ApplyWorkspaceEditParams (Just "Howdy edit") $
                 WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing Nothing
-        resp $ Right Null
-        void $ sendRequest SWorkspaceApplyEdit params (const (pure ()))
+          resp $ Right Null
+          void $ sendRequest SWorkspaceApplyEdit params (const (pure ()))
+        RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just (List [val]))) -> do
+          let
+            Success versionedDocUri = fromJSON val
+            edit = List [InL (TextEdit (mkRange 0 0 0 5) "howdy")]
+            documentEdit = TextDocumentEdit versionedDocUri edit
+            params =
+              ApplyWorkspaceEditParams (Just "Howdy edit") $
+                WorkspaceEdit Nothing (Just (List [InL documentEdit])) Nothing
+          resp $ Right Null
+          void $ sendRequest SWorkspaceApplyEdit params (const (pure ()))
+        RequestMessage _ _ _ (ExecuteCommandParams _ name _) ->
+          error $ "unsupported command: " <> show name
      , requestHandler STextDocumentCodeAction $ \req resp -> do
         let RequestMessage _ _ _ params = req
             CodeActionParams _ _ _ _ cactx = params

lsp-test/test/Test.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveAnyClass #-}
 
@@ -132,7 +133,37 @@ main = hspec $ around withDummyServer $ do
             in runSessionWithHandles hin hout def fullCaps "." sesh
               `shouldThrow` selector
 
-  describe "text document VFS" $
+  describe "text document VFS" $ do
+    it "sends back didChange notifications (documentChanges)" $ \(hin, hout) ->
+      runSessionWithHandles hin hout def fullCaps "." $ do
+        doc <- openDoc "test/data/refactor/Main.hs" "haskell"
+        VersionedTextDocumentIdentifier _ beforeVersion <- getVersionedDoc doc
+
+        let args = toJSON (VersionedTextDocumentIdentifier (doc ^. uri) beforeVersion)
+            reqParams = ExecuteCommandParams Nothing "doAVersionedEdit" (Just (List [args]))
+
+        request_ SWorkspaceExecuteCommand reqParams
+
+        editReq <- message SWorkspaceApplyEdit
+        liftIO $ do
+          let Just (List [InL(TextDocumentEdit vdoc (List [InL edit_]))]) =
+                editReq ^. params . edit . documentChanges
+          vdoc `shouldBe` VersionedTextDocumentIdentifier  (doc ^. uri) beforeVersion
+          edit_ `shouldBe` TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"
+
+        change <- customNotification "custom/textDocument/didChange"
+        let NotMess (NotificationMessage _ _ (c::Value)) = change
+            Success (DidChangeTextDocumentParams reportedVDoc _edit) = fromJSON c
+            VersionedTextDocumentIdentifier _ reportedVersion = reportedVDoc
+
+        contents <- documentContents doc
+
+        liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
+        VersionedTextDocumentIdentifier _ afterVersion <- getVersionedDoc doc
+        liftIO $ afterVersion `shouldNotBe` beforeVersion
+
+        liftIO $ reportedVersion `shouldNotBe` beforeVersion
+
     it "sends back didChange notifications" $ \(hin, hout) ->
       runSessionWithHandles hin hout def fullCaps "." $ do
         doc <- openDoc "test/data/refactor/Main.hs" "haskell"

lsp-types/src/Language/LSP/Types/Lens.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE TypeInType             #-}
+{-# LANGUAGE ExplicitNamespaces #-}
 
 module Language.LSP.Types.Lens where
 
@@ -19,6 +20,7 @@ import           Language.LSP.Types.CodeAction
 import           Language.LSP.Types.CodeLens
 import           Language.LSP.Types.DocumentColor
 import           Language.LSP.Types.Command
+import           Language.LSP.Types.Common (type (|?))
 import           Language.LSP.Types.Completion
 import           Language.LSP.Types.Configuration
 import           Language.LSP.Types.Declaration
@@ -391,3 +393,6 @@ makeFieldsNoPrefix ''SemanticTokensEdit
 makeFieldsNoPrefix ''SemanticTokensDelta
 makeFieldsNoPrefix ''SemanticTokensDeltaPartialResult
 makeFieldsNoPrefix ''SemanticTokensWorkspaceClientCapabilities
+
+-- Unions
+makePrisms ''(|?)