Skip to content

Commit 36b655d

Browse files
lukel97lukel97
authored
Merge pull request #267 from banacorn/master
Add support for file and folder operations (create, rename, move) to workspace edits
2 parents 8d6e8f3 + 45ab9ba commit 36b655d

File tree

6 files changed

+227
-29
lines changed

6 files changed

+227
-29
lines changed

‎cabal.project

+3-3
Original file line numberDiff line numberDiff line change
@@ -8,8 +8,8 @@ package lsp
88

99
source-repository-package
1010
type: git
11-
location: https://github.com/wz1000/lsp-test.git
12-
tag: d1ecbc5e8f324895701293429976a6c2f74d82a2
11+
location: https://github.com/bubba/lsp-test.git
12+
tag: cd644f52c5c564403b5f3b0a8652e7f4154f8d6a
1313

1414
tests: True
15-
test-show-details: direct
15+
test-show-details: direct

‎example/Reactor.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -225,7 +225,7 @@ handle = mconcat
225225
let edit = J.TextEdit (J.mkRange l c l (c + T.length newName)) newName
226226
tde = J.TextDocumentEdit vdoc (J.List [edit])
227227
-- "documentChanges" field is preferred over "changes"
228-
rsp = J.WorkspaceEdit Nothing (Just (J.List [tde]))
228+
rsp = J.WorkspaceEdit Nothing (Just (J.List [J.InL tde]))
229229
responder (Right rsp)
230230

231231
, requestHandler J.STextDocumentHover $ \req responder -> do

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

+6
Original file line numberDiff line numberDiff line change
@@ -257,6 +257,12 @@ makeFieldsNoPrefix ''DocumentFilter
257257
makeFieldsNoPrefix ''TextEdit
258258
makeFieldsNoPrefix ''VersionedTextDocumentIdentifier
259259
makeFieldsNoPrefix ''TextDocumentEdit
260+
makeFieldsNoPrefix ''CreateFileOptions
261+
makeFieldsNoPrefix ''CreateFile
262+
makeFieldsNoPrefix ''RenameFileOptions
263+
makeFieldsNoPrefix ''RenameFile
264+
makeFieldsNoPrefix ''DeleteFileOptions
265+
makeFieldsNoPrefix ''DeleteFile
260266
makeFieldsNoPrefix ''WorkspaceEdit
261267

262268
-- Workspace Folders

‎lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs

