lsp-types 1.4.0.1 → 1.5.0.0
raw patch · 13 files changed
+46/−393 lines, 13 filesdep −bytestringdep −directorydep −hsloggerdep ~mtlPVP ok
version bump matches the API change (PVP)
Dependencies removed: bytestring, directory, hslogger, rope-utf16-splay, temporary
Dependency ranges changed: mtl
API changes (from Hackage documentation)
- Language.LSP.Types.Lens: instance Language.LSP.Types.Lens.HasWorkspaceSymbolProvider Language.LSP.Types.ServerCapabilities.ServerCapabilities (GHC.Maybe.Maybe GHC.Types.Bool)
- Language.LSP.VFS: PosPrefixInfo :: !Text -> !Text -> !Text -> !Position -> PosPrefixInfo
- Language.LSP.VFS: VFS :: !Map NormalizedUri VirtualFile -> !FilePath -> VFS
- Language.LSP.VFS: VirtualFile :: !Int32 -> !Int -> !Rope -> VirtualFile
- Language.LSP.VFS: [$sel:_file_version:VirtualFile] :: VirtualFile -> !Int
- Language.LSP.VFS: [$sel:_lsp_version:VirtualFile] :: VirtualFile -> !Int32
- Language.LSP.VFS: [$sel:_text:VirtualFile] :: VirtualFile -> !Rope
- Language.LSP.VFS: [$sel:cursorPos:PosPrefixInfo] :: PosPrefixInfo -> !Position
- Language.LSP.VFS: [$sel:fullLine:PosPrefixInfo] :: PosPrefixInfo -> !Text
- Language.LSP.VFS: [$sel:prefixModule:PosPrefixInfo] :: PosPrefixInfo -> !Text
- Language.LSP.VFS: [$sel:prefixText:PosPrefixInfo] :: PosPrefixInfo -> !Text
- Language.LSP.VFS: [$sel:vfsMap:VFS] :: VFS -> !Map NormalizedUri VirtualFile
- Language.LSP.VFS: [$sel:vfsTempDir:VFS] :: VFS -> !FilePath
- Language.LSP.VFS: applyChange :: Rope -> TextDocumentContentChangeEvent -> Rope
- Language.LSP.VFS: applyChanges :: Rope -> [TextDocumentContentChangeEvent] -> Rope
- Language.LSP.VFS: changeChars :: Rope -> Int -> Int -> Text -> Rope
- Language.LSP.VFS: changeFromClientVFS :: VFS -> Message 'TextDocumentDidChange -> (VFS, [String])
- Language.LSP.VFS: changeFromServerVFS :: VFS -> Message 'WorkspaceApplyEdit -> IO VFS
- Language.LSP.VFS: closeVFS :: VFS -> Message 'TextDocumentDidClose -> (VFS, [String])
- Language.LSP.VFS: data PosPrefixInfo
- Language.LSP.VFS: data VFS
- Language.LSP.VFS: data VirtualFile
- Language.LSP.VFS: getCompletionPrefix :: Monad m => Position -> VirtualFile -> m (Maybe PosPrefixInfo)
- Language.LSP.VFS: initVFS :: (VFS -> IO r) -> IO r
- Language.LSP.VFS: instance GHC.Classes.Eq Language.LSP.VFS.PosPrefixInfo
- Language.LSP.VFS: instance GHC.Show.Show Language.LSP.VFS.PosPrefixInfo
- Language.LSP.VFS: instance GHC.Show.Show Language.LSP.VFS.VFS
- Language.LSP.VFS: instance GHC.Show.Show Language.LSP.VFS.VirtualFile
- Language.LSP.VFS: openVFS :: VFS -> Message 'TextDocumentDidOpen -> (VFS, [String])
- Language.LSP.VFS: persistFileVFS :: VFS -> NormalizedUri -> Maybe (FilePath, IO ())
- Language.LSP.VFS: rangeLinesFromVfs :: VirtualFile -> Range -> Text
- Language.LSP.VFS: updateVFS :: (VFSMap -> VFSMap) -> VFS -> VFS
- Language.LSP.VFS: virtualFileText :: VirtualFile -> Text
- Language.LSP.VFS: virtualFileVersion :: VirtualFile -> Int32
+ Language.LSP.Types: SttNamespace :: SemanticTokenTypes
+ Language.LSP.Types.Lens: instance Language.LSP.Types.Lens.HasContext Language.LSP.Types.SignatureHelp.SignatureHelpParams (GHC.Maybe.Maybe Language.LSP.Types.SignatureHelp.SignatureHelpContext)
+ Language.LSP.Types.Lens: instance Language.LSP.Types.Lens.HasPosition Language.LSP.Types.SignatureHelp.SignatureHelpParams Language.LSP.Types.Location.Position
+ Language.LSP.Types.Lens: instance Language.LSP.Types.Lens.HasTextDocument Language.LSP.Types.SignatureHelp.SignatureHelpParams Language.LSP.Types.TextDocument.TextDocumentIdentifier
+ Language.LSP.Types.Lens: instance Language.LSP.Types.Lens.HasWorkDoneToken Language.LSP.Types.SignatureHelp.SignatureHelpParams (GHC.Maybe.Maybe Language.LSP.Types.Progress.ProgressToken)
+ Language.LSP.Types.Lens: instance Language.LSP.Types.Lens.HasWorkspaceSymbolProvider Language.LSP.Types.ServerCapabilities.ServerCapabilities (GHC.Maybe.Maybe (GHC.Types.Bool Language.LSP.Types.Common.|? Language.LSP.Types.WorkspaceSymbol.WorkspaceSymbolOptions))
- Language.LSP.Types: regHelper :: forall m_a63Iw x_a63Ix. SMethod m_a63Iw -> (Show (RegistrationOptions m_a63Iw) => ToJSON (RegistrationOptions m_a63Iw) => FromJSON (RegistrationOptions m_a63Iw) => x_a63Ix) -> x_a63Ix
+ Language.LSP.Types: regHelper :: forall m_a648B x_a648C. SMethod m_a648B -> (Show (RegistrationOptions m_a648B) => ToJSON (RegistrationOptions m_a648B) => FromJSON (RegistrationOptions m_a648B) => x_a648C) -> x_a648C
- Language.LSP.Types.Capabilities: ServerCapabilities :: Maybe (TextDocumentSyncOptions |? TextDocumentSyncKind) -> Maybe (Bool |? HoverOptions) -> Maybe CompletionOptions -> Maybe SignatureHelpOptions -> Maybe (Bool |? (DeclarationOptions |? DeclarationRegistrationOptions)) -> Maybe (Bool |? DefinitionOptions) -> Maybe (Bool |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions)) -> Maybe (Bool |? (ImplementationOptions |? ImplementationRegistrationOptions)) -> Maybe (Bool |? ReferenceOptions) -> Maybe (Bool |? DocumentHighlightOptions) -> Maybe (Bool |? DocumentSymbolOptions) -> Maybe (Bool |? CodeActionOptions) -> Maybe CodeLensOptions -> Maybe DocumentLinkOptions -> Maybe (Bool |? (DocumentColorOptions |? DocumentColorRegistrationOptions)) -> Maybe (Bool |? DocumentFormattingOptions) -> Maybe (Bool |? DocumentRangeFormattingOptions) -> Maybe DocumentOnTypeFormattingOptions -> Maybe (Bool |? RenameOptions) -> Maybe (Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions)) -> Maybe ExecuteCommandOptions -> Maybe (Bool |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions)) -> Maybe (Bool |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions)) -> Maybe (SemanticTokensOptions |? SemanticTokensRegistrationOptions) -> Maybe Bool -> Maybe WorkspaceServerCapabilities -> Maybe Value -> ServerCapabilities
+ Language.LSP.Types.Capabilities: ServerCapabilities :: Maybe (TextDocumentSyncOptions |? TextDocumentSyncKind) -> Maybe (Bool |? HoverOptions) -> Maybe CompletionOptions -> Maybe SignatureHelpOptions -> Maybe (Bool |? (DeclarationOptions |? DeclarationRegistrationOptions)) -> Maybe (Bool |? DefinitionOptions) -> Maybe (Bool |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions)) -> Maybe (Bool |? (ImplementationOptions |? ImplementationRegistrationOptions)) -> Maybe (Bool |? ReferenceOptions) -> Maybe (Bool |? DocumentHighlightOptions) -> Maybe (Bool |? DocumentSymbolOptions) -> Maybe (Bool |? CodeActionOptions) -> Maybe CodeLensOptions -> Maybe DocumentLinkOptions -> Maybe (Bool |? (DocumentColorOptions |? DocumentColorRegistrationOptions)) -> Maybe (Bool |? DocumentFormattingOptions) -> Maybe (Bool |? DocumentRangeFormattingOptions) -> Maybe DocumentOnTypeFormattingOptions -> Maybe (Bool |? RenameOptions) -> Maybe (Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions)) -> Maybe ExecuteCommandOptions -> Maybe (Bool |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions)) -> Maybe (Bool |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions)) -> Maybe (SemanticTokensOptions |? SemanticTokensRegistrationOptions) -> Maybe (Bool |? WorkspaceSymbolOptions) -> Maybe WorkspaceServerCapabilities -> Maybe Value -> ServerCapabilities
- Language.LSP.Types.Capabilities: [$sel:_workspaceSymbolProvider:ServerCapabilities] :: ServerCapabilities -> Maybe Bool
+ Language.LSP.Types.Capabilities: [$sel:_workspaceSymbolProvider:ServerCapabilities] :: ServerCapabilities -> Maybe (Bool |? WorkspaceSymbolOptions)
- Language.LSP.Types.Lens: _InL :: forall a_a6WPX b_ac6Y a_ac6X. Prism ((|?) a_a6WPX b_ac6Y) ((|?) a_ac6X b_ac6Y) a_a6WPX a_ac6X
+ Language.LSP.Types.Lens: _InL :: forall a_a6XhT b_aarW a_aarV. Prism ((|?) a_a6XhT b_aarW) ((|?) a_aarV b_aarW) a_a6XhT a_aarV
- Language.LSP.Types.Lens: _InR :: forall a_ac6X b_a6WQ2 b_ac6Y. Prism ((|?) a_ac6X b_a6WQ2) ((|?) a_ac6X b_ac6Y) b_a6WQ2 b_ac6Y
+ Language.LSP.Types.Lens: _InR :: forall a_aarV b_a6XhY b_aarW. Prism ((|?) a_aarV b_a6XhY) ((|?) a_aarV b_aarW) b_a6XhY b_aarW
Files
- ChangeLog.md +4/−0
- lsp-types.cabal +4/−10
- src/Language/LSP/Types/Common.hs +3/−0
- src/Language/LSP/Types/Lens.hs +2/−1
- src/Language/LSP/Types/Location.hs +9/−0
- src/Language/LSP/Types/LspId.hs +9/−1
- src/Language/LSP/Types/Message.hs +5/−5
- src/Language/LSP/Types/Method.hs +0/−1
- src/Language/LSP/Types/Parsing.hs +1/−1
- src/Language/LSP/Types/SMethodMap.hs +1/−1
- src/Language/LSP/Types/SemanticTokens.hs +6/−2
- src/Language/LSP/Types/ServerCapabilities.hs +2/−1
- src/Language/LSP/VFS.hs +0/−370
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for lsp-types +## 1.5.0.0++* VFS module moved from `lsp-types` to `lsp`, as it relates to the actual implementation of a LSP server.+ ## 1.4.0.1 * Fix result type of selection range requests.
lsp-types.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp-types-version: 1.4.0.1+version: 1.5.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol, data types description: An implementation of the types to allow language implementors to@@ -21,7 +21,6 @@ , Language.LSP.Types.Capabilities , Language.LSP.Types.Lens , Language.LSP.Types.SMethodMap- , Language.LSP.VFS , Data.IxMap other-modules: Language.LSP.Types.CallHierarchy , Language.LSP.Types.Cancellation@@ -74,26 +73,21 @@ build-depends: base >= 4.11 && < 5 , aeson >=1.2.2.0 , binary- , bytestring , containers , data-default , deepseq- , Diff- , directory+ , Diff >= 0.2 , dlist , filepath , hashable- , hslogger , lens >= 4.15.2- , mtl- , network-uri+ , mtl < 2.4+ , network-uri >= 2.6 , mod- , rope-utf16-splay >= 0.3.1.0 , scientific , some , text , template-haskell- , temporary , unordered-containers hs-source-dirs: src default-language: Haskell2010
src/Language/LSP/Types/Common.hs view
@@ -18,6 +18,7 @@ import Control.Applicative import Control.DeepSeq import Data.Aeson+import Data.Hashable import Data.Int (Int32) import Data.Mod.Word import Text.Read (Read(readPrec))@@ -32,6 +33,8 @@ deriving newtype (Num, Bounded, Enum, Eq, Ord) deriving stock (Generic) deriving anyclass (NFData)++instance Hashable UInt where hashWithSalt s (UInt n) = hashWithSalt s (unMod n) instance Show UInt where show (UInt u) = show $ unMod u
src/Language/LSP/Types/Lens.hs view
@@ -56,7 +56,7 @@ import Language.LSP.Types.SemanticTokens import Control.Lens.TH --- TODO: This is out of date and very unmantainable, use TH to call all these!!+-- TODO: This is out of date and very unmaintainable, use TH to call all these!! -- client capabilities makeFieldsNoPrefix ''MessageActionItemClientCapabilities@@ -360,6 +360,7 @@ -- Signature Help makeFieldsNoPrefix ''SignatureHelpSignatureInformation makeFieldsNoPrefix ''SignatureHelpParameterInformation+makeFieldsNoPrefix ''SignatureHelpParams makeFieldsNoPrefix ''SignatureHelpClientCapabilities makeFieldsNoPrefix ''SignatureHelpOptions makeFieldsNoPrefix ''SignatureHelpRegistrationOptions
src/Language/LSP/Types/Location.hs view
@@ -4,6 +4,7 @@ import Control.DeepSeq import Data.Aeson.TH+import Data.Hashable import GHC.Generics hiding (UInt) import Language.LSP.Types.Common import Language.LSP.Types.Uri@@ -11,6 +12,8 @@ -- --------------------------------------------------------------------- +-- | A position in a document. Note that the character offsets in a line+-- are given in UTF-16 code units, *not* Unicode code points. data Position = Position { -- | Line position in a document (zero-based).@@ -24,6 +27,8 @@ instance NFData Position deriveJSON lspOptions ''Position +instance Hashable Position+ -- --------------------------------------------------------------------- data Range =@@ -35,6 +40,8 @@ instance NFData Range deriveJSON lspOptions ''Range +instance Hashable Range+ -- --------------------------------------------------------------------- data Location =@@ -45,6 +52,8 @@ instance NFData Location deriveJSON lspOptions ''Location++instance Hashable Location -- ---------------------------------------------------------------------
src/Language/LSP/Types/LspId.hs view
@@ -7,9 +7,10 @@ module Language.LSP.Types.LspId where import qualified Data.Aeson as A-import Data.Text (Text)+import Data.Hashable import Data.Int (Int32) import Data.IxMap+import Data.Text (Text) import Language.LSP.Types.Method @@ -30,6 +31,10 @@ type Base LspId = SomeLspId toBase = SomeLspId +instance Hashable (LspId m) where+ hashWithSalt n (IdInt i) = hashWithSalt n i+ hashWithSalt n (IdString t) = hashWithSalt n t+ data SomeLspId where SomeLspId :: !(LspId m) -> SomeLspId @@ -45,3 +50,6 @@ go (IdString a) (IdString b) = a `compare` b go (IdInt _) (IdString _) = LT go (IdString _) (IdInt _) = GT++instance Hashable SomeLspId where+ hashWithSalt n (SomeLspId lspId) = hashWithSalt n lspId
src/Language/LSP/Types/Message.hs view
@@ -372,7 +372,7 @@ deriving instance Show (ResponseResult m) => Show (ResponseMessage m) instance (ToJSON (ResponseResult m)) => ToJSON (ResponseMessage m) where- toJSON (ResponseMessage { _jsonrpc = jsonrpc, _id = lspid, _result = result })+ toJSON ResponseMessage { _jsonrpc = jsonrpc, _id = lspid, _result = result } = object [ "jsonrpc" .= jsonrpc , "id" .= lspid@@ -389,11 +389,11 @@ _result <- o .:! "result" _error <- o .:? "error" result <- case (_error, _result) of- ((Just err), Nothing ) -> pure $ Left err- (Nothing , (Just res)) -> pure $ Right res- ((Just _err), (Just _res)) -> fail $ "both error and result cannot be present: " ++ show o+ (Just err, Nothing) -> pure $ Left err+ (Nothing, Just res) -> pure $ Right res+ (Just _err, Just _res) -> fail $ "both error and result cannot be present: " ++ show o (Nothing, Nothing) -> fail "both error and result cannot be Nothing"- return $ ResponseMessage _jsonrpc _id $ result+ return $ ResponseMessage _jsonrpc _id result -- --------------------------------------------------------------------- -- Helper Type Families
src/Language/LSP/Types/Method.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-}
src/Language/LSP/Types/Parsing.hs view
@@ -29,7 +29,7 @@ import Data.Function (on) -- ------------------------------------------------------------------------ Working with arbritary messages+-- Working with arbitrary messages -- --------------------------------------------------------------------- data FromServerMessage' a where
src/Language/LSP/Types/SMethodMap.hs view
@@ -28,7 +28,7 @@ -- This type exists to avoid a dependency on 'dependent-map'. It is less -- safe (since we use 'unsafeCoerce') but much simpler and hence easier to include.--- | A specialized altenative to a full dependent map for use with 'SMethod'.+-- | A specialized alternative to a full dependent map for use with 'SMethod'. data SMethodMap (v :: Method f t -> Type) = -- This works by using an 'IntMap' indexed by constructor tag for the majority -- of 'SMethod's, which have no parameters, and hence can only appear once as keys
src/Language/LSP/Types/SemanticTokens.hs view
@@ -29,7 +29,8 @@ import Data.String data SemanticTokenTypes =- SttType+ SttNamespace+ | SttType | SttClass | SttEnum | SttInterface@@ -54,6 +55,7 @@ deriving (Show, Read, Eq, Ord) instance A.ToJSON SemanticTokenTypes where+ toJSON SttNamespace = A.String "namespace" toJSON SttType = A.String "type" toJSON SttClass = A.String "class" toJSON SttEnum = A.String "enum"@@ -78,6 +80,7 @@ toJSON (SttUnknown t) = A.String t instance A.FromJSON SemanticTokenTypes where+ parseJSON (A.String "namespace") = pure SttNamespace parseJSON (A.String "type") = pure SttType parseJSON (A.String "class") = pure SttClass parseJSON (A.String "enum") = pure SttEnum@@ -105,7 +108,8 @@ -- | The set of semantic token types which are "known" (i.e. listed in the LSP spec). knownSemanticTokenTypes :: [SemanticTokenTypes] knownSemanticTokenTypes = [- SttType+ SttNamespace+ , SttType , SttClass , SttEnum , SttInterface
src/Language/LSP/Types/ServerCapabilities.hs view
@@ -31,6 +31,7 @@ import Language.LSP.Types.TextDocument import Language.LSP.Types.TypeDefinition import Language.LSP.Types.Utils+import Language.LSP.Types.WorkspaceSymbol -- --------------------------------------------------------------------- @@ -126,7 +127,7 @@ -- @since 3.16.0 , _semanticTokensProvider :: Maybe (SemanticTokensOptions |? SemanticTokensRegistrationOptions) -- | The server provides workspace symbol support.- , _workspaceSymbolProvider :: Maybe Bool+ , _workspaceSymbolProvider :: Maybe (Bool |? WorkspaceSymbolOptions) -- | Workspace specific server capabilities , _workspace :: Maybe WorkspaceServerCapabilities -- | Experimental server capabilities.
− src/Language/LSP/VFS.hs
@@ -1,370 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}--{-|-Handles the "Language.LSP.Types.TextDocumentDidChange" \/-"Language.LSP.Types.TextDocumentDidOpen" \/-"Language.LSP.Types.TextDocumentDidClose" messages to keep an in-memory-`filesystem` of the current client workspace. The server can access and edit-files in the client workspace by operating on the "VFS" in "LspFuncs".--}-module Language.LSP.VFS- (- VFS(..)- , VirtualFile(..)- , virtualFileText- , virtualFileVersion- -- * Managing the VFS- , initVFS- , openVFS- , changeFromClientVFS- , changeFromServerVFS- , persistFileVFS- , closeVFS- , updateVFS-- -- * manipulating the file contents- , rangeLinesFromVfs- , PosPrefixInfo(..)- , getCompletionPrefix-- -- * for tests- , applyChanges- , applyChange- , changeChars- ) where--import Control.Lens hiding ( (<.>), parts )-import Control.Monad-import Data.Char (isUpper, isAlphaNum)-import Data.Text ( Text )-import qualified Data.Text as T-import Data.Int (Int32)-import Data.List-import Data.Ord-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Map.Strict as Map-import Data.Maybe-import Data.Rope.UTF16 ( Rope )-import qualified Data.Rope.UTF16 as Rope-import qualified Language.LSP.Types as J-import qualified Language.LSP.Types.Lens as J-import System.FilePath-import Data.Hashable-import System.Directory-import System.IO -import System.IO.Temp-import System.Log.Logger---- ----------------------------------------------------------------------{-# ANN module ("hlint: ignore Eta reduce" :: String) #-}-{-# ANN module ("hlint: ignore Redundant do" :: String) #-}--- -----------------------------------------------------------------------data VirtualFile =- VirtualFile {- _lsp_version :: !Int32 -- ^ The LSP version of the document- , _file_version :: !Int -- ^ This number is only incremented whilst the file- -- remains in the map.- , _text :: !Rope -- ^ The full contents of the document- } deriving (Show)---type VFSMap = Map.Map J.NormalizedUri VirtualFile--data VFS = VFS { vfsMap :: !(Map.Map J.NormalizedUri VirtualFile)- , vfsTempDir :: !FilePath -- ^ This is where all the temporary files will be written to- } deriving Show-------virtualFileText :: VirtualFile -> Text-virtualFileText vf = Rope.toText (_text vf)--virtualFileVersion :: VirtualFile -> Int32-virtualFileVersion vf = _lsp_version vf-------initVFS :: (VFS -> IO r) -> IO r-initVFS k = withSystemTempDirectory "haskell-lsp" $ \temp_dir -> k (VFS mempty temp_dir)---- ------------------------------------------------------------------------- | Applies the changes from a 'J.DidOpenTextDocument' to the 'VFS'-openVFS :: VFS -> J.Message 'J.TextDocumentDidOpen -> (VFS, [String])-openVFS vfs (J.NotificationMessage _ _ params) =- let J.DidOpenTextDocumentParams- (J.TextDocumentItem uri _ version text) = params- in (updateVFS (Map.insert (J.toNormalizedUri uri) (VirtualFile version 0 (Rope.fromText text))) vfs- , [])----- ------------------------------------------------------------------------- ^ Applies a 'DidChangeTextDocumentNotification' to the 'VFS'-changeFromClientVFS :: VFS -> J.Message 'J.TextDocumentDidChange -> (VFS,[String])-changeFromClientVFS vfs (J.NotificationMessage _ _ params) =- let- J.DidChangeTextDocumentParams vid (J.List changes) = params- J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid- in- case Map.lookup uri (vfsMap vfs) of- Just (VirtualFile _ file_ver str) ->- let str' = applyChanges str changes- -- the client shouldn't be sending over a null version, only the server.- in (updateVFS (Map.insert uri (VirtualFile (fromMaybe 0 version) (file_ver + 1) str')) vfs, [])- Nothing ->- -- logs $ "haskell-lsp:changeVfs:can't find uri:" ++ show uri- -- return vfs- (vfs, ["haskell-lsp:changeVfs:can't find uri:" ++ show uri])--updateVFS :: (VFSMap -> VFSMap) -> VFS -> VFS-updateVFS f vfs@VFS{vfsMap} = vfs { vfsMap = f vfsMap }---- -----------------------------------------------------------------------applyCreateFile :: J.CreateFile -> VFS -> VFS-applyCreateFile (J.CreateFile uri options _ann) = - 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 _ann) 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 _ann) = - 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 . editRange) 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- editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range- editRange (J.InR e) = e ^. J.range- editRange (J.InL e) = e ^. J.range-- editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent- editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText)- editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText)--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 _anns = edit- case mDocChanges of- Just (J.List docChanges) -> applyDocumentChanges docChanges- Nothing -> case mChanges of- 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)) (fmap J.InL edits)]-- 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-virtualFileName prefix uri (VirtualFile _ file_ver _) =- let uri_raw = J.fromNormalizedUri uri- basename = maybe "" takeFileName (J.uriToFilePath uri_raw)- -- Given a length and a version number, pad the version number to- -- the given n. Does nothing if the version number string is longer- -- than the given length.- padLeft :: Int -> Int -> String- padLeft n num =- let numString = show num- in replicate (n - length numString) '0' ++ numString- in prefix </> basename ++ "-" ++ padLeft 5 file_ver ++ "-" ++ show (hash uri_raw) <.> takeExtensions basename---- | Write a virtual file to a temporary file if it exists in the VFS.-persistFileVFS :: VFS -> J.NormalizedUri -> Maybe (FilePath, IO ())-persistFileVFS vfs uri =- case Map.lookup uri (vfsMap vfs) of- Nothing -> Nothing- Just vf ->- let tfn = virtualFileName (vfsTempDir vfs) uri vf- action = do- exists <- doesFileExist tfn- unless exists $ do- let contents = Rope.toString (_text vf)- writeRaw h = do- -- We honour original file line endings- hSetNewlineMode h noNewlineTranslation- hSetEncoding h utf8- hPutStr h contents- debugM "haskell-lsp.persistFileVFS" $ "Writing virtual file: " - ++ "uri = " ++ show uri ++ ", virtual file = " ++ show tfn- withFile tfn WriteMode writeRaw- in Just (tfn, action)---- -----------------------------------------------------------------------closeVFS :: VFS -> J.Message 'J.TextDocumentDidClose -> (VFS, [String])-closeVFS vfs (J.NotificationMessage _ _ params) =- let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier uri) = params- in (updateVFS (Map.delete (J.toNormalizedUri uri)) vfs,["Closed: " ++ show uri])---- ------------------------------------------------------------------------- | Apply the list of changes.--- Changes should be applied in the order that they are--- received from the client.-applyChanges :: Rope -> [J.TextDocumentContentChangeEvent] -> Rope-applyChanges = foldl' applyChange---- -----------------------------------------------------------------------applyChange :: Rope -> J.TextDocumentContentChangeEvent -> Rope-applyChange _ (J.TextDocumentContentChangeEvent Nothing Nothing str)- = Rope.fromText str-applyChange str (J.TextDocumentContentChangeEvent (Just (J.Range (J.Position sl sc) _to)) (Just len) txt)- = changeChars str start (fromIntegral len) txt- where- start = Rope.rowColumnCodeUnits (Rope.RowColumn (fromIntegral sl) (fromIntegral sc)) str-applyChange str (J.TextDocumentContentChangeEvent (Just (J.Range (J.Position sl sc) (J.Position el ec))) Nothing txt)- = changeChars str start len txt- where- start = Rope.rowColumnCodeUnits (Rope.RowColumn (fromIntegral sl) (fromIntegral sc)) str- end = Rope.rowColumnCodeUnits (Rope.RowColumn (fromIntegral el) (fromIntegral ec)) str- len = end - start-applyChange str (J.TextDocumentContentChangeEvent Nothing (Just _) _txt)- = str---- -----------------------------------------------------------------------changeChars :: Rope -> Int -> Int -> Text -> Rope-changeChars str start len new = mconcat [before, Rope.fromText new, after']- where- (before, after) = Rope.splitAt start str- after' = Rope.drop len after---- ------------------------------------------------------------------------- TODO:AZ:move this to somewhere sane--- | Describes the line at the current cursor position-data PosPrefixInfo = PosPrefixInfo- { fullLine :: !T.Text- -- ^ The full contents of the line the cursor is at-- , prefixModule :: !T.Text- -- ^ If any, the module name that was typed right before the cursor position.- -- For example, if the user has typed "Data.Maybe.from", then this property- -- will be "Data.Maybe"-- , prefixText :: !T.Text- -- ^ The word right before the cursor position, after removing the module part.- -- For example if the user has typed "Data.Maybe.from",- -- then this property will be "from"- , cursorPos :: !J.Position- -- ^ The cursor position- } deriving (Show,Eq)--getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo)-getCompletionPrefix pos@(J.Position l c) (VirtualFile _ _ ropetext) =- return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad- let headMaybe [] = Nothing- headMaybe (x:_) = Just x- lastMaybe [] = Nothing- lastMaybe xs = Just $ last xs-- curLine <- headMaybe $ T.lines $ Rope.toText- $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext- let beforePos = T.take (fromIntegral c) curLine- curWord <-- if | T.null beforePos -> Just ""- | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc '- | otherwise -> lastMaybe (T.words beforePos)-- let parts = T.split (=='.')- $ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord- case reverse parts of- [] -> Nothing- (x:xs) -> do- let modParts = dropWhile (not . isUpper . T.head)- $ reverse $ filter (not .T.null) xs- modName = T.intercalate "." modParts- return $ PosPrefixInfo curLine modName x pos---- -----------------------------------------------------------------------rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text-rangeLinesFromVfs (VirtualFile _ _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r- where- (_ ,s1) = Rope.splitAtLine (fromIntegral lf) ropetext- (s2, _) = Rope.splitAtLine (fromIntegral (lt - lf)) s1- r = Rope.toText s2--- ---------------------------------------------------------------------