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 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 diff --git a/lsp-types/src/Language/LSP/Types/Lens.hs b/lsp-types/src/Language/LSP/Types/Lens.hs index 9eb16596f..1ff326635 100644 --- a/lsp-types/src/Language/LSP/Types/Lens.hs +++ b/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 diff --git a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs b/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs index 4ebda0efb..430e963fa 100644 --- a/lsp-types/src/Language/LSP/Types/WorkspaceEdit.hs +++ b/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 diff --git a/lsp-types/src/Language/LSP/VFS.hs b/lsp-types/src/Language/LSP/VFS.hs index 95f294bb1..05f091729 100644 --- a/lsp-types/src/Language/LSP/VFS.hs +++ b/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 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