{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
-- * Sessions
Session
, runSession
- -- ** Config
, runSessionWithConfig
+ , runSessionWithHandles
+ -- ** Config
, SessionConfig(..)
, defaultConfig
, C.fullCaps
-- ** 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 System.IO
import System.Directory
import System.FilePath
+import System.Process (ProcessHandle)
import qualified System.FilePath.Glob as Glob
-- | Starts a new 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
+
+
+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
+ 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 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)
where
-- | Asks the server to shutdown and exit politely
exitServer :: Session ()
- exitServer = request_ SShutdown (Nothing :: Maybe Value) >> sendNotification SExit (Just ExitParams)
+ exitServer = request_ SShutdown (Nothing :: Maybe Value) >> 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
let mMap = req ^. params . edit . changes
in maybe False (HashMap.member (doc ^. uri)) mMap
-message :: SServerMethod m -> Session (ServerMessage m)
-message = undefined -- TODO
-
-- | Sends a request to the server and waits for its response.
-- Will skip any messages in between the request and the response
-- @
-- @
-- Note: will skip any messages in between the request and the response.
request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m)
-request m = sendRequest m >=> skipManyTill anyMessage . responseForId
+request m = sendRequest m >=> skipManyTill anyMessage . responseForId m
-- | The same as 'sendRequest', but discard the response.
request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session ()
liftIO $ modifyMVar_ reqMap $
\r -> return $ fromJust $ updateRequestMap r id method
- let mkSession :: Session () -> Session ()
- mkSession x = x
-
- mkSession $ case splitClientMethod method of
+ ~() <- case splitClientMethod method of
IsClientReq -> sendMessage mess
IsClientEither -> sendMessage $ ReqMess mess
rootDir <- asks rootDir
caps <- asks sessionCapabilities
absFile <- liftIO $ canonicalizePath (rootDir </> file)
- let regs = filter (\r -> r ^. method == SomeClientMethod SWorkspaceDidChangeWatchedFiles) $
- 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
-- | Returns the symbols in a document.
getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
getDocumentSymbols doc = do
- ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
+ ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) :: Session DocumentSymbolsResponse
case res of
- Right (DSDocumentSymbols (List xs)) -> return (Left xs)
- Right (DSSymbolInformation (List xs)) -> return (Right xs)
+ Right (L (List xs)) -> return (Left xs)
+ Right (R (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 STextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
+ rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx)
case rsp ^. result of
Right (List xs) -> return xs
-- | 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 STextDocumentCodeAction (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 (SomeLspId $ fromJust rspLid) e)
executeCommand :: Command -> Session ()
executeCommand cmd = do
let args = decode $ encode $ fromJust $ cmd ^. arguments
- execParams = ExecuteCommandParams (cmd ^. command) args Nothing
+ execParams = ExecuteCommandParams Nothing (cmd ^. command) args
request_ SWorkspaceExecuteCommand execParams
-- | Executes 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) SWorkspaceApplyEdit (ApplyWorkspaceEditParams e)
+ 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.
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) SWorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
+ let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
updateState (FromServerMess SWorkspaceApplyEdit req)
-- version may have changed
-- | Returns the completions for the position in the document.
getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
getCompletions doc pos = do
- rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing 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
+ L (List items) -> return items
+ R (CompletionList _ (List items)) -> return items
-- | Returns the references for the position in the document.
getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
-> Session (List Location) -- ^ The locations of the references.
getReferences doc pos inclDecl =
let ctx = ReferenceContext inclDecl
- params = ReferenceParams doc pos ctx Nothing
+ 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 STextDocumentDefinition 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 STextDocumentTypeDefinition 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 :: (ResponseParams 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
+ L loc -> pure (L [loc])
+ R (L (List locs)) -> pure (L locs)
+ R (R (List locLinks)) -> pure (R 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
+ let params = RenameParams doc pos Nothing (T.pack newName)
rsp <- request STextDocumentRename params :: Session RenameResponse
let wEdit = getResponseResult rsp
- req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
+ 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 :: TextDocumentIdentifier -> Position -> Session Hover
getHover doc pos =
- let params = TextDocumentPositionParams doc pos Nothing
+ 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 (List DocumentHighlight)
getHighlights doc pos =
- let params = TextDocumentPositionParams doc pos Nothing
+ let params = DocumentHighlightParams doc pos Nothing Nothing
in getResponseResult <$> request STextDocumentDocumentHighlight params
-- | Checks the response for errors and throws an exception if needed.
-- | Applies formatting to the specified document.
formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
formatDoc doc opts = do
- let params = DocumentFormattingParams doc opts Nothing
+ 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
+ let params = DocumentRangeFormattingParams Nothing doc range opts
edits <- getResponseResult <$> request STextDocumentRangeFormatting params
applyTextEdits doc edits
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) SWorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
+ 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 STextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
+ rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId) :: Session CodeLensResponse
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