Add support for file and folder operations (create, rename, move) to workspace edits

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

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

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

@@ -257,6 +257,12 @@ makeFieldsNoPrefix ''DocumentFilter
 makeFieldsNoPrefix ''TextEdit
 makeFieldsNoPrefix ''VersionedTextDocumentIdentifier
 makeFieldsNoPrefix ''TextDocumentEdit
+makeFieldsNoPrefix ''CreateFileOptions
+makeFieldsNoPrefix ''CreateFile
+makeFieldsNoPrefix ''RenameFileOptions
+makeFieldsNoPrefix ''RenameFile
+makeFieldsNoPrefix ''DeleteFileOptions
+makeFieldsNoPrefix ''DeleteFile
 makeFieldsNoPrefix ''WorkspaceEdit
 
 -- Workspace Folders

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

@@ -1,11 +1,16 @@
 {-# LANGUAGE DuplicateRecordFields      #-}
 {-# 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
 
@@ -38,12 +43,135 @@ deriveJSON lspOptions ''TextDocumentEdit
 
 -- ---------------------------------------------------------------------
 
+-- | Options to create a file.
+data CreateFileOptions =
+  CreateFileOptions
+    { -- | Overwrite existing file. Overwrite wins over `ignoreIfExists`
+      _overwrite      :: Maybe Bool
+      -- | Ignore if exists.
+    , _ignoreIfExists :: Maybe Bool
+    } deriving (Show, Read, Eq)
+
+deriveJSON lspOptions ''CreateFileOptions
+
+-- | Create file operation
+data CreateFile =
+  CreateFile
+    { -- | The resource to create.
+      _uri      :: Uri
+      -- | Additional options
+    , _options  :: Maybe CreateFileOptions
+    } deriving (Show, Read, Eq)
+
+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 =
+  RenameFileOptions
+    { -- | Overwrite target if existing. Overwrite wins over `ignoreIfExists`
+      _overwrite      :: Maybe Bool
+      -- | Ignores if target exists.
+    , _ignoreIfExists :: Maybe Bool
+    } deriving (Show, Read, Eq)
+
+deriveJSON lspOptions ''RenameFileOptions
+
+-- | Rename file operation
+data RenameFile =
+  RenameFile
+    { -- | The old (existing) location.
+      _oldUri   :: Uri
+      -- | The new location.
+    , _newUri   :: Uri
+      -- | Rename options.
+    , _options  :: Maybe RenameFileOptions
+    } deriving (Show, Read, Eq)
+
+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 =
+  DeleteFileOptions
+    { -- | Delete the content recursively if a folder is denoted.
+      _recursive          :: Maybe Bool
+      -- | Ignore the operation if the file doesn't exist.
+    , _ignoreIfNotExists  :: Maybe Bool
+    } deriving (Show, Read, Eq)
+
+deriveJSON lspOptions ''DeleteFileOptions
+
+-- | Delete file operation
+data DeleteFile =
+  DeleteFile
+    { -- | The file to delete.
+      _uri      :: Uri
+      -- | Delete options.
+    , _options  :: Maybe DeleteFileOptions
+    } deriving (Show, Read, Eq)
+
+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{..}
+
+
+-- ---------------------------------------------------------------------
+
+-- | `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 =
   WorkspaceEdit
     { _changes         :: Maybe WorkspaceEditMap
-    , _documentChanges :: Maybe (List TextDocumentEdit)
+    , _documentChanges :: Maybe (List DocumentChange)
     } deriving (Show, Read, Eq)
 
 instance Semigroup WorkspaceEdit where

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

@@ -129,41 +129,104 @@ 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 uri)
+                (VirtualFile 0 0 (Rope.fromText ""))
+  where 
+    shouldOverwrite :: Bool 
+    shouldOverwrite = case options of 
+        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 = 
+  let oldUri = J.toNormalizedUri oldUri'
+      newUri = J.toNormalizedUri 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 
+        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
+applyDeleteFile (J.DeleteFile uri _options) = 
+  updateVFS $ Map.delete (J.toNormalizedUri 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
   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'
-
-    editToChangeEvent (J.TextEdit range text) = J.TextDocumentContentChangeEvent (Just range) Nothing text
+    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
 
 -- ---------------------------------------------------------------------
 virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath

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