{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-|
-Module : Language.Haskell.LSP.Test
+Module : Language.LSP.Test
Description : A functional testing framework for LSP servers.
Maintainer : luke_lau@icloud.com
Stability : experimental
Provides the framework to start functionally testing
<https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>.
-You should import "Language.Haskell.LSP.Types" alongside this.
+You should import "Language.LSP.Types" alongside this.
-}
-module Language.Haskell.LSP.Test
+module Language.LSP.Test
(
-- * Sessions
Session
, runSession
- -- ** Config
, runSessionWithConfig
+ , runSessionWithHandles
+ -- ** Config
, SessionConfig(..)
, defaultConfig
, C.fullCaps
-- ** Exceptions
- , module Language.Haskell.LSP.Test.Exceptions
+ , module Language.LSP.Test.Exceptions
, withTimeout
-- * Sending
, request
, sendNotification
, sendResponse
-- * Receving
- , module Language.Haskell.LSP.Test.Parsing
+ , module Language.LSP.Test.Parsing
-- * Utilities
-- | Quick helper functions for common tasks.
-- ** References
, getReferences
-- ** Definitions
+ , getDeclarations
, getDefinitions
, getTypeDefinitions
+ , getImplementations
-- ** Renaming
, rename
-- ** Hover
import Control.Monad
import Control.Monad.IO.Class
import Control.Exception
-import Control.Lens hiding ((.=), List)
+import Control.Lens hiding ((.=), List, Empty)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.HashMap.Strict as HashMap
import Data.List
import Data.Maybe
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens hiding
+import Language.LSP.Types
+import Language.LSP.Types.Lens hiding
(id, capabilities, message, executeCommand, applyEdit, rename)
-import qualified Language.Haskell.LSP.Types.Lens as LSP
-import qualified Language.Haskell.LSP.Types.Capabilities as C
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.VFS
-import Language.Haskell.LSP.Test.Compat
-import Language.Haskell.LSP.Test.Decoding
-import Language.Haskell.LSP.Test.Exceptions
-import Language.Haskell.LSP.Test.Parsing
-import Language.Haskell.LSP.Test.Session
-import Language.Haskell.LSP.Test.Server
+import qualified Language.LSP.Types.Lens as LSP
+import qualified Language.LSP.Types.Capabilities as C
+import Language.LSP.VFS
+import Language.LSP.Test.Compat
+import Language.LSP.Test.Decoding
+import Language.LSP.Test.Exceptions
+import Language.LSP.Test.Parsing
+import Language.LSP.Test.Session
+import Language.LSP.Test.Server
import System.Environment
import System.IO
import System.Directory
import System.FilePath
+import System.Process (ProcessHandle)
import qualified System.FilePath.Glob as Glob
-- | Starts a new session.
-- > diags <- waitForDiagnostics
-- > let pos = Position 12 5
-- > params = TextDocumentPositionParams doc
--- > hover <- request TextDocumentHover params
+-- > hover <- request STextdocumentHover params
runSession :: String -- ^ The command to run the server.
-> C.ClientCapabilities -- ^ The capabilities that the client should declare.
-> FilePath -- ^ The filepath to the root directory for the session.
-> Session a -- ^ The session to run.
-> IO a
runSessionWithConfig config' serverExe caps rootDir session = do
+ config <- envOverrideConfig config'
+ withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
+ runSessionWithHandles' (Just serverProc) serverIn serverOut config caps rootDir session
+
+-- | Starts a new session, using the specified handles to communicate with the
+-- server. You can use this to host the server within the same process.
+-- An example with lsp might look like:
+--
+-- > (hinRead, hinWrite) <- createPipe
+-- > (houtRead, houtWrite) <- createPipe
+-- >
+-- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition
+-- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do
+-- > -- ...
+runSessionWithHandles :: Handle -- ^ The input handle
+ -> Handle -- ^ The output handle
+ -> SessionConfig
+ -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
+ -> FilePath -- ^ The filepath to the root directory for the session.
+ -> Session a -- ^ The session to run.
+ -> IO a
+runSessionWithHandles = runSessionWithHandles' Nothing
+
+
+runSessionWithHandles' :: Maybe ProcessHandle
+ -> Handle -- ^ The input handle
+ -> Handle -- ^ The output handle
+ -> SessionConfig
+ -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
+ -> FilePath -- ^ The filepath to the root directory for the session.
+ -> Session a -- ^ The session to run.
+ -> IO a
+runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir session = do
pid <- getCurrentProcessID
absRootDir <- canonicalizePath rootDir
config <- envOverrideConfig config'
- let initializeParams = InitializeParams (Just pid)
+ let initializeParams = InitializeParams Nothing
+ (Just pid)
+ (Just lspTestClientInfo)
(Just $ T.pack absRootDir)
(Just $ filePathToUri absRootDir)
Nothing
caps
(Just TraceOff)
- Nothing
- withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
- runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
+ (List <$> initialWorkspaceFolders config)
+ runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
-- Wrap the session around initialize and shutdown calls
- -- initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
- initReqId <- sendRequest Initialize initializeParams
+ initReqId <- sendRequest SInitialize initializeParams
-- Because messages can be sent in between the request and response,
-- collect them and then...
- (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId)
+ (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId)
case initRspMsg ^. LSP.result of
Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error)
initRspVar <- initRsp <$> ask
liftIO $ putMVar initRspVar initRspMsg
- sendNotification Initialized InitializedParams
+ sendNotification SInitialized (Just InitializedParams)
case lspConfig config of
- Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
+ Just cfg -> sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
Nothing -> return ()
-- ... relay them back to the user Session so they can match on them!
where
-- | Asks the server to shutdown and exit politely
exitServer :: Session ()
- exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
+ exitServer = request_ SShutdown Empty >> sendNotification SExit Empty
-- | Listens to the server output until the shutdown ack,
-- makes sure it matches the record and signals any semaphores
listenServer serverOut context = do
msgBytes <- getNextMessage serverOut
- reqMap <- readMVar $ requestMap context
-
- let msg = decodeFromServerMsg reqMap msgBytes
+ msg <- modifyMVar (requestMap context) $ \reqMap ->
+ pure $ decodeFromServerMsg reqMap msgBytes
writeChan (messageChan context) (ServerMessage msg)
case msg of
- (RspShutdown _) -> return ()
+ (FromServerRsp SShutdown _) -> return ()
_ -> listenServer serverOut context
-- | Is this message allowed to be sent by the server between the intialize
-- request and response?
-- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize
checkLegalBetweenMessage :: FromServerMessage -> Session ()
- checkLegalBetweenMessage (NotShowMessage _) = pure ()
- checkLegalBetweenMessage (NotLogMessage _) = pure ()
- checkLegalBetweenMessage (NotTelemetry _) = pure ()
- checkLegalBetweenMessage (ReqShowMessage _) = pure ()
+ checkLegalBetweenMessage (FromServerMess SWindowShowMessage _) = pure ()
+ checkLegalBetweenMessage (FromServerMess SWindowLogMessage _) = pure ()
+ checkLegalBetweenMessage (FromServerMess STelemetryEvent _) = pure ()
+ checkLegalBetweenMessage (FromServerMess SWindowShowMessageRequest _) = pure ()
checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg)
-- | Check environment variables to override the config
-- and returns the new content
getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
getDocumentEdit doc = do
- req <- message :: Session ApplyWorkspaceEditRequest
+ req <- message SWorkspaceApplyEdit
unless (checkDocumentChanges req || checkChanges req) $
liftIO $ throw (IncorrectApplyEditRequest (show req))
documentContents doc
where
- checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
checkDocumentChanges req =
let changes = req ^. params . edit . documentChanges
maybeDocs = fmap (fmap (^. textDocument . uri)) changes
in case maybeDocs of
Just docs -> (doc ^. uri) `elem` docs
Nothing -> False
- checkChanges :: ApplyWorkspaceEditRequest -> Bool
checkChanges req =
let mMap = req ^. params . edit . changes
in maybe False (HashMap.member (doc ^. uri)) mMap
-- | Sends a request to the server and waits for its response.
-- Will skip any messages in between the request and the response
-- @
--- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
+-- rsp <- request STextDocumentDocumentSymbol params
-- @
-- Note: will skip any messages in between the request and the response.
-request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
-request m = sendRequest m >=> skipManyTill anyMessage . responseForId
+request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m)
+request m = sendRequest m >=> skipManyTill anyMessage . responseForId m
-- | The same as 'sendRequest', but discard the response.
-request_ :: ToJSON params => ClientMethod -> params -> Session ()
-request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
+request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session ()
+request_ p = void . request p
-- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
sendRequest
- :: ToJSON params
- => ClientMethod -- ^ The request method.
- -> params -- ^ The request parameters.
- -> Session LspId -- ^ The id of the request that was sent.
+ :: SClientMethod m -- ^ The request method.
+ -> MessageParams m -- ^ The request parameters.
+ -> Session (LspId m) -- ^ The id of the request that was sent.
sendRequest method params = do
- id <- curReqId <$> get
- modify $ \c -> c { curReqId = nextId id }
+ idn <- curReqId <$> get
+ modify $ \c -> c { curReqId = idn+1 }
+ let id = IdInt idn
- let req = RequestMessage' "2.0" id method params
+ let mess = RequestMessage "2.0" id method params
-- Update the request map
reqMap <- requestMap <$> ask
liftIO $ modifyMVar_ reqMap $
- \r -> return $ updateRequestMap r id method
+ \r -> return $ fromJust $ updateRequestMap r id method
- sendMessage req
+ ~() <- case splitClientMethod method of
+ IsClientReq -> sendMessage mess
+ IsClientEither -> sendMessage $ ReqMess mess
return id
- where nextId (IdInt i) = IdInt (i + 1)
- nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
-
--- | A custom type for request message that doesn't
--- need a response type, allows us to infer the request
--- message type without using proxies.
-data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
-
-instance ToJSON a => ToJSON (RequestMessage' a) where
- toJSON (RequestMessage' rpc id method params) =
- object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
-
-
-- | Sends a notification to the server.
-sendNotification :: ToJSON a
- => ClientMethod -- ^ The notification method.
- -> a -- ^ The notification parameters.
+sendNotification :: SClientMethod (m :: Method FromClient Notification) -- ^ The notification method.
+ -> MessageParams m -- ^ The notification parameters.
-> Session ()
-
-- Open a virtual file if we send a did open text document notification
-sendNotification TextDocumentDidOpen params = do
- let params' = fromJust $ decode $ encode params
- n :: DidOpenTextDocumentNotification
- n = NotificationMessage "2.0" TextDocumentDidOpen params'
+sendNotification STextDocumentDidOpen params = do
+ let n = NotificationMessage "2.0" STextDocumentDidOpen params
oldVFS <- vfs <$> get
let (newVFS,_) = openVFS oldVFS n
modify (\s -> s { vfs = newVFS })
sendMessage n
-- Close a virtual file if we send a close text document notification
-sendNotification TextDocumentDidClose params = do
- let params' = fromJust $ decode $ encode params
- n :: DidCloseTextDocumentNotification
- n = NotificationMessage "2.0" TextDocumentDidClose params'
+sendNotification STextDocumentDidClose params = do
+ let n = NotificationMessage "2.0" STextDocumentDidClose params
oldVFS <- vfs <$> get
let (newVFS,_) = closeVFS oldVFS n
modify (\s -> s { vfs = newVFS })
sendMessage n
-sendNotification TextDocumentDidChange params = do
- let params' = fromJust $ decode $ encode params
- n :: DidChangeTextDocumentNotification
- n = NotificationMessage "2.0" TextDocumentDidChange params'
+sendNotification STextDocumentDidChange params = do
+ let n = NotificationMessage "2.0" STextDocumentDidChange params
oldVFS <- vfs <$> get
let (newVFS,_) = changeFromClientVFS oldVFS n
modify (\s -> s { vfs = newVFS })
sendMessage n
-sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
+sendNotification method params =
+ case splitClientMethod method of
+ IsClientNot -> sendMessage (NotificationMessage "2.0" method params)
+ IsClientEither -> sendMessage (NotMess $ NotificationMessage "2.0" method params)
-- | Sends a response to the server.
-sendResponse :: ToJSON a => ResponseMessage a -> Session ()
+sendResponse :: ToJSON (ResponseResult m) => ResponseMessage m -> Session ()
sendResponse = sendMessage
-- | Returns the initialize response that was received from the server.
-- The initialize requests and responses are not included the session,
-- so if you need to test it use this.
-initializeResponse :: Session InitializeResponse
+initializeResponse :: Session (ResponseMessage Initialize)
initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
-- | /Creates/ a new text document. This is different from 'openDoc'
rootDir <- asks rootDir
caps <- asks sessionCapabilities
absFile <- liftIO $ canonicalizePath (rootDir </> file)
- let regs = filter (\r -> r ^. method == WorkspaceDidChangeWatchedFiles) $
- Map.elems dynCaps
+ let pred :: SomeRegistration -> [Registration WorkspaceDidChangeWatchedFiles]
+ pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r]
+ pred _ = mempty
+ regs = concatMap pred $ Map.elems dynCaps
watchHits :: FileSystemWatcher -> Bool
watchHits (FileSystemWatcher pattern kind) =
-- If WatchKind is exlcuded, defaults to all true as per spec
createHits (WatchKind create _ _) = create
- regHits :: Registration -> Bool
- regHits reg = isJust $ do
- opts <- reg ^. registerOptions
- fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of
- Success x -> Just x
- Error _ -> Nothing
- if foldl' (\acc w -> acc || watchHits w) False (fileWatchOpts ^. watchers)
- then Just ()
- else Nothing
+ regHits :: Registration WorkspaceDidChangeWatchedFiles -> Bool
+ regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . watchers)
clientCapsSupports =
caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just
shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs
when shouldSend $
- sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
+ sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
List [ FileEvent (filePathToUri (rootDir </> file)) FcCreated ]
openDoc' file languageId contents
let fp = rootDir context </> file
uri = filePathToUri fp
item = TextDocumentItem uri (T.pack languageId) 0 contents
- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
+ sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item)
pure $ TextDocumentIdentifier uri
-- | Closes a text document and sends a textDocument/didOpen notification to the server.
closeDoc :: TextDocumentIdentifier -> Session ()
closeDoc docId = do
let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
- sendNotification TextDocumentDidClose params
+ sendNotification STextDocumentDidClose params
-- | Changes a text document and sends a textDocument/didOpen notification to the server.
changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
changeDoc docId changes = do
verDoc <- getVersionedDoc docId
let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
- sendNotification TextDocumentDidChange params
+ sendNotification STextDocumentDidChange params
-- | Gets the Uri for the file corrected to the session directory.
getDocUri :: FilePath -> Session Uri
-- | Waits for diagnostics to be published and returns them.
waitForDiagnostics :: Session [Diagnostic]
waitForDiagnostics = do
- diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
+ diagsNot <- skipManyTill anyMessage (message STextDocumentPublishDiagnostics)
let (List diags) = diagsNot ^. params . LSP.diagnostics
return diags
-- | The same as 'waitForDiagnostics', but will only match a specific
--- 'Language.Haskell.LSP.Types._source'.
+-- 'Language.LSP.Types._source'.
waitForDiagnosticsSource :: String -> Session [Diagnostic]
waitForDiagnosticsSource src = do
diags <- waitForDiagnostics
-- returned.
noDiagnostics :: Session ()
noDiagnostics = do
- diagsNot <- message :: Session PublishDiagnosticsNotification
+ diagsNot <- message STextDocumentPublishDiagnostics
when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
-- | Returns the symbols in a document.
getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
getDocumentSymbols doc = do
- ResponseMessage _ rspLid res <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
+ ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)
case res of
- Right (DSDocumentSymbols (List xs)) -> return (Left xs)
- Right (DSSymbolInformation (List xs)) -> return (Right xs)
- Left err -> throw (UnexpectedResponseError rspLid err)
+ Right (InL (List xs)) -> return (Left xs)
+ Right (InR (List xs)) -> return (Right xs)
+ Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err)
-- | Returns the code actions in the specified range.
-getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
+getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]
getCodeActions doc range = do
ctx <- getCodeActionContext doc
- rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
+ rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx)
case rsp ^. result of
Right (List xs) -> return xs
- Left error -> throw (UnexpectedResponseError (rsp ^. LSP.id) error)
+ Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) error)
-- | Returns all the code actions in a document by
-- querying the code actions at each of the current
-- diagnostics' positions.
-getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
+getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction]
getAllCodeActions doc = do
ctx <- getCodeActionContext doc
foldM (go ctx) [] =<< getCurrentDiagnostics doc
where
- go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
+ go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction]
go ctx acc diag = do
- ResponseMessage _ rspLid res <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
+ ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx)
case res of
- Left e -> throw (UnexpectedResponseError rspLid e)
+ Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)
Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)
getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
executeCommand :: Command -> Session ()
executeCommand cmd = do
let args = decode $ encode $ fromJust $ cmd ^. arguments
- execParams = ExecuteCommandParams (cmd ^. command) args Nothing
- request_ WorkspaceExecuteCommand execParams
+ execParams = ExecuteCommandParams Nothing (cmd ^. command) args
+ void $ sendRequest SWorkspaceExecuteCommand execParams
-- | Executes a code action.
-- Matching with the specification, if a code action
where handleEdit :: WorkspaceEdit -> Session ()
handleEdit e =
-- Its ok to pass in dummy parameters here as they aren't used
- let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
- in updateState (ReqApplyWorkspaceEdit req)
+ let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e)
+ in updateState (FromServerMess SWorkspaceApplyEdit req)
-- | Adds the current version to the document, as tracked by the session.
getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
caps <- asks sessionCapabilities
let supportsDocChanges = fromMaybe False $ do
- let mWorkspace = C._workspace caps
+ let mWorkspace = caps ^. LSP.workspace
C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
- C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
+ C.WorkspaceEditClientCapabilities mDocChanges _ _ <- mEdit
mDocChanges
let wEdit = if supportsDocChanges
let changes = HashMap.singleton (doc ^. uri) (List [edit])
in WorkspaceEdit (Just changes) Nothing
- let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
- updateState (ReqApplyWorkspaceEdit req)
+ let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
+ updateState (FromServerMess SWorkspaceApplyEdit req)
-- version may have changed
getVersionedDoc doc
-- | Returns the completions for the position in the document.
getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
getCompletions doc pos = do
- rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)
+ rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing)
case getResponseResult rsp of
- Completions (List items) -> return items
- CompletionList (CompletionListType _ (List items)) -> return items
+ InL (List items) -> return items
+ InR (CompletionList _ (List items)) -> return items
-- | Returns the references for the position in the document.
getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
-> Position -- ^ The position to lookup.
-> Bool -- ^ Whether to include declarations as references.
- -> Session [Location] -- ^ The locations of the references.
+ -> Session (List Location) -- ^ The locations of the references.
getReferences doc pos inclDecl =
let ctx = ReferenceContext inclDecl
- params = ReferenceParams doc pos ctx Nothing
- in getResponseResult <$> request TextDocumentReferences params
+ params = ReferenceParams doc pos Nothing Nothing ctx
+ in getResponseResult <$> request STextDocumentReferences params
+
+-- | Returns the declarations(s) for the term at the specified position.
+getDeclarations :: TextDocumentIdentifier -- ^ The document the term is in.
+ -> Position -- ^ The position the term is at.
+ -> Session ([Location] |? [LocationLink])
+getDeclarations = getDeclarationyRequest STextDocumentDeclaration DeclarationParams
-- | Returns the definition(s) for the term at the specified position.
getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
-> Position -- ^ The position the term is at.
- -> Session [Location] -- ^ The location(s) of the definitions
-getDefinitions doc pos = do
- let params = TextDocumentPositionParams doc pos Nothing
- rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
- case getResponseResult rsp of
- SingleLoc loc -> pure [loc]
- MultiLoc locs -> pure locs
+ -> Session ([Location] |? [LocationLink])
+getDefinitions = getDeclarationyRequest STextDocumentDefinition DefinitionParams
-- | Returns the type definition(s) for the term at the specified position.
getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
-> Position -- ^ The position the term is at.
- -> Session [Location] -- ^ The location(s) of the definitions
-getTypeDefinitions doc pos = do
- let params = TextDocumentPositionParams doc pos Nothing
- rsp <- request TextDocumentTypeDefinition params :: Session TypeDefinitionResponse
+ -> Session ([Location] |? [LocationLink])
+getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams
+
+-- | Returns the type definition(s) for the term at the specified position.
+getImplementations :: TextDocumentIdentifier -- ^ The document the term is in.
+ -> Position -- ^ The position the term is at.
+ -> Session ([Location] |? [LocationLink])
+getImplementations = getDeclarationyRequest STextDocumentImplementation ImplementationParams
+
+
+getDeclarationyRequest :: (ResponseResult m ~ (Location |? (List Location |? List LocationLink)))
+ => SClientMethod m
+ -> (TextDocumentIdentifier
+ -> Position
+ -> Maybe ProgressToken
+ -> Maybe ProgressToken
+ -> MessageParams m)
+ -> TextDocumentIdentifier
+ -> Position
+ -> Session ([Location] |? [LocationLink])
+getDeclarationyRequest method paramCons doc pos = do
+ let params = paramCons doc pos Nothing Nothing
+ rsp <- request method params
case getResponseResult rsp of
- SingleLoc loc -> pure [loc]
- MultiLoc locs -> pure locs
+ InL loc -> pure (InL [loc])
+ InR (InL (List locs)) -> pure (InL locs)
+ InR (InR (List locLinks)) -> pure (InR locLinks)
-- | Renames the term at the specified position.
rename :: TextDocumentIdentifier -> Position -> String -> Session ()
rename doc pos newName = do
- let params = RenameParams doc pos (T.pack newName) Nothing
- rsp <- request TextDocumentRename params :: Session RenameResponse
+ let params = RenameParams doc pos Nothing (T.pack newName)
+ rsp <- request STextDocumentRename params
let wEdit = getResponseResult rsp
- req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
- updateState (ReqApplyWorkspaceEdit req)
+ req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
+ updateState (FromServerMess SWorkspaceApplyEdit req)
-- | Returns the hover information at the specified position.
getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
getHover doc pos =
- let params = TextDocumentPositionParams doc pos Nothing
- in getResponseResult <$> request TextDocumentHover params
+ let params = HoverParams doc pos Nothing
+ in getResponseResult <$> request STextDocumentHover params
-- | Returns the highlighted occurences of the term at the specified position
-getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
+getHighlights :: TextDocumentIdentifier -> Position -> Session (List DocumentHighlight)
getHighlights doc pos =
- let params = TextDocumentPositionParams doc pos Nothing
- in getResponseResult <$> request TextDocumentDocumentHighlight params
+ let params = DocumentHighlightParams doc pos Nothing Nothing
+ in getResponseResult <$> request STextDocumentDocumentHighlight params
-- | Checks the response for errors and throws an exception if needed.
-- Returns the result if successful.
-getResponseResult :: ResponseMessage a -> a
+getResponseResult :: ResponseMessage m -> ResponseResult m
getResponseResult rsp =
case rsp ^. result of
Right x -> x
- Left err -> throw $ UnexpectedResponseError (rsp ^. LSP.id) err
+ Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) err
-- | Applies formatting to the specified document.
formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
formatDoc doc opts = do
- let params = DocumentFormattingParams doc opts Nothing
- edits <- getResponseResult <$> request TextDocumentFormatting params
+ let params = DocumentFormattingParams Nothing doc opts
+ edits <- getResponseResult <$> request STextDocumentFormatting params
applyTextEdits doc edits
-- | Applies formatting to the specified range in a document.
formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
formatRange doc opts range = do
- let params = DocumentRangeFormattingParams doc range opts Nothing
- edits <- getResponseResult <$> request TextDocumentRangeFormatting params
+ let params = DocumentRangeFormattingParams Nothing doc range opts
+ edits <- getResponseResult <$> request STextDocumentRangeFormatting params
applyTextEdits doc edits
applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
applyTextEdits doc edits =
let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
-- Send a dummy message to updateState so it can do bookkeeping
- req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
- in updateState (ReqApplyWorkspaceEdit req)
+ req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
+ in updateState (FromServerMess SWorkspaceApplyEdit req)
-- | Returns the code lenses for the specified document.
getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
getCodeLenses tId = do
- rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
+ rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId)
case getResponseResult rsp of
List res -> pure res
-- register during the 'Session'.
--
-- @since 0.11.0.0
-getRegisteredCapabilities :: Session [Registration]
+getRegisteredCapabilities :: Session [SomeRegistration]
getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get
projects / lsp-test.git / blobdiff