+129-1
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,16 @@
11
{-# LANGUAGE DuplicateRecordFields #-}
22
{-# LANGUAGE TemplateHaskell #-}
3+
{-# LANGUAGE TypeOperators #-}
34
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE RecordWildCards #-}
6+
47
module Language.LSP.Types.WorkspaceEdit where
58

9+
import Control.Monad (unless)
610
import Data.Aeson
711
import Data.Aeson.TH
812
import qualified Data.HashMap.Strict as H
13+
import Data.Maybe (catMaybes)
914
import Data.Text (Text)
1015
import qualified Data.Text as T
1116

@@ -38,12 +43,135 @@ deriveJSON lspOptions ''TextDocumentEdit
3843

3944
-- ---------------------------------------------------------------------
4045

46+
-- | Options to create a file.
47+
data CreateFileOptions =
48+
CreateFileOptions
49+
{ -- | Overwrite existing file. Overwrite wins over `ignoreIfExists`
50+
_overwrite :: Maybe Bool
51+
-- | Ignore if exists.
52+
, _ignoreIfExists :: Maybe Bool
53+
} deriving (Show, Read, Eq)
54+
55+
deriveJSON lspOptions ''CreateFileOptions
56+
57+
-- | Create file operation
58+
data CreateFile =
59+
CreateFile
60+
{ -- | The resource to create.
61+
_uri :: Uri
62+
-- | Additional options
63+
, _options :: Maybe CreateFileOptions
64+
} deriving (Show, Read, Eq)
65+
66+
instance ToJSON CreateFile where
67+
toJSON CreateFile{..} =
68+
object $ catMaybes
69+
[ Just $ "kind" .= ("create" :: Text)
70+
, Just $ "uri" .= _uri
71+
, ("options" .=) <$> _options
72+
]
73+
74+
instance FromJSON CreateFile where
75+
parseJSON = withObject "CreateFile" $ \o -> do
76+
kind <- o .: "kind"
77+
unless (kind == ("create" :: Text))
78+
$ fail $ "Expected kind \"create\" but got " ++ show kind
79+
_uri <- o .: "uri"
80+
_options <- o .:? "options"
81+
pure CreateFile{..}
82+
83+
-- Rename file options
84+
data RenameFileOptions =
85+
RenameFileOptions
86+
{ -- | Overwrite target if existing. Overwrite wins over `ignoreIfExists`
87+
_overwrite :: Maybe Bool
88+
-- | Ignores if target exists.
89+
, _ignoreIfExists :: Maybe Bool
90+
} deriving (Show, Read, Eq)
91+
92+
deriveJSON lspOptions ''RenameFileOptions
93+
94+
-- | Rename file operation
95+
data RenameFile =
96+
RenameFile
97+
{ -- | The old (existing) location.
98+
_oldUri :: Uri
99+
-- | The new location.
100+
, _newUri :: Uri
101+
-- | Rename options.
102+
, _options :: Maybe RenameFileOptions
103+
} deriving (Show, Read, Eq)
104+
105+
instance ToJSON RenameFile where
106+
toJSON RenameFile{..} =
107+
object $ catMaybes
108+
[ Just $ "kind" .= ("rename" :: Text)
109+
, Just $ "oldUri" .= _oldUri
110+
, Just $ "newUri" .= _newUri
111+
, ("options" .=) <$> _options
112+
]
113+
114+
instance FromJSON RenameFile where
115+
parseJSON = withObject "RenameFile" $ \o -> do
116+
kind <- o .: "kind"
117+
unless (kind == ("rename" :: Text))
118+
$ fail $ "Expected kind \"rename\" but got " ++ show kind
119+
_oldUri <- o .: "oldUri"
120+
_newUri <- o .: "newUri"
121+
_options <- o .:? "options"
122+
pure RenameFile{..}
123+
124+
-- Delete file options
125+
data DeleteFileOptions =
126+
DeleteFileOptions
127+
{ -- | Delete the content recursively if a folder is denoted.
128+
_recursive :: Maybe Bool
129+
-- | Ignore the operation if the file doesn't exist.
130+
, _ignoreIfNotExists :: Maybe Bool
131+
} deriving (Show, Read, Eq)
132+
133+
deriveJSON lspOptions ''DeleteFileOptions
134+
135+
-- | Delete file operation
136+
data DeleteFile =
137+
DeleteFile
138+
{ -- | The file to delete.
139+
_uri :: Uri
140+
-- | Delete options.
141+
, _options :: Maybe DeleteFileOptions
142+
} deriving (Show, Read, Eq)
143+
144+
instance ToJSON DeleteFile where
145+
toJSON DeleteFile{..} =
146+
object $ catMaybes
147+
[ Just $ "kind" .= ("delete" :: Text)
148+
, Just $ "uri" .= _uri
149+
, ("options" .=) <$> _options
150+
]
151+
152+
instance FromJSON DeleteFile where
153+
parseJSON = withObject "DeleteFile" $ \o -> do
154+
kind <- o .: "kind"
155+
unless (kind == ("delete" :: Text))
156+
$ fail $ "Expected kind \"delete\" but got " ++ show kind
157+
_uri <- o .: "uri"
158+
_options <- o .:? "options"
159+
pure DeleteFile{..}
160+
161+
162+
-- ---------------------------------------------------------------------
163+
164+
-- | `TextDocumentEdit |? CreateFile |? RenameFile |? DeleteFile` is a bit mouthful, here's the synonym
165+
type DocumentChange = TextDocumentEdit |? CreateFile |? RenameFile |? DeleteFile
166+
167+
-- ---------------------------------------------------------------------
168+
41169
type WorkspaceEditMap = H.HashMap Uri (List TextEdit)
42170

43171
data WorkspaceEdit =
44172
WorkspaceEdit
45173
{ _changes :: Maybe WorkspaceEditMap
46-
, _documentChanges :: Maybe (List TextDocumentEdit)
174+
, _documentChanges :: Maybe (List DocumentChange)
47175
} deriving (Show, Read, Eq)
48176

49177
instance Semigroup WorkspaceEdit where

‎lsp-types/src/Language/LSP/VFS.hs

+83-20
Original file line numberDiff line numberDiff line change
@@ -129,41 +129,104 @@ updateVFS f vfs@VFS{vfsMap} = vfs { vfsMap = f vfsMap }
129129

130130
-- ---------------------------------------------------------------------
131131

132+
applyCreateFile :: J.CreateFile -> VFS -> VFS
133+
applyCreateFile (J.CreateFile uri options) =
134+
updateVFS $ Map.insertWith
135+
(\ new old -> if shouldOverwrite then new else old)
136+
(J.toNormalizedUri uri)
137+
(VirtualFile 0 0 (Rope.fromText ""))
138+
where
139+
shouldOverwrite :: Bool
140+
shouldOverwrite = case options of
141+
Nothing -> False -- default
142+
Just (J.CreateFileOptions Nothing Nothing ) -> False -- default
143+
Just (J.CreateFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True
144+
Just (J.CreateFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False
145+
Just (J.CreateFileOptions (Just True) Nothing ) -> True -- `overwrite` is True
146+
Just (J.CreateFileOptions (Just True) (Just True) ) -> True -- `overwrite` wins over `ignoreIfExists`
147+
Just (J.CreateFileOptions (Just True) (Just False)) -> True -- `overwrite` is True
148+
Just (J.CreateFileOptions (Just False) Nothing ) -> False -- `overwrite` is False
149+
Just (J.CreateFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False
150+
Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists`
151+
152+
applyRenameFile :: J.RenameFile -> VFS -> VFS
153+
applyRenameFile (J.RenameFile oldUri' newUri' options) vfs =
154+
let oldUri = J.toNormalizedUri oldUri'
155+
newUri = J.toNormalizedUri newUri'
156+
in case Map.lookup oldUri (vfsMap vfs) of
157+
-- nothing to rename
158+
Nothing -> vfs
159+
Just file -> case Map.lookup newUri (vfsMap vfs) of
160+
-- the target does not exist, just move over
161+
Nothing -> updateVFS (Map.insert newUri file . Map.delete oldUri) vfs
162+
Just _ -> if shouldOverwrite
163+
then updateVFS (Map.insert newUri file . Map.delete oldUri) vfs
164+
else vfs
165+
where
166+
shouldOverwrite :: Bool
167+
shouldOverwrite = case options of
168+
Nothing -> False -- default
169+
Just (J.RenameFileOptions Nothing Nothing ) -> False -- default
170+
Just (J.RenameFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True
171+
Just (J.RenameFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False
172+
Just (J.RenameFileOptions (Just True) Nothing ) -> True -- `overwrite` is True
173+
Just (J.RenameFileOptions (Just True) (Just True) ) -> True -- `overwrite` wins over `ignoreIfExists`
174+
Just (J.RenameFileOptions (Just True) (Just False)) -> True -- `overwrite` is True
175+
Just (J.RenameFileOptions (Just False) Nothing ) -> False -- `overwrite` is False
176+
Just (J.RenameFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False
177+
Just (J.RenameFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists`
178+
179+
-- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory
180+
applyDeleteFile :: J.DeleteFile -> VFS -> VFS
181+
applyDeleteFile (J.DeleteFile uri _options) =
182+
updateVFS $ Map.delete (J.toNormalizedUri uri)
183+
184+
185+
applyTextDocumentEdit :: J.TextDocumentEdit -> VFS -> IO VFS
186+
applyTextDocumentEdit (J.TextDocumentEdit vid (J.List edits)) vfs = do
187+
-- all edits are supposed to be applied at once
188+
-- so apply from bottom up so they don't affect others
189+
let sortedEdits = sortOn (Down . (^. J.range)) edits
190+
changeEvents = map editToChangeEvent sortedEdits
191+
ps = J.DidChangeTextDocumentParams vid (J.List changeEvents)
192+
notif = J.NotificationMessage "" J.STextDocumentDidChange ps
193+
let (vfs',ls) = changeFromClientVFS vfs notif
194+
mapM_ (debugM "haskell-lsp.applyTextDocumentEdit") ls
195+
return vfs'
196+
197+
where
198+
editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text
199+
200+
applyDocumentChange :: J.DocumentChange -> VFS -> IO VFS
201+
applyDocumentChange (J.InL change) = applyTextDocumentEdit change
202+
applyDocumentChange (J.InR (J.InL change)) = return . applyCreateFile change
203+
applyDocumentChange (J.InR (J.InR (J.InL change))) = return . applyRenameFile change
204+
applyDocumentChange (J.InR (J.InR (J.InR change))) = return . applyDeleteFile change
205+
132206
-- ^ Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS'
133207
changeFromServerVFS :: VFS -> J.Message 'J.WorkspaceApplyEdit -> IO VFS
134208
changeFromServerVFS initVfs (J.RequestMessage _ _ _ params) = do
135209
let J.ApplyWorkspaceEditParams _label edit = params
136210
J.WorkspaceEdit mChanges mDocChanges = edit
137211
case mDocChanges of
138-
Just (J.List textDocEdits) -> applyEdits textDocEdits
212+
Just (J.List docChanges) -> applyDocumentChanges docChanges
139213
Nothing -> case mChanges of
140-
Just cs -> applyEdits $ HashMap.foldlWithKey' changeToTextDocumentEdit [] cs
214+
Just cs -> applyDocumentChanges $ map J.InL $ HashMap.foldlWithKey' changeToTextDocumentEdit [] cs
141215
Nothing -> do
142216
debugM "haskell-lsp.changeVfs" "No changes"
143217
return initVfs
144218

145219
where
146-
147220
changeToTextDocumentEdit acc uri edits =
148221
acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) edits]
149222

150-
-- applyEdits :: [J.TextDocumentEdit] -> VFS
151-
applyEdits :: [J.TextDocumentEdit] -> IO VFS
152-
applyEdits = foldM f initVfs . sortOn (^. J.textDocument . J.version)
153-
154-
f :: VFS -> J.TextDocumentEdit -> IO VFS
155-
f vfs (J.TextDocumentEdit vid (J.List edits)) = do
156-
-- all edits are supposed to be applied at once
157-
-- so apply from bottom up so they don't affect others
158-
let sortedEdits = sortOn (Down . (^. J.range)) edits
159-
changeEvents = map editToChangeEvent sortedEdits
160-
ps = J.DidChangeTextDocumentParams vid (J.List changeEvents)
161-
notif = J.NotificationMessage "" J.STextDocumentDidChange ps
162-
let (vfs',ls) = changeFromClientVFS vfs notif
163-
mapM_ (debugM "haskell-lsp.changeFromServerVFS") ls
164-
return vfs'
165-
166-
editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text
223+
applyDocumentChanges :: [J.DocumentChange] -> IO VFS
224+
applyDocumentChanges = foldM (flip applyDocumentChange) initVfs . sortOn project
225+
226+
-- for sorting [DocumentChange]
227+
project :: J.DocumentChange -> J.TextDocumentVersion -- type TextDocumentVersion = Maybe Int
228+
project (J.InL textDocumentEdit) = textDocumentEdit ^. J.textDocument . J.version
229+
project _ = Nothing
167230

168231
-- ---------------------------------------------------------------------
169232
virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath

‎src/Language/LSP/Server/Core.hs

+5-4
Original file line numberDiff line numberDiff line change
@@ -744,15 +744,16 @@ reverseSortEdit (J.WorkspaceEdit cs dcs) = J.WorkspaceEdit cs' dcs'
744744
cs' :: Maybe J.WorkspaceEditMap
745745
cs' = (fmap . fmap ) sortTextEdits cs
746746

747-
dcs' :: Maybe (J.List J.TextDocumentEdit)
748-
dcs' = (fmap . fmap ) sortTextDocumentEdits dcs
747+
dcs' :: Maybe (J.List J.DocumentChange)
748+
dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs
749749

750750
sortTextEdits :: J.List J.TextEdit -> J.List J.TextEdit
751751
sortTextEdits (J.List edits) = J.List (L.sortBy down edits)
752752

753-
sortTextDocumentEdits :: J.TextDocumentEdit -> J.TextDocumentEdit
754-
sortTextDocumentEdits (J.TextDocumentEdit td (J.List edits)) = J.TextDocumentEdit td (J.List edits')
753+
sortOnlyTextDocumentEdits :: J.DocumentChange -> J.DocumentChange
754+
sortOnlyTextDocumentEdits (J.InL (J.TextDocumentEdit td (J.List edits))) = J.InL $ J.TextDocumentEdit td (J.List edits')
755755
where
756756
edits' = L.sortBy down edits
757+
sortOnlyTextDocumentEdits (J.InR others) = J.InR others
757758

758759
down (J.TextEdit r1 _) (J.TextEdit r2 _) = r2 `compare` r1

0 commit comments

Comments
 (0)