diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/lsp-types.cabal b/lsp-types.cabal --- a/lsp-types.cabal +++ b/lsp-types.cabal @@ -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 diff --git a/src/Language/LSP/Types/Common.hs b/src/Language/LSP/Types/Common.hs --- a/src/Language/LSP/Types/Common.hs +++ b/src/Language/LSP/Types/Common.hs @@ -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 diff --git a/src/Language/LSP/Types/Lens.hs b/src/Language/LSP/Types/Lens.hs --- a/src/Language/LSP/Types/Lens.hs +++ b/src/Language/LSP/Types/Lens.hs @@ -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 diff --git a/src/Language/LSP/Types/Location.hs b/src/Language/LSP/Types/Location.hs --- a/src/Language/LSP/Types/Location.hs +++ b/src/Language/LSP/Types/Location.hs @@ -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 -- --------------------------------------------------------------------- diff --git a/src/Language/LSP/Types/LspId.hs b/src/Language/LSP/Types/LspId.hs --- a/src/Language/LSP/Types/LspId.hs +++ b/src/Language/LSP/Types/LspId.hs @@ -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 diff --git a/src/Language/LSP/Types/Message.hs b/src/Language/LSP/Types/Message.hs --- a/src/Language/LSP/Types/Message.hs +++ b/src/Language/LSP/Types/Message.hs @@ -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 diff --git a/src/Language/LSP/Types/Method.hs b/src/Language/LSP/Types/Method.hs --- a/src/Language/LSP/Types/Method.hs +++ b/src/Language/LSP/Types/Method.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Language/LSP/Types/Parsing.hs b/src/Language/LSP/Types/Parsing.hs --- a/src/Language/LSP/Types/Parsing.hs +++ b/src/Language/LSP/Types/Parsing.hs @@ -29,7 +29,7 @@ import Data.Function (on) -- --------------------------------------------------------------------- --- Working with arbritary messages +-- Working with arbitrary messages -- --------------------------------------------------------------------- data FromServerMessage' a where diff --git a/src/Language/LSP/Types/SMethodMap.hs b/src/Language/LSP/Types/SMethodMap.hs --- a/src/Language/LSP/Types/SMethodMap.hs +++ b/src/Language/LSP/Types/SMethodMap.hs @@ -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 diff --git a/src/Language/LSP/Types/SemanticTokens.hs b/src/Language/LSP/Types/SemanticTokens.hs --- a/src/Language/LSP/Types/SemanticTokens.hs +++ b/src/Language/LSP/Types/SemanticTokens.hs @@ -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 diff --git a/src/Language/LSP/Types/ServerCapabilities.hs b/src/Language/LSP/Types/ServerCapabilities.hs --- a/src/Language/LSP/Types/ServerCapabilities.hs +++ b/src/Language/LSP/Types/ServerCapabilities.hs @@ -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. diff --git a/src/Language/LSP/VFS.hs b/src/Language/LSP/VFS.hs deleted file mode 100644 --- a/src/Language/LSP/VFS.hs +++ /dev/null @@ -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 --- ---------------------------------------------------------------------