diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for lsp-client +## 0.4.0.0 -- 2024-08-09 + +* Update to lsp-2.7 and lsp-types-2.3 +* Introduce SessionT and MonadSession +* Lift all functions to MonadSession +* Session.initialize now takes LSP initialization options and returns the initialization result +* Session state no longer holds initialization result +* Add Session.getAllVersionedDocs + ## 0.3.0.0 -- 2024-04-04 * Support lsp 2.4 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lsp-client.cabal b/lsp-client.cabal --- a/lsp-client.cabal +++ b/lsp-client.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: lsp-client -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Haskell library for Language Server Protocol clients homepage: https://github.com/ners/lsp-client/blob/master/README.md license: Apache-2.0 @@ -49,9 +49,8 @@ base >= 4.16 && < 5, bytestring >= 0.9 && < 0.13, lens >= 5 && < 6, - lsp-types >= 2 && < 3, + lsp-types ^>= 2.3, unliftio >= 0.2 && < 0.3, - row-types, library import: common @@ -68,15 +67,17 @@ extra, filepath, generic-lens, - lsp >= 2.4, + lsp ^>= 2.7, mtl, stm, text, text-rope, - unordered-containers, + transformers, unix-compat >= 0.7.1 && < 0.8, - exposed-modules: + unordered-containers, + other-modules: Control.Concurrent.STM.TVar.Extra, + exposed-modules: Language.LSP.Client, Language.LSP.Client.Decoding, Language.LSP.Client.Encoding, diff --git a/src/Control/Concurrent/STM/TVar/Extra.hs b/src/Control/Concurrent/STM/TVar/Extra.hs --- a/src/Control/Concurrent/STM/TVar/Extra.hs +++ b/src/Control/Concurrent/STM/TVar/Extra.hs @@ -4,7 +4,7 @@ import Prelude overTVar :: (a -> a) -> TVar a -> STM a -overTVar f var = stateTVar var (\x -> (f x, f x)) +overTVar f var = stateTVar var $ \x -> let y = f x in (y, y) overTVarIO :: (a -> a) -> TVar a -> IO a overTVarIO = (atomically .) . overTVar diff --git a/src/Language/LSP/Client.hs b/src/Language/LSP/Client.hs --- a/src/Language/LSP/Client.hs +++ b/src/Language/LSP/Client.hs @@ -5,7 +5,6 @@ import Control.Concurrent.STM import Control.Monad (forever) -import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (asks, runReaderT) import Data.ByteString.Lazy qualified as LazyByteString import Data.Dependent.Map qualified as DMap @@ -17,20 +16,21 @@ import Language.LSP.Protocol.Message qualified as LSP import Language.LSP.VFS (emptyVFS) import System.IO (Handle) -import UnliftIO (concurrently_, race) +import UnliftIO (MonadUnliftIO, concurrently_, liftIO, race) import Prelude {- | Starts a new session, using the specified handles to communicate with the server. -} runSessionWithHandles - :: Handle + :: (MonadUnliftIO io) + => Handle -- ^ The input handle: messages sent from the server to the client will be read from here -> Handle -- ^ The output handle: messages sent by the client will be written here - -> Session a + -> SessionT io a -- ^ Session actions - -> IO a + -> io a runSessionWithHandles input output action = do initialState <- defaultSessionState emptyVFS flip runReaderT initialState $ do diff --git a/src/Language/LSP/Client/Exceptions.hs b/src/Language/LSP/Client/Exceptions.hs --- a/src/Language/LSP/Client/Exceptions.hs +++ b/src/Language/LSP/Client/Exceptions.hs @@ -8,9 +8,10 @@ import Data.ByteString.Lazy.Char8 qualified as LazyByteString import Data.List (nub) import Language.LSP.Protocol.Message - ( FromServerMessage - , ResponseError - , SomeLspId + ( ErrorData + , FromServerMessage + , LspId + , TResponseError ) import Prelude @@ -22,11 +23,10 @@ | ReplayOutOfOrder FromServerMessage [FromServerMessage] | UnexpectedDiagnostics | IncorrectApplyEditRequest String - | UnexpectedResponseError SomeLspId ResponseError + | forall m. (Show (ErrorData m)) => UnexpectedResponseError (LspId m) (TResponseError m) | UnexpectedServerTermination | IllegalInitSequenceMessage FromServerMessage | MessageSendError Value IOError - deriving stock (Eq) instance Exception SessionException diff --git a/src/Language/LSP/Client/Session.hs b/src/Language/LSP/Client/Session.hs --- a/src/Language/LSP/Client/Session.hs +++ b/src/Language/LSP/Client/Session.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE CPP #-} module Language.LSP.Client.Session where @@ -13,8 +14,10 @@ import Control.Lens.Extras (is) import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Reader (ReaderT, asks) +import Control.Monad.Reader (ReaderT (runReaderT), ask, asks) import Control.Monad.State (StateT, execState) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Data.Aeson (Value) import Data.Default (def) import Data.Foldable (foldl', foldr', forM_, toList) import Data.Function (on) @@ -28,40 +31,26 @@ import Data.List.Extra (groupOn) import Data.Map.Strict qualified as Map import Data.Maybe (fromJust, fromMaybe, mapMaybe) -import Data.Row import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text import Data.Text.Utf16.Rope.Mixed (Rope) import Language.LSP.Client.Decoding import Language.LSP.Client.Exceptions (SessionException (UnexpectedResponseError)) -import Language.LSP.Protocol.Capabilities (fullCaps) -import Language.LSP.Protocol.Lens hiding (error, to) +import Language.LSP.Protocol.Capabilities (fullLatestClientCaps) +import Language.LSP.Protocol.Lens qualified as LSP import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import System.PosixCompat.Process (getProcessID) import Language.LSP.VFS - ( VFS - , VfsLog - , VirtualFile (..) - , changeFromClientVFS - , changeFromServerVFS - , closeVFS - , lsp_version - , openVFS - , vfsMap - , virtualFileVersion - ) import System.Directory (canonicalizePath) import System.FilePath (isAbsolute, ()) import System.FilePath.Glob qualified as Glob +import System.PosixCompat.Process (getProcessID) import Prelude hiding (id) import Prelude qualified data SessionState = SessionState - { initialized :: TMVar InitializeResult - -- ^ The response of the initialization handshake, if any. - , pendingRequests :: TVar RequestMap + { pendingRequests :: TVar RequestMap -- ^ Response callbacks for sent requests waiting for a response. Once a response arrives the request is removed from this map. , notificationHandlers :: TVar NotificationMap -- ^ Notification callbacks that fire whenever a notification of their type is received. @@ -81,9 +70,8 @@ -- ^ The root of the project as sent to the server. Document URIs are relative to it. Not a `TVar` because it does not change during the session. } -defaultSessionState :: VFS -> IO SessionState -defaultSessionState vfs' = do - initialized <- newEmptyTMVarIO +defaultSessionState :: (MonadIO io) => VFS -> io SessionState +defaultSessionState vfs' = liftIO $ do pendingRequests <- newTVarIO emptyRequestMap notificationHandlers <- newTVarIO emptyNotificationMap lastRequestId <- newTVarIO 0 @@ -102,51 +90,55 @@ It is essentially an STM-backed `StateT`: despite it being `ReaderT`, it can still mutate `TVar` values. -} -type Session = ReaderT SessionState IO +type SessionT = ReaderT SessionState -documentChangeUri :: DocumentChange -> Uri -documentChangeUri (InL x) = x ^. textDocument . uri -documentChangeUri (InR (InL x)) = x ^. uri -documentChangeUri (InR (InR (InL x))) = x ^. oldUri -documentChangeUri (InR (InR (InR x))) = x ^. uri +type Session = SessionT IO --- eitherOf :: APrism' s a -> (a -> b) -> (s -> b) -> s -> b --- eitherOf p a b = either b a . matching p --- --- anyOf :: [APrism' s a] -> (a -> b) -> b -> s -> b --- anyOf [] _ b = const b --- anyOf (p : prisms) a b = eitherOf p a $ anyOf prisms a b +class (Monad m) => MonadSession m where + liftSession :: forall a. Session a -> m a +instance {-# OVERLAPPING #-} (MonadIO m) => MonadSession (SessionT m) where + liftSession a = liftIO . runReaderT a =<< ask + +instance {-# OVERLAPPABLE #-} (MonadTrans t, MonadSession m, Monad (t m)) => MonadSession (t m) where + liftSession = lift . liftSession + +documentChangeUri :: DocumentChange -> Uri +documentChangeUri (InL x) = x ^. LSP.textDocument . LSP.uri +documentChangeUri (InR (InL x)) = x ^. LSP.uri +documentChangeUri (InR (InR (InL x))) = x ^. LSP.oldUri +documentChangeUri (InR (InR (InR x))) = x ^. LSP.uri + {- | Fires whenever the client receives a message from the server. Updates the session state as needed. Note that this does not provide any business logic beyond updating the session state; you most likely want to use `sendRequest` and `receiveNotification` to register callbacks for specific messages. -} -handleServerMessage :: FromServerMessage -> Session () +handleServerMessage :: (MonadSession m) => FromServerMessage -> m () handleServerMessage (FromServerMess SMethod_Progress req) = - when (anyOf folded ($ req ^. params . value) [is _workDoneProgressBegin, is _workDoneProgressEnd]) - $ asks progressTokens - >>= liftIO - . flip modifyTVarIO (HashSet.insert $ req ^. params . token) + liftSession . when (anyOf folded ($ req ^. LSP.params . LSP.value) [is _workDoneProgressBegin, is _workDoneProgressEnd]) $ + asks progressTokens + >>= liftIO + . flip modifyTVarIO (HashSet.insert $ req ^. LSP.params . LSP.token) handleServerMessage (FromServerMess SMethod_ClientRegisterCapability req) = - asks serverCapabilities >>= liftIO . flip modifyTVarIO (HashMap.union (HashMap.fromList newRegs)) + liftSession $ asks serverCapabilities >>= liftIO . flip modifyTVarIO (HashMap.union (HashMap.fromList newRegs)) where - regs = req ^.. params . registrations . traversed . to toSomeRegistration . _Just - newRegs = (\sr@(SomeRegistration r) -> (r ^. id, sr)) <$> regs + regs = req ^.. LSP.params . LSP.registrations . traversed . to toSomeRegistration . _Just + newRegs = (\sr@(SomeRegistration r) -> (r ^. LSP.id, sr)) <$> regs handleServerMessage (FromServerMess SMethod_ClientUnregisterCapability req) = - asks serverCapabilities >>= liftIO . flip modifyTVarIO (flip (foldr' HashMap.delete) unRegs) + liftSession $ asks serverCapabilities >>= liftIO . flip modifyTVarIO (flip (foldr' HashMap.delete) unRegs) where - unRegs = (^. id) <$> req ^. params . unregisterations -handleServerMessage (FromServerMess SMethod_WorkspaceApplyEdit r) = do + unRegs = (^. LSP.id) <$> req ^. LSP.params . LSP.unregisterations +handleServerMessage (FromServerMess SMethod_WorkspaceApplyEdit r) = liftSession $ do -- First, prefer the versioned documentChanges field - allChangeParams <- case r ^. params . edit . documentChanges of + allChangeParams <- case r ^. LSP.params . LSP.edit . LSP.documentChanges of Just cs -> do mapM_ (checkIfNeedsOpened . documentChangeUri) cs -- replace the user provided version numbers with the VFS ones + 1 -- (technically we should check that the user versions match the VFS ones) - cs' <- traverseOf (traverse . _L . textDocument) bumpNewestVersion cs + cs' <- traverseOf (traverse . _L . LSP.textDocument) bumpNewestVersion cs return $ mapMaybe getParamsFromDocumentChange cs' -- Then fall back to the changes field - Nothing -> case r ^. params . edit . changes of + Nothing -> case r ^. LSP.params . LSP.edit . LSP.changes of Just cs -> do mapM_ checkIfNeedsOpened (Map.keys cs) concat <$> mapM (uncurry getChangeParams) (Map.toList cs) @@ -155,24 +147,22 @@ asks vfs >>= liftIO . flip modifyTVarIO (execState $ changeFromServerVFS logger r) - let groupedParams = groupOn (view textDocument) allChangeParams + let groupedParams = groupOn (view LSP.textDocument) allChangeParams mergedParams = mergeParams <$> groupedParams forM_ mergedParams $ sendNotification SMethod_TextDocumentDidChange -- Update VFS to new document versions - let sortedVersions = sortBy (compare `on` (^. textDocument . version)) <$> groupedParams - latestVersions = view textDocument . last <$> sortedVersions + let sortedVersions = sortBy (compare `on` (^. LSP.textDocument . LSP.version)) <$> groupedParams + latestVersions = view LSP.textDocument . last <$> sortedVersions - forM_ latestVersions $ \(VersionedTextDocumentIdentifier uri v) -> + forM_ latestVersions $ \VersionedTextDocumentIdentifier{..} -> asks vfs >>= liftIO - . flip - modifyTVarIO - ( \vfs -> do - let update (VirtualFile _ file_ver t) = VirtualFile v (file_ver + 1) t - in vfs & vfsMap . ix (toNormalizedUri uri) %~ update - ) + . flip + modifyTVarIO + ( vfsMap . ix (toNormalizedUri _uri) %~ ((lsp_version .~ _version) . (file_version +~ 1)) + ) sendResponse r $ Right @@ -183,7 +173,9 @@ } where logger :: LogAction (StateT VFS Identity) (WithSeverity VfsLog) - logger = LogAction $ \(WithSeverity msg sev) -> case sev of Error -> error $ show msg; _ -> pure () + logger = LogAction $ \WithSeverity{..} -> case getSeverity of Error -> error $ show getMsg; _ -> pure () + + checkIfNeedsOpened :: Uri -> Session () checkIfNeedsOpened uri = do isOpen <- asks vfs >>= liftIO . readTVarIO <&> has (vfsMap . ix (toNormalizedUri uri)) @@ -204,33 +196,43 @@ getParamsFromTextDocumentEdit :: TextDocumentEdit -> Maybe DidChangeTextDocumentParams getParamsFromTextDocumentEdit (TextDocumentEdit docId edits) = do - DidChangeTextDocumentParams <$> docId ^? _versionedTextDocumentIdentifier <*> pure (editToChangeEvent <$> edits) + _textDocument <- docId ^? _versionedTextDocumentIdentifier + let _contentChanges = editToChangeEvent <$> edits + pure DidChangeTextDocumentParams{..} editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent - editToChangeEvent (InR e) = TextDocumentContentChangeEvent $ InL $ #range .== (e ^. range) .+ #rangeLength .== Nothing .+ #text .== (e ^. newText) - editToChangeEvent (InL e) = TextDocumentContentChangeEvent $ InL $ #range .== (e ^. range) .+ #rangeLength .== Nothing .+ #text .== (e ^. newText) + editToChangeEvent (InR e) = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial{_rangeLength = Nothing, _range = e ^. LSP.range, _text = e ^. LSP.newText} + editToChangeEvent (InL e) = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial{_rangeLength = Nothing, _range = e ^. LSP.range, _text = e ^. LSP.newText} getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams getParamsFromDocumentChange (InL textDocumentEdit) = getParamsFromTextDocumentEdit textDocumentEdit getParamsFromDocumentChange _ = Nothing bumpNewestVersion :: OptionalVersionedTextDocumentIdentifier -> Session OptionalVersionedTextDocumentIdentifier - bumpNewestVersion (OptionalVersionedTextDocumentIdentifier uri (InL _)) = do - nextVersion <- head <$> textDocumentVersions uri - pure $ OptionalVersionedTextDocumentIdentifier uri $ InL nextVersion._version + bumpNewestVersion OptionalVersionedTextDocumentIdentifier{_uri, _version = InL _} = do + VersionedTextDocumentIdentifier{_version} <- head <$> textDocumentVersions _uri + pure OptionalVersionedTextDocumentIdentifier{_version = InL _version, ..} bumpNewestVersion i = pure i - -- For a uri returns an infinite list of versions [n,n+1,n+2,...] + -- For a uri returns an infinite list of versions [n+1,n+2,...] -- where n is the current version textDocumentVersions :: Uri -> Session [VersionedTextDocumentIdentifier] - textDocumentVersions uri = do - vfs <- asks vfs >>= liftIO . readTVarIO - let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . lsp_version - pure $ VersionedTextDocumentIdentifier uri <$> [curVer + 1 ..] + textDocumentVersions _uri = do + tail . iterate (LSP.version +~ 1) <$> getVersionedDoc TextDocumentIdentifier{_uri} + textDocumentEdits :: Uri -> [TextEdit] -> Session [TextDocumentEdit] textDocumentEdits uri edits = do - vers <- textDocumentVersions uri - pure $ zipWith (\v e -> TextDocumentEdit (review _versionedTextDocumentIdentifier v) [InL e]) vers edits + versions <- textDocumentVersions uri + pure $ + zipWith + ( \v e -> + TextDocumentEdit + { _edits = [InL e] + , _textDocument = review _versionedTextDocumentIdentifier v + } + ) + versions + edits getChangeParams uri edits = do edits <- textDocumentEdits uri (reverse edits) @@ -238,73 +240,76 @@ mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams mergeParams params = - let events = concat $ toList $ toList . (^. contentChanges) <$> params - in DidChangeTextDocumentParams (head params ^. textDocument) events -handleServerMessage (FromServerMess SMethod_WindowWorkDoneProgressCreate req) = sendResponse req $ Right Null + DidChangeTextDocumentParams + { _contentChanges = concat . toList $ toList . (^. LSP.contentChanges) <$> params + , _textDocument = head params ^. LSP.textDocument + } +handleServerMessage (FromServerMess SMethod_WindowWorkDoneProgressCreate req) = liftSession . sendResponse req $ Right Null handleServerMessage _ = pure () {- | Sends a request to the server, with a callback that fires when the response arrives. Multiple requests can be waiting at the same time. -} sendRequest - :: forall (m :: Method 'ClientToServer 'Request) - . (TMessage m ~ TRequestMessage m) - => SMethod m - -> MessageParams m - -> (TResponseMessage m -> IO ()) - -> Session (LspId m) -sendRequest requestMethod params requestCallback = do - reqId <- asks lastRequestId >>= liftIO . overTVarIO (+ 1) <&> IdInt - asks pendingRequests >>= liftIO . flip modifyTVarIO (updateRequestMap reqId RequestCallback{..}) - sendMessage $ fromClientReq $ TRequestMessage "2.0" reqId requestMethod params - pure reqId + :: forall (method :: Method 'ClientToServer 'Request) m + . (TMessage method ~ TRequestMessage method, MonadSession m) + => SMethod method + -> MessageParams method + -> (TResponseMessage method -> IO ()) + -> m (LspId method) +sendRequest requestMethod _params requestCallback = liftSession $ do + _id <- asks lastRequestId >>= liftIO . overTVarIO (+ 1) <&> IdInt + asks pendingRequests >>= liftIO . flip modifyTVarIO (updateRequestMap _id RequestCallback{..}) + sendMessage $ fromClientReq TRequestMessage{_jsonrpc = "2.0", _method = requestMethod, ..} + pure _id {- | Send a response to the server. This is used internally to acknowledge server requests. Users of this library cannot register callbacks to server requests, so this function is probably of no use to them. -} sendResponse - :: forall (m :: Method 'ServerToClient 'Request) - . TRequestMessage m - -> Either ResponseError (MessageResult m) - -> Session () -sendResponse req res = do - sendMessage $ FromClientRsp req._method $ TResponseMessage req._jsonrpc (Just req._id) res + :: forall (method :: Method 'ServerToClient 'Request) m + . (MonadSession m) + => TRequestMessage method + -> Either (TResponseError method) (MessageResult method) + -> m () +sendResponse TRequestMessage{..} _result = liftSession . sendMessage $ FromClientRsp _method TResponseMessage{_id = Just _id, ..} +-- {_id = Just _id, ..} + -- | Sends a request to the server and synchronously waits for its response. request - :: forall (m :: Method 'ClientToServer 'Request) - . (TMessage m ~ TRequestMessage m) - => SMethod m - -> MessageParams m - -> Session (TResponseMessage m) -request method params = do + :: forall (method :: Method 'ClientToServer 'Request) m + . (TMessage method ~ TRequestMessage method, MonadSession m) + => SMethod method + -> MessageParams method + -> m (TResponseMessage method) +request method params = liftSession $ do done <- liftIO newEmptyMVar void $ sendRequest method params $ putMVar done liftIO $ takeMVar done {- | Checks the response for errors and throws an exception if needed. - Returns the result if successful. + Returns the result if successful.InitializeParams -} -getResponseResult :: TResponseMessage m -> MessageResult m -getResponseResult response = either err Prelude.id $ response ^. result +getResponseResult :: (Show (ErrorData m)) => TResponseMessage m -> MessageResult m +getResponseResult response = either err Prelude.id $ response ^. LSP.result where - lid = SomeLspId $ fromJust response._id - err = throw . UnexpectedResponseError lid + err = throw . UnexpectedResponseError (fromJust $ response ^. LSP.id) -- | Sends a notification to the server. Updates the VFS if the notification is a document update. sendNotification - :: forall (m :: Method 'ClientToServer 'Notification) - . (TMessage m ~ TNotificationMessage m) - => SMethod m - -> MessageParams m - -> Session () -sendNotification m params = do + :: forall (method :: Method 'ClientToServer 'Notification) m + . (TMessage method ~ TNotificationMessage method, MonadSession m) + => SMethod method + -> MessageParams method + -> m () +sendNotification m params = liftSession $ do let n = TNotificationMessage "2.0" m params vfs <- asks vfs case m of - SMethod_TextDocumentDidOpen -> liftIO $ modifyTVarIO vfs (execState $ openVFS mempty n) - SMethod_TextDocumentDidClose -> liftIO $ modifyTVarIO vfs (execState $ closeVFS mempty n) - SMethod_TextDocumentDidChange -> liftIO $ modifyTVarIO vfs (execState $ changeFromClientVFS mempty n) + SMethod_TextDocumentDidOpen -> liftIO . modifyTVarIO vfs . execState $ openVFS mempty n + SMethod_TextDocumentDidClose -> liftIO . modifyTVarIO vfs . execState $ closeVFS mempty n + SMethod_TextDocumentDidChange -> liftIO . modifyTVarIO vfs . execState $ changeFromClientVFS mempty n _ -> pure () sendMessage $ fromClientNot n @@ -312,46 +317,49 @@ If multiple callbacks are registered for the same notification method, they will all be called. -} receiveNotification - :: forall (m :: Method 'ServerToClient 'Notification) - . (TMessage m ~ TNotificationMessage m) - => SMethod m - -> (TMessage m -> IO ()) - -> Session () + :: forall (method :: Method 'ServerToClient 'Notification) m + . (TMessage method ~ TNotificationMessage method, MonadSession m) + => SMethod method + -> (TMessage method -> IO ()) + -> m () receiveNotification method notificationCallback = - asks notificationHandlers - >>= liftIO - . flip - modifyTVarIO - ( appendNotificationCallback method NotificationCallback{..} - ) + liftSession $ + asks notificationHandlers + >>= liftIO + . flip + modifyTVarIO + ( appendNotificationCallback method NotificationCallback{..} + ) {- | Clears the registered callback for the given notification method, if any. If multiple callbacks have been registered, this clears /all/ of them. -} clearNotificationCallback - :: forall (m :: Method 'ServerToClient 'Notification) - . SMethod m - -> Session () + :: forall (method :: Method 'ServerToClient 'Notification) m + . (MonadSession m) + => SMethod method + -> m () clearNotificationCallback method = - asks notificationHandlers - >>= liftIO - . flip - modifyTVarIO - ( removeNotificationCallback method - ) + liftSession $ + asks notificationHandlers + >>= liftIO + . flip + modifyTVarIO + ( removeNotificationCallback method + ) -- | Queues a message to be sent to the server at the client's earliest convenience. -sendMessage :: FromClientMessage -> Session () -sendMessage msg = asks outgoing >>= liftIO . atomically . (`writeTQueue` msg) +sendMessage :: (MonadSession m) => FromClientMessage -> m () +sendMessage msg = liftSession $ asks outgoing >>= liftIO . atomically . (`writeTQueue` msg) -lspClientInfo :: Rec ("name" .== Text .+ "version" .== Maybe Text) -lspClientInfo = #name .== "lsp-client" .+ #version .== Just CURRENT_PACKAGE_VERSION +lspClientInfo :: ClientInfo +lspClientInfo = ClientInfo{_name = "lsp-client", _version = Just CURRENT_PACKAGE_VERSION} {- | Performs the initialisation handshake and synchronously waits for its completion. When the function completes, the session is initialised. -} -initialize :: Session () -initialize = do +initialize :: (MonadSession m) => Maybe Value -> m InitializeResult +initialize options = liftSession $ do pid <- liftIO getProcessID response <- request @@ -363,13 +371,13 @@ , _locale = Nothing , _rootPath = Nothing , _rootUri = InR Null - , _initializationOptions = Nothing - , _capabilities = fullCaps - , _trace = Just TraceValues_Off + , _initializationOptions = options + , _capabilities = fullLatestClientCaps + , _trace = Just TraceValue_Off , _workspaceFolders = Nothing } - asks initialized >>= liftIO . atomically . flip putTMVar (getResponseResult response) sendNotification SMethod_Initialized InitializedParams + pure $ getResponseResult response {- | /Creates/ a new text document. This is different from 'openDoc' as it sends a @workspace/didChangeWatchedFiles@ notification letting the server @@ -380,15 +388,16 @@ the server that one does exist. -} createDoc - :: FilePath + :: (MonadSession m) + => FilePath -- ^ The path to the document to open, __relative to the root directory__. - -> Text - -- ^ The text document's language identifier, e.g. @"haskell"@. + -> LanguageKind + -- ^ The text document's language -> Text -- ^ The content of the text document to create. - -> Session TextDocumentIdentifier + -> m TextDocumentIdentifier -- ^ The identifier of the document just created. -createDoc file language contents = do +createDoc file language contents = liftSession $ do serverCaps <- asks serverCapabilities >>= liftIO . readTVarIO clientCaps <- asks clientCapabilities rootDir <- asks rootDir @@ -399,84 +408,114 @@ regs :: [TRegistration 'Method_WorkspaceDidChangeWatchedFiles] regs = concatMap pred $ HashMap.elems serverCaps watchHits :: FileSystemWatcher -> Bool - watchHits (FileSystemWatcher (GlobPattern (InL (Pattern pattern))) kind) = - fileMatches (Text.unpack pattern) && maybe True containsCreate kind + watchHits FileSystemWatcher{_globPattern = GlobPattern (InL (Pattern pattern)), _kind} = + fileMatches (Text.unpack pattern) && maybe True containsCreate _kind watchHits _ = False fileMatches :: String -> Bool fileMatches pattern = Glob.match (Glob.compile pattern) (if isAbsolute pattern then absFile else file) regHits :: TRegistration 'Method_WorkspaceDidChangeWatchedFiles -> Bool - regHits reg = any watchHits $ reg ^. registerOptions . _Just . watchers + regHits reg = any watchHits $ reg ^. LSP.registerOptions . _Just . LSP.watchers clientCapsSupports = clientCaps - ^? workspace + ^? LSP.workspace . _Just - . didChangeWatchedFiles + . LSP.didChangeWatchedFiles . _Just - . dynamicRegistration + . LSP.dynamicRegistration . _Just - == Just True + == Just True shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs - when shouldSend - $ sendNotification SMethod_WorkspaceDidChangeWatchedFiles - $ DidChangeWatchedFilesParams - [FileEvent (filePathToUri $ rootDir file) FileChangeType_Created] + when shouldSend $ + sendNotification + SMethod_WorkspaceDidChangeWatchedFiles + DidChangeWatchedFilesParams + { _changes = + [ FileEvent + { _type_ = FileChangeType_Created + , _uri = filePathToUri $ rootDir file + } + ] + } openDoc' file language contents {- | Opens a text document that /exists on disk/, and sends a @textDocument/didOpen@ notification to the server. -} -openDoc :: FilePath -> Text -> Session TextDocumentIdentifier -openDoc file language = do +openDoc :: (MonadSession m) => FilePath -> LanguageKind -> m TextDocumentIdentifier +openDoc file language = liftSession $ do rootDir <- asks rootDir - let fp = rootDir file - contents <- liftIO $ Text.readFile fp + contents <- liftIO . Text.readFile $ rootDir file openDoc' file language contents {- | This is a variant of `openDoc` that takes the file content as an argument. Use this is the file exists /outside/ of the current workspace. -} -openDoc' :: FilePath -> Text -> Text -> Session TextDocumentIdentifier -openDoc' file language contents = do +openDoc' :: (MonadSession m) => FilePath -> LanguageKind -> Text -> m TextDocumentIdentifier +openDoc' file language contents = liftSession $ do rootDir <- asks rootDir - let fp = rootDir file - uri = filePathToUri fp - item = TextDocumentItem uri language 0 contents - sendNotification SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams item) - pure $ TextDocumentIdentifier uri + let _uri = filePathToUri $ rootDir file + sendNotification + SMethod_TextDocumentDidOpen + DidOpenTextDocumentParams + { _textDocument = + TextDocumentItem + { _text = contents + , _languageId = language + , _version = 0 + , _uri + } + } + pure TextDocumentIdentifier{..} -- | Closes a text document and sends a @textDocument/didClose@ notification to the server. -closeDoc :: TextDocumentIdentifier -> Session () -closeDoc docId = do - let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) - sendNotification SMethod_TextDocumentDidClose params +closeDoc :: (MonadSession m) => TextDocumentIdentifier -> m () +closeDoc docId = + liftSession $ + sendNotification + SMethod_TextDocumentDidClose + DidCloseTextDocumentParams + { _textDocument = + TextDocumentIdentifier + { _uri = docId ^. LSP.uri + } + } -- | Changes a text document and sends a @textDocument/didChange@ notification to the server. -changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () -changeDoc docId changes = do - verDoc <- getVersionedDoc docId - let params = DidChangeTextDocumentParams (verDoc & version +~ 1) changes - sendNotification SMethod_TextDocumentDidChange params +changeDoc :: (MonadSession m) => TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> m () +changeDoc docId _contentChanges = liftSession $ do + _textDocument <- getVersionedDoc docId <&> LSP.version +~ 1 + sendNotification SMethod_TextDocumentDidChange DidChangeTextDocumentParams{..} -- | Gets the Uri for the file relative to the session's root directory. -getDocUri :: FilePath -> Session Uri -getDocUri file = do +getDocUri :: (MonadSession m) => FilePath -> m Uri +getDocUri file = liftSession $ do rootDir <- asks rootDir - let fp = rootDir file - return $ filePathToUri fp + pure . filePathToUri $ rootDir file -- | The current text contents of a document. -documentContents :: TextDocumentIdentifier -> Session (Maybe Rope) -documentContents (TextDocumentIdentifier uri) = do +documentContents :: (MonadSession m) => TextDocumentIdentifier -> m (Maybe Rope) +documentContents TextDocumentIdentifier{_uri} = liftSession $ do vfs <- asks vfs >>= liftIO . readTVarIO - pure $ vfs ^? vfsMap . ix (toNormalizedUri uri) . to _file_text + pure $ vfs ^? vfsMap . ix (toNormalizedUri _uri) . to _file_text -- | Adds the current version to the document, as tracked by the session. -getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier -getVersionedDoc (TextDocumentIdentifier uri) = do +getVersionedDoc :: (MonadSession m) => TextDocumentIdentifier -> m VersionedTextDocumentIdentifier +getVersionedDoc TextDocumentIdentifier{_uri} = liftSession $ do vfs <- asks vfs >>= liftIO . readTVarIO - let ver = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion - pure $ VersionedTextDocumentIdentifier uri ver + let _version = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri _uri) . to virtualFileVersion + pure VersionedTextDocumentIdentifier{..} + +-- | Get all the versioned documents tracked by the session. +getAllVersionedDocs :: (MonadSession m) => m [VersionedTextDocumentIdentifier] +getAllVersionedDocs = liftSession $ do + vfs <- asks vfs >>= liftIO . readTVarIO + pure $ + Map.toList (vfs ^. vfsMap) <&> \(nuri, vf) -> + VersionedTextDocumentIdentifier + { _uri = fromNormalizedUri nuri + , _version = virtualFileVersion vf + } diff --git a/test/Language/LSP/ClientSpec.hs b/test/Language/LSP/ClientSpec.hs --- a/test/Language/LSP/ClientSpec.hs +++ b/test/Language/LSP/ClientSpec.hs @@ -1,8 +1,7 @@ module Language.LSP.ClientSpec where import Control.Arrow ((>>>)) -import Control.Concurrent.STM.TVar.Extra (writeTVarIO) -import Control.Exception +import Control.Exception (AssertionFailed (..)) import Control.Lens ((^.)) import Control.Monad import Control.Monad.Extra (whenMaybeM, whileJustM, whileM) @@ -14,7 +13,6 @@ import Data.ByteString.Lazy qualified as LazyByteString import Data.Coerce (coerce) import Data.Maybe (fromJust) -import Data.Row import Data.String (IsString) import Data.Tuple.Extra (thd3) import Language.LSP.Client @@ -25,13 +23,12 @@ import Language.LSP.Protocol.Lens qualified as LSP import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import System.IO import System.Process (createPipe) import Test.Hspec hiding (shouldReturn) import Test.Hspec qualified as Hspec import Test.Hspec.QuickCheck import Test.QuickCheck -import UnliftIO (MonadIO (..), MonadUnliftIO, fromEither, newTVarIO, race, readTVarIO) +import UnliftIO import UnliftIO.Concurrent import Prelude hiding (log) @@ -39,9 +36,9 @@ shouldReturn a expected = a >>= liftIO . flip Hspec.shouldBe expected withTimeout :: forall m a. (MonadUnliftIO m) => Int -> m a -> m a -withTimeout delay a = fromEither =<< race timeout a +withTimeout delay = fromEither <=< race t where - timeout = do + t = do threadDelay delay pure $ AssertionFailed "Timeout exceeded" @@ -134,6 +131,9 @@ getAvailableContents :: Handle -> IO ByteString getAvailableContents h = whileJustM $ whenMaybeM (hReady h) (hGetSome h defaultChunkSize) +writeTVarIO :: TVar a -> a -> IO () +writeTVarIO = (atomically .) . writeTVar + spec :: Spec spec = do prop "concurrently handles actions and server messages" $ again $ do @@ -176,7 +176,7 @@ LSP.documentContents doc `shouldReturn` Just "" let content :: (IsString s) => s content = "foo\n\nbar" - changeDoc doc [TextDocumentContentChangeEvent $ InR $ #text .== content] + changeDoc doc [TextDocumentContentChangeEvent $ InR TextDocumentContentChangeWholeDocument{_text = content}] LSP.documentContents doc `shouldReturn` Just content closeDoc doc LSP.documentContents doc `shouldReturn` Nothing