From cc92dd0d20fb9c405494e6470cd419b82707f43b Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Wed, 9 Dec 2020 16:08:11 +0800 Subject: [PATCH 01/12] Datatypes for File Resource Changes --- lsp-types/src/Language/LSP/Types/Lens.hs | 7 ++ .../src/Language/LSP/Types/WorkspaceEdit.hs | 92 +++++++++++++++++++ 2 files changed, 99 insertions(+) diff --git a/lsp-types/src/Language/LSP/Types/Lens.hs b/lsp-types/src/Language/LSP/Types/Lens.hs index 9eb16596f..d578f2288 100644 --- a/lsp-types/src/Language/LSP/Types/Lens.hs +++ b/lsp-types/src/Language/LSP/Types/Lens.hs @@ -257,6 +257,13 @@ makeFieldsNoPrefix ''DocumentFilter makeFieldsNoPrefix ''TextEdit makeFieldsNoPrefix ''VersionedTextDocumentIdentifier makeFieldsNoPrefix ''TextDocumentEdit +makeFieldsNoPrefix ''FileResourceChangeKind +makeFieldsNoPrefix ''CreateFileOptions +makeFieldsNoPrefix ''CreateFile +makeFieldsNoPrefix ''RenameFileOptions +makeFieldsNoPrefix ''RenameFile +makeFieldsNoPrefix ''DeleteFileOptions +makeFieldsNoPrefix ''DeleteFile makeFieldsNoPrefix ''WorkspaceEdit -- Workspace Folders diff --git a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs index 4ebda0efb..e52583a86 100644 --- a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs +++ b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs @@ -38,6 +38,98 @@ deriveJSON lspOptions ''TextDocumentEdit -- --------------------------------------------------------------------- +-- | For tagging `CreateFile`/`RenameFile`/`DeleteFile` +-- Should this be merged with `ResourceOperationKind` ? +data FileResourceChangeKind + = FileResourceChangeCreate + | FileResourceChangeRename + | FileResourceChangeDelete + deriving (Read, Show, Eq) + +instance ToJSON FileResourceChangeKind where + toJSON FileResourceChangeCreate = String "create" + toJSON FileResourceChangeRename = String "rename" + toJSON FileResourceChangeDelete = String "delete" + +instance FromJSON FileResourceChangeKind where + parseJSON (String "create") = pure FileResourceChangeCreate + parseJSON (String "rename") = pure FileResourceChangeRename + parseJSON (String "delete") = pure FileResourceChangeDelete + parseJSON _ = mempty + +-- | Options to create a file. +data CreateFileOptions = + CreateFileOptions + { -- | Overwrite existing file. Overwrite wins over `ignoreIfExists` + _overwrite :: Bool + -- | Ignore if exists. + , _ignoreIfExists :: Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''CreateFileOptions + +-- | Create file operation +data CreateFile = + CreateFile + { _kind :: FileResourceChangeKind + -- | The resource to create. + , _uri :: Text + -- | Additional options + , _options :: Maybe CreateFileOptions + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''CreateFile + +-- Rename file options +data RenameFileOptions = + RenameFileOptions + { -- | Overwrite target if existing. Overwrite wins over `ignoreIfExists` + _overwrite :: Bool + -- | Ignores if target exists. + , _ignoreIfExists :: Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''RenameFileOptions + +-- | Rename file operation +data RenameFile = + RenameFile + { _kind :: FileResourceChangeKind + -- | The old (existing) location. + , _oldUri :: Text + -- | The new location. + , _newUri :: Text + -- | Rename options. + , _options :: Maybe RenameFileOptions + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''RenameFile + +-- Delete file options +data DeleteFileOptions = + DeleteFileOptions + { -- | Delete the content recursively if a folder is denoted. + _recursive :: Bool + -- | Ignore the operation if the file doesn't exist. + , _ignoreIfNotExists :: Bool + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''DeleteFileOptions + +-- | Delete file operation +data DeleteFile = + DeleteFile + { _kind :: FileResourceChangeKind + -- | The file to delete. + , _uri :: Text + -- | Delete options. + , _options :: Maybe DeleteFileOptions + } deriving (Show, Read, Eq) + +deriveJSON lspOptions ''DeleteFile + +-- --------------------------------------------------------------------- + type WorkspaceEditMap = H.HashMap Uri (List TextEdit) data WorkspaceEdit = From ea4c8226e9dc40a1a8c79376784361944608c04d Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Wed, 9 Dec 2020 18:04:20 +0800 Subject: [PATCH 02/12] Type synonym for DocumentChange --- lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs index e52583a86..52a405a00 100644 --- a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs +++ b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} + module Language.LSP.Types.WorkspaceEdit where import Data.Aeson @@ -130,6 +132,11 @@ deriveJSON lspOptions ''DeleteFile -- --------------------------------------------------------------------- +-- | `TextDocumentEdit |? CreateFile |? RenameFile |? DeleteFile` is a bit mouthful, here's the synonym +type DocumentChange = TextDocumentEdit |? CreateFile |? RenameFile |? DeleteFile + +-- --------------------------------------------------------------------- + type WorkspaceEditMap = H.HashMap Uri (List TextEdit) data WorkspaceEdit = From be1dc3ce05c33827f553aad705410e1a4784fa47 Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Wed, 9 Dec 2020 18:04:47 +0800 Subject: [PATCH 03/12] Applying CreateFile on the VFS --- lsp-types/src/Language/LSP/VFS.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/lsp-types/src/Language/LSP/VFS.hs b/lsp-types/src/Language/LSP/VFS.hs index 95f294bb1..39e8dd5b9 100644 --- a/lsp-types/src/Language/LSP/VFS.hs +++ b/lsp-types/src/Language/LSP/VFS.hs @@ -129,6 +129,19 @@ updateVFS f vfs@VFS{vfsMap} = vfs { vfsMap = f vfsMap } -- --------------------------------------------------------------------- +applyCreateFile :: J.CreateFile -> VFS -> VFS +applyCreateFile (J.CreateFile _ uri options) = + updateVFS $ Map.insertWith + (\ new old -> if shouldOverwrite then new else old) + (J.toNormalizedUri (J.Uri uri)) + (VirtualFile 0 0 (Rope.fromText "")) + where + shouldOverwrite :: Bool + shouldOverwrite = case options of + Just (J.CreateFileOptions False False) -> True -- `ignoreIfExists` is False + Just (J.CreateFileOptions True _ ) -> True -- `overwrite` is True + _ -> False -- otherwise don't overwrite + -- ^ Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS' changeFromServerVFS :: VFS -> J.Message 'J.WorkspaceApplyEdit -> IO VFS changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do From 583ad60a439ed88664b5bfe4e367a088e9d3b836 Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Wed, 9 Dec 2020 18:38:44 +0800 Subject: [PATCH 04/12] Applying RenameFile on the VFS --- lsp-types/src/Language/LSP/VFS.hs | 29 +++++++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/lsp-types/src/Language/LSP/VFS.hs b/lsp-types/src/Language/LSP/VFS.hs index 39e8dd5b9..dfb9cf381 100644 --- a/lsp-types/src/Language/LSP/VFS.hs +++ b/lsp-types/src/Language/LSP/VFS.hs @@ -133,14 +133,35 @@ applyCreateFile :: J.CreateFile -> VFS -> VFS applyCreateFile (J.CreateFile _ uri options) = updateVFS $ Map.insertWith (\ new old -> if shouldOverwrite then new else old) - (J.toNormalizedUri (J.Uri uri)) + (J.toNormalizedUri (J.Uri uri)) (VirtualFile 0 0 (Rope.fromText "")) where shouldOverwrite :: Bool shouldOverwrite = case options of - Just (J.CreateFileOptions False False) -> True -- `ignoreIfExists` is False - Just (J.CreateFileOptions True _ ) -> True -- `overwrite` is True - _ -> False -- otherwise don't overwrite + Just (J.CreateFileOptions True _) -> True -- `overwrite` is True + Just (J.CreateFileOptions False _) -> False -- `overwrite` wins over `ignoreIfExists` + Nothing -> False + +applyRenameFile :: J.RenameFile -> VFS -> VFS +applyRenameFile (J.RenameFile _ oldUri' newUri' options) vfs = + let oldUri = J.toNormalizedUri (J.Uri oldUri') + newUri = J.toNormalizedUri (J.Uri newUri') + in case Map.lookup oldUri (vfsMap vfs) of + -- nothing to rename + Nothing -> vfs + Just file -> case Map.lookup newUri (vfsMap vfs) of + -- the target does not exist, just move over + Nothing -> updateVFS (Map.insert newUri file . Map.delete oldUri) vfs + Just _ -> if shouldOverwrite + then updateVFS (Map.insert newUri file . Map.delete oldUri) vfs + else vfs + where + shouldOverwrite :: Bool + shouldOverwrite = case options of + Just (J.RenameFileOptions True _) -> True -- `overwrite` is True + Just (J.RenameFileOptions False _) -> False -- `overwrite` wins over `ignoreIfExists` + Nothing -> False + -- ^ Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS' changeFromServerVFS :: VFS -> J.Message 'J.WorkspaceApplyEdit -> IO VFS From 63a0f1f3ebcff0eee5e308d311ced164115b2e83 Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Thu, 10 Dec 2020 11:00:23 +0800 Subject: [PATCH 05/12] Applying DeleteFile on the VFS --- lsp-types/src/Language/LSP/VFS.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lsp-types/src/Language/LSP/VFS.hs b/lsp-types/src/Language/LSP/VFS.hs index dfb9cf381..dae81cec1 100644 --- a/lsp-types/src/Language/LSP/VFS.hs +++ b/lsp-types/src/Language/LSP/VFS.hs @@ -162,6 +162,10 @@ applyRenameFile (J.RenameFile _ oldUri' newUri' options) vfs = Just (J.RenameFileOptions False _) -> False -- `overwrite` wins over `ignoreIfExists` Nothing -> False +-- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory +applyDeleteFile :: J.DeleteFile -> VFS -> VFS +applyDeleteFile (J.DeleteFile _ uri _options) = + updateVFS $ Map.delete (J.toNormalizedUri (J.Uri uri)) -- ^ Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS' changeFromServerVFS :: VFS -> J.Message 'J.WorkspaceApplyEdit -> IO VFS From 6ecbda7c3cf4782c2bc9a67bf5bc7e0d455fee92 Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Thu, 10 Dec 2020 11:09:27 +0800 Subject: [PATCH 06/12] Applying DocumentChange on the VFS --- lsp-types/src/Language/LSP/VFS.hs | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/lsp-types/src/Language/LSP/VFS.hs b/lsp-types/src/Language/LSP/VFS.hs index dae81cec1..986002118 100644 --- a/lsp-types/src/Language/LSP/VFS.hs +++ b/lsp-types/src/Language/LSP/VFS.hs @@ -167,6 +167,28 @@ applyDeleteFile :: J.DeleteFile -> VFS -> VFS applyDeleteFile (J.DeleteFile _ uri _options) = updateVFS $ Map.delete (J.toNormalizedUri (J.Uri uri)) + +applyTextDocumentEdit :: J.TextDocumentEdit -> VFS -> IO VFS +applyTextDocumentEdit (J.TextDocumentEdit vid (J.List edits)) vfs = do + -- all edits are supposed to be applied at once + -- so apply from bottom up so they don't affect others + let sortedEdits = sortOn (Down . (^. J.range)) edits + changeEvents = map editToChangeEvent sortedEdits + ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) + notif = J.NotificationMessage "" J.STextDocumentDidChange ps + let (vfs',ls) = changeFromClientVFS vfs notif + mapM_ (debugM "haskell-lsp.applyTextDocumentEdit") ls + return vfs' + + where + editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text + +applyDocumentChange :: J.DocumentChange -> VFS -> IO VFS +applyDocumentChange (J.InL change) = applyTextDocumentEdit change +applyDocumentChange (J.InR (J.InL change)) = return . applyCreateFile change +applyDocumentChange (J.InR (J.InR (J.InL change))) = return . applyRenameFile change +applyDocumentChange (J.InR (J.InR (J.InR change))) = return . applyDeleteFile change + -- ^ Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS' changeFromServerVFS :: VFS -> J.Message 'J.WorkspaceApplyEdit -> IO VFS changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do @@ -202,7 +224,7 @@ changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do return vfs' editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text - + -- --------------------------------------------------------------------- virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath virtualFileName prefix uri (VirtualFile _ file_ver _) = From 12ca1fd72bf394a3e8642e4763829405bf8b563e Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Thu, 10 Dec 2020 11:22:45 +0800 Subject: [PATCH 07/12] WorkspaceEdit._documentChanges now stores DocumentChanges --- .../src/Language/LSP/Types/WorkspaceEdit.hs | 2 +- lsp-types/src/Language/LSP/VFS.hs | 29 ++++++------------- src/Language/LSP/Server/Core.hs | 9 +++--- 3 files changed, 15 insertions(+), 25 deletions(-) diff --git a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs index 52a405a00..08f03fb98 100644 --- a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs +++ b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs @@ -142,7 +142,7 @@ type WorkspaceEditMap = H.HashMap Uri (List TextEdit) data WorkspaceEdit = WorkspaceEdit { _changes :: Maybe WorkspaceEditMap - , _documentChanges :: Maybe (List TextDocumentEdit) + , _documentChanges :: Maybe (List DocumentChange) } deriving (Show, Read, Eq) instance Semigroup WorkspaceEdit where diff --git a/lsp-types/src/Language/LSP/VFS.hs b/lsp-types/src/Language/LSP/VFS.hs index 986002118..e0d46b90d 100644 --- a/lsp-types/src/Language/LSP/VFS.hs +++ b/lsp-types/src/Language/LSP/VFS.hs @@ -195,36 +195,25 @@ changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do let J.ApplyWorkspaceEditParams _label edit = params J.WorkspaceEdit mChanges mDocChanges = edit case mDocChanges of - Just (J.List textDocEdits) -> applyEdits textDocEdits + Just (J.List docChanges) -> applyDocumentChanges docChanges Nothing -> case mChanges of - Just cs -> applyEdits $ HashMap.foldlWithKey' changeToTextDocumentEdit [] cs + Just cs -> applyDocumentChanges $ map J.InL $ HashMap.foldlWithKey' changeToTextDocumentEdit [] cs Nothing -> do debugM "haskell-lsp.changeVfs" "No changes" return initVfs where - changeToTextDocumentEdit acc uri edits = acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) edits] - -- applyEdits :: [J.TextDocumentEdit] -> VFS - applyEdits :: [J.TextDocumentEdit] -> IO VFS - applyEdits = foldM f initVfs . sortOn (^. J.textDocument . J.version) - - f :: VFS -> J.TextDocumentEdit -> IO VFS - f vfs (J.TextDocumentEdit vid (J.List edits)) = do - -- all edits are supposed to be applied at once - -- so apply from bottom up so they don't affect others - let sortedEdits = sortOn (Down . (^. J.range)) edits - changeEvents = map editToChangeEvent sortedEdits - ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) - notif = J.NotificationMessage "" J.STextDocumentDidChange ps - let (vfs',ls) = changeFromClientVFS vfs notif - mapM_ (debugM "haskell-lsp.changeFromServerVFS") ls - return vfs' + applyDocumentChanges :: [J.DocumentChange] -> IO VFS + applyDocumentChanges = foldM (flip applyDocumentChange) initVfs . sortOn project + + -- for sorting [DocumentChange] + project :: J.DocumentChange -> J.TextDocumentVersion -- type TextDocumentVersion = Maybe Int + project (J.InL textDocumentEdit) = textDocumentEdit ^. J.textDocument . J.version + project _ = Nothing - editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text - -- --------------------------------------------------------------------- virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath virtualFileName prefix uri (VirtualFile _ file_ver _) = diff --git a/src/Language/LSP/Server/Core.hs b/src/Language/LSP/Server/Core.hs index 1494feb0a..8f4c30276 100644 --- a/src/Language/LSP/Server/Core.hs +++ b/src/Language/LSP/Server/Core.hs @@ -744,15 +744,16 @@ reverseSortEdit (J.WorkspaceEdit cs dcs) = J.WorkspaceEdit cs' dcs' cs' :: Maybe J.WorkspaceEditMap cs' = (fmap . fmap ) sortTextEdits cs - dcs' :: Maybe (J.List J.TextDocumentEdit) - dcs' = (fmap . fmap ) sortTextDocumentEdits dcs + dcs' :: Maybe (J.List J.DocumentChange) + dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs sortTextEdits :: J.List J.TextEdit -> J.List J.TextEdit sortTextEdits (J.List edits) = J.List (L.sortBy down edits) - sortTextDocumentEdits :: J.TextDocumentEdit -> J.TextDocumentEdit - sortTextDocumentEdits (J.TextDocumentEdit td (J.List edits)) = J.TextDocumentEdit td (J.List edits') + sortOnlyTextDocumentEdits :: J.DocumentChange -> J.DocumentChange + sortOnlyTextDocumentEdits (J.InL (J.TextDocumentEdit td (J.List edits))) = J.InL $ J.TextDocumentEdit td (J.List edits') where edits' = L.sortBy down edits + sortOnlyTextDocumentEdits (J.InR others) = J.InR others down (J.TextEdit r1 _) (J.TextEdit r2 _) = r2 `compare` r1 From a1be3f35e8144032b5d57e5269a322c078a90a92 Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Thu, 10 Dec 2020 14:27:11 +0800 Subject: [PATCH 08/12] Fix Reactor example --- example/Reactor.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/example/Reactor.hs b/example/Reactor.hs index 4421ad17d..54971d096 100644 --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -225,7 +225,7 @@ handle = mconcat let edit = J.TextEdit (J.mkRange l c l (c + T.length newName)) newName tde = J.TextDocumentEdit vdoc (J.List [edit]) -- "documentChanges" field is preferred over "changes" - rsp = J.WorkspaceEdit Nothing (Just (J.List [tde])) + rsp = J.WorkspaceEdit Nothing (Just (J.List [J.InL tde])) responder (Right rsp) , requestHandler J.STextDocumentHover $ \req responder -> do From 5c3d374355f840065437243ea5fc490fefa7f484 Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Fri, 11 Dec 2020 15:50:24 +0800 Subject: [PATCH 09/12] Fix & make fields of file change options optional --- .../src/Language/LSP/Types/WorkspaceEdit.hs | 12 ++++----- lsp-types/src/Language/LSP/VFS.hs | 26 ++++++++++++++----- 2 files changed, 26 insertions(+), 12 deletions(-) diff --git a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs index 08f03fb98..357e99176 100644 --- a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs +++ b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs @@ -63,9 +63,9 @@ instance FromJSON FileResourceChangeKind where data CreateFileOptions = CreateFileOptions { -- | Overwrite existing file. Overwrite wins over `ignoreIfExists` - _overwrite :: Bool + _overwrite :: Maybe Bool -- | Ignore if exists. - , _ignoreIfExists :: Bool + , _ignoreIfExists :: Maybe Bool } deriving (Show, Read, Eq) deriveJSON lspOptions ''CreateFileOptions @@ -86,9 +86,9 @@ deriveJSON lspOptions ''CreateFile data RenameFileOptions = RenameFileOptions { -- | Overwrite target if existing. Overwrite wins over `ignoreIfExists` - _overwrite :: Bool + _overwrite :: Maybe Bool -- | Ignores if target exists. - , _ignoreIfExists :: Bool + , _ignoreIfExists :: Maybe Bool } deriving (Show, Read, Eq) deriveJSON lspOptions ''RenameFileOptions @@ -111,9 +111,9 @@ deriveJSON lspOptions ''RenameFile data DeleteFileOptions = DeleteFileOptions { -- | Delete the content recursively if a folder is denoted. - _recursive :: Bool + _recursive :: Maybe Bool -- | Ignore the operation if the file doesn't exist. - , _ignoreIfNotExists :: Bool + , _ignoreIfNotExists :: Maybe Bool } deriving (Show, Read, Eq) deriveJSON lspOptions ''DeleteFileOptions diff --git a/lsp-types/src/Language/LSP/VFS.hs b/lsp-types/src/Language/LSP/VFS.hs index e0d46b90d..a51b841cd 100644 --- a/lsp-types/src/Language/LSP/VFS.hs +++ b/lsp-types/src/Language/LSP/VFS.hs @@ -138,9 +138,16 @@ applyCreateFile (J.CreateFile _ uri options) = where shouldOverwrite :: Bool shouldOverwrite = case options of - Just (J.CreateFileOptions True _) -> True -- `overwrite` is True - Just (J.CreateFileOptions False _) -> False -- `overwrite` wins over `ignoreIfExists` - Nothing -> False + Nothing -> False -- default + Just (J.CreateFileOptions Nothing Nothing ) -> False -- default + Just (J.CreateFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True + Just (J.CreateFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False + Just (J.CreateFileOptions (Just True) Nothing ) -> True -- `overwrite` is True + Just (J.CreateFileOptions (Just True) (Just True) ) -> True -- `overwrite` wins over `ignoreIfExists` + Just (J.CreateFileOptions (Just True) (Just False)) -> True -- `overwrite` is True + Just (J.CreateFileOptions (Just False) Nothing ) -> False -- `overwrite` is False + Just (J.CreateFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False + Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` applyRenameFile :: J.RenameFile -> VFS -> VFS applyRenameFile (J.RenameFile _ oldUri' newUri' options) vfs = @@ -158,9 +165,16 @@ applyRenameFile (J.RenameFile _ oldUri' newUri' options) vfs = where shouldOverwrite :: Bool shouldOverwrite = case options of - Just (J.RenameFileOptions True _) -> True -- `overwrite` is True - Just (J.RenameFileOptions False _) -> False -- `overwrite` wins over `ignoreIfExists` - Nothing -> False + Nothing -> False -- default + Just (J.RenameFileOptions Nothing Nothing ) -> False -- default + Just (J.RenameFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True + Just (J.RenameFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False + Just (J.RenameFileOptions (Just True) Nothing ) -> True -- `overwrite` is True + Just (J.RenameFileOptions (Just True) (Just True) ) -> True -- `overwrite` wins over `ignoreIfExists` + Just (J.RenameFileOptions (Just True) (Just False)) -> True -- `overwrite` is True + Just (J.RenameFileOptions (Just False) Nothing ) -> False -- `overwrite` is False + Just (J.RenameFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False + Just (J.RenameFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` -- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory applyDeleteFile :: J.DeleteFile -> VFS -> VFS From 99131d60c2a5b95010883271cd7c1a7b5c138670 Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Fri, 11 Dec 2020 16:05:43 +0800 Subject: [PATCH 10/12] Tag kinds in JSON only --- lsp-types/src/Language/LSP/Types/Lens.hs | 1 - .../src/Language/LSP/Types/WorkspaceEdit.hs | 91 ++++++++++++------- lsp-types/src/Language/LSP/VFS.hs | 6 +- 3 files changed, 63 insertions(+), 35 deletions(-) diff --git a/lsp-types/src/Language/LSP/Types/Lens.hs b/lsp-types/src/Language/LSP/Types/Lens.hs index d578f2288..1ff326635 100644 --- a/lsp-types/src/Language/LSP/Types/Lens.hs +++ b/lsp-types/src/Language/LSP/Types/Lens.hs @@ -257,7 +257,6 @@ makeFieldsNoPrefix ''DocumentFilter makeFieldsNoPrefix ''TextEdit makeFieldsNoPrefix ''VersionedTextDocumentIdentifier makeFieldsNoPrefix ''TextDocumentEdit -makeFieldsNoPrefix ''FileResourceChangeKind makeFieldsNoPrefix ''CreateFileOptions makeFieldsNoPrefix ''CreateFile makeFieldsNoPrefix ''RenameFileOptions diff --git a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs index 357e99176..fa3c1fa39 100644 --- a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs +++ b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs @@ -2,12 +2,15 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Language.LSP.Types.WorkspaceEdit where +import Control.Monad (unless) import Data.Aeson import Data.Aeson.TH import qualified Data.HashMap.Strict as H +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T @@ -40,25 +43,6 @@ deriveJSON lspOptions ''TextDocumentEdit -- --------------------------------------------------------------------- --- | For tagging `CreateFile`/`RenameFile`/`DeleteFile` --- Should this be merged with `ResourceOperationKind` ? -data FileResourceChangeKind - = FileResourceChangeCreate - | FileResourceChangeRename - | FileResourceChangeDelete - deriving (Read, Show, Eq) - -instance ToJSON FileResourceChangeKind where - toJSON FileResourceChangeCreate = String "create" - toJSON FileResourceChangeRename = String "rename" - toJSON FileResourceChangeDelete = String "delete" - -instance FromJSON FileResourceChangeKind where - parseJSON (String "create") = pure FileResourceChangeCreate - parseJSON (String "rename") = pure FileResourceChangeRename - parseJSON (String "delete") = pure FileResourceChangeDelete - parseJSON _ = mempty - -- | Options to create a file. data CreateFileOptions = CreateFileOptions @@ -73,14 +57,28 @@ deriveJSON lspOptions ''CreateFileOptions -- | Create file operation data CreateFile = CreateFile - { _kind :: FileResourceChangeKind - -- | The resource to create. - , _uri :: Text + { -- | The resource to create. + _uri :: Text -- | Additional options , _options :: Maybe CreateFileOptions } deriving (Show, Read, Eq) -deriveJSON lspOptions ''CreateFile +instance ToJSON CreateFile where + toJSON CreateFile{..} = + object $ catMaybes + [ Just $ "kind" .= ("create" :: Text) + , Just $ "uri" .= _uri + , ("options" .=) <$> _options + ] + +instance FromJSON CreateFile where + parseJSON = withObject "CreateFile" $ \o -> do + kind <- o .: "kind" + unless (kind == ("create" :: Text)) + $ fail $ "Expected kind \"create\" but got " ++ show kind + _uri <- o .: "uri" + _options <- o .:? "options" + pure CreateFile{..} -- Rename file options data RenameFileOptions = @@ -96,16 +94,32 @@ deriveJSON lspOptions ''RenameFileOptions -- | Rename file operation data RenameFile = RenameFile - { _kind :: FileResourceChangeKind - -- | The old (existing) location. - , _oldUri :: Text + { -- | The old (existing) location. + _oldUri :: Text -- | The new location. , _newUri :: Text -- | Rename options. , _options :: Maybe RenameFileOptions } deriving (Show, Read, Eq) -deriveJSON lspOptions ''RenameFile +instance ToJSON RenameFile where + toJSON RenameFile{..} = + object $ catMaybes + [ Just $ "kind" .= ("rename" :: Text) + , Just $ "oldUri" .= _oldUri + , Just $ "newUri" .= _newUri + , ("options" .=) <$> _options + ] + +instance FromJSON RenameFile where + parseJSON = withObject "RenameFile" $ \o -> do + kind <- o .: "kind" + unless (kind == ("rename" :: Text)) + $ fail $ "Expected kind \"rename\" but got " ++ show kind + _oldUri <- o .: "oldUri" + _newUri <- o .: "newUri" + _options <- o .:? "options" + pure RenameFile{..} -- Delete file options data DeleteFileOptions = @@ -121,14 +135,29 @@ deriveJSON lspOptions ''DeleteFileOptions -- | Delete file operation data DeleteFile = DeleteFile - { _kind :: FileResourceChangeKind - -- | The file to delete. - , _uri :: Text + { -- | The file to delete. + _uri :: Text -- | Delete options. , _options :: Maybe DeleteFileOptions } deriving (Show, Read, Eq) -deriveJSON lspOptions ''DeleteFile +instance ToJSON DeleteFile where + toJSON DeleteFile{..} = + object $ catMaybes + [ Just $ "kind" .= ("delete" :: Text) + , Just $ "uri" .= _uri + , ("options" .=) <$> _options + ] + +instance FromJSON DeleteFile where + parseJSON = withObject "DeleteFile" $ \o -> do + kind <- o .: "kind" + unless (kind == ("delete" :: Text)) + $ fail $ "Expected kind \"delete\" but got " ++ show kind + _uri <- o .: "uri" + _options <- o .:? "options" + pure DeleteFile{..} + -- --------------------------------------------------------------------- diff --git a/lsp-types/src/Language/LSP/VFS.hs b/lsp-types/src/Language/LSP/VFS.hs index a51b841cd..524a26184 100644 --- a/lsp-types/src/Language/LSP/VFS.hs +++ b/lsp-types/src/Language/LSP/VFS.hs @@ -130,7 +130,7 @@ updateVFS f vfs@VFS{vfsMap} = vfs { vfsMap = f vfsMap } -- --------------------------------------------------------------------- applyCreateFile :: J.CreateFile -> VFS -> VFS -applyCreateFile (J.CreateFile _ uri options) = +applyCreateFile (J.CreateFile uri options) = updateVFS $ Map.insertWith (\ new old -> if shouldOverwrite then new else old) (J.toNormalizedUri (J.Uri uri)) @@ -150,7 +150,7 @@ applyCreateFile (J.CreateFile _ uri options) = Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` applyRenameFile :: J.RenameFile -> VFS -> VFS -applyRenameFile (J.RenameFile _ oldUri' newUri' options) vfs = +applyRenameFile (J.RenameFile oldUri' newUri' options) vfs = let oldUri = J.toNormalizedUri (J.Uri oldUri') newUri = J.toNormalizedUri (J.Uri newUri') in case Map.lookup oldUri (vfsMap vfs) of @@ -178,7 +178,7 @@ applyRenameFile (J.RenameFile _ oldUri' newUri' options) vfs = -- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory applyDeleteFile :: J.DeleteFile -> VFS -> VFS -applyDeleteFile (J.DeleteFile _ uri _options) = +applyDeleteFile (J.DeleteFile uri _options) = updateVFS $ Map.delete (J.toNormalizedUri (J.Uri uri)) From 0556d22fc66f24bb526f671666183a86b485837e Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Fri, 11 Dec 2020 17:20:43 +0800 Subject: [PATCH 11/12] Use Uri instead of Text in DocumentChange --- lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs | 8 ++++---- lsp-types/src/Language/LSP/VFS.hs | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs index fa3c1fa39..430e963fa 100644 --- a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs +++ b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs @@ -58,7 +58,7 @@ deriveJSON lspOptions ''CreateFileOptions data CreateFile = CreateFile { -- | The resource to create. - _uri :: Text + _uri :: Uri -- | Additional options , _options :: Maybe CreateFileOptions } deriving (Show, Read, Eq) @@ -95,9 +95,9 @@ deriveJSON lspOptions ''RenameFileOptions data RenameFile = RenameFile { -- | The old (existing) location. - _oldUri :: Text + _oldUri :: Uri -- | The new location. - , _newUri :: Text + , _newUri :: Uri -- | Rename options. , _options :: Maybe RenameFileOptions } deriving (Show, Read, Eq) @@ -136,7 +136,7 @@ deriveJSON lspOptions ''DeleteFileOptions data DeleteFile = DeleteFile { -- | The file to delete. - _uri :: Text + _uri :: Uri -- | Delete options. , _options :: Maybe DeleteFileOptions } deriving (Show, Read, Eq) diff --git a/lsp-types/src/Language/LSP/VFS.hs b/lsp-types/src/Language/LSP/VFS.hs index 524a26184..05f091729 100644 --- a/lsp-types/src/Language/LSP/VFS.hs +++ b/lsp-types/src/Language/LSP/VFS.hs @@ -133,7 +133,7 @@ applyCreateFile :: J.CreateFile -> VFS -> VFS applyCreateFile (J.CreateFile uri options) = updateVFS $ Map.insertWith (\ new old -> if shouldOverwrite then new else old) - (J.toNormalizedUri (J.Uri uri)) + (J.toNormalizedUri uri) (VirtualFile 0 0 (Rope.fromText "")) where shouldOverwrite :: Bool @@ -151,8 +151,8 @@ applyCreateFile (J.CreateFile uri options) = applyRenameFile :: J.RenameFile -> VFS -> VFS applyRenameFile (J.RenameFile oldUri' newUri' options) vfs = - let oldUri = J.toNormalizedUri (J.Uri oldUri') - newUri = J.toNormalizedUri (J.Uri newUri') + let oldUri = J.toNormalizedUri oldUri' + newUri = J.toNormalizedUri newUri' in case Map.lookup oldUri (vfsMap vfs) of -- nothing to rename Nothing -> vfs @@ -179,7 +179,7 @@ applyRenameFile (J.RenameFile oldUri' newUri' options) vfs = -- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory applyDeleteFile :: J.DeleteFile -> VFS -> VFS applyDeleteFile (J.DeleteFile uri _options) = - updateVFS $ Map.delete (J.toNormalizedUri (J.Uri uri)) + updateVFS $ Map.delete (J.toNormalizedUri uri) applyTextDocumentEdit :: J.TextDocumentEdit -> VFS -> IO VFS From 45ab9ba251509b92b2fd7da8e5088db70bec1a21 Mon Sep 17 00:00:00 2001 From: Ting-Gian LUA Date: Sun, 13 Dec 2020 00:44:24 +0800 Subject: [PATCH 12/12] Reference the new lsp-test commit --- cabal.project | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/cabal.project b/cabal.project index b807936b9..48fd092fe 100644 --- a/cabal.project +++ b/cabal.project @@ -8,8 +8,8 @@ package lsp source-repository-package type: git - location: https://github.com/wz1000/lsp-test.git - tag: d1ecbc5e8f324895701293429976a6c2f74d82a2 + location: https://github.com/bubba/lsp-test.git + tag: cd644f52c5c564403b5f3b0a8652e7f4154f8d6a tests: True -test-show-details: direct +test-show-details: direct \ No newline at end of file