, anySessionException
-- * Sending
, sendRequest
- , sendNotification
+ , sendRequest_
, sendRequest'
+ , sendNotification
+ , sendRequestMessage
, sendNotification'
, sendResponse
-- * Receving
, response
, anyNotification
, notification
+ , anyMessage
, loggingNotification
, publishDiagnosticsNotification
-- * Combinators
, satisfy
-- * Utilities
, initializeResponse
+ -- ** Documents
, openDoc
, documentContents
, getDocumentEdit
, getDocUri
- , noDiagnostics
+ -- ** Symbols
, getDocumentSymbols
- , getDiagnostics
+ -- ** Diagnostics
+ , waitForDiagnostics
+ , noDiagnostics
+ -- ** Commands
+ , executeCommand
+ -- ** Code Actions
+ , getAllCodeActions
+ , executeCodeAction
) where
import Control.Applicative
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Aeson
-import qualified Data.ByteString.Lazy.Char8 as B
import Data.Default
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import Data.Maybe
-import Language.Haskell.LSP.Types hiding (id, capabilities)
+import Language.Haskell.LSP.Types hiding (id, capabilities, error)
import qualified Language.Haskell.LSP.Types as LSP
+import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.VFS
import Language.Haskell.LSP.Test.Compat
import Language.Haskell.LSP.Test.Decoding
Nothing
(capabilities config)
(Just TraceOff)
- withServer serverExe $ \serverIn serverOut _ ->
+ withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
-- Wrap the session around initialize and shutdown calls
- sendRequest Initialize initializeParams
- initRspMsg <- response :: Session InitializeResponse
+ initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
-- | The current text contents of a document.
documentContents :: TextDocumentIdentifier -> Session T.Text
documentContents doc = do
- vfs' <- vfs <$> get
- let docUri = doc ^. uri
- file <- case Map.lookup docUri vfs' of
- Just file -> return file
- Nothing -> do
- openDoc (fromJust (uriToFilePath docUri)) ""
- newVfs <- vfs <$> get
- return $ newVfs Map.! docUri
+ vfs <- vfs <$> get
+ let file = vfs Map.! (doc ^. uri)
return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
-- | Parses an ApplyEditRequest, checks that it is for the passed document
let mMap = req ^. params . edit . changes
in maybe False (HashMap.member (doc ^. uri)) mMap
--- | Sends a request to the server.
---
+-- | Sends a request to the server and waits for its response.
-- @
--- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
--- TextDocumentDocumentSymbol
--- (DocumentSymbolParams docId)
+-- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
-- @
-sendRequest
- :: (ToJSON params)
- => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
- ClientMethod -- ^ The request method.
+-- Note: will skip any messages in between the request and the response.
+sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
+sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
+
+-- | Send a request to the server and wait for its response,
+-- but discard it.
+sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
+sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
+
+-- | Sends a request to the server without waiting on the response.
+sendRequest'
+ :: ToJSON params
+ => ClientMethod -- ^ The request method.
-> params -- ^ The request parameters.
-> Session LspId -- ^ The id of the request that was sent.
-sendRequest method params = do
+sendRequest' method params = do
id <- curReqId <$> get
modify $ \c -> c { curReqId = nextId id }
object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
-sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
-sendRequest' req = do
+sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
+sendRequestMessage req = do
-- Update the request map
reqMap <- requestMap <$> ask
liftIO $ modifyMVar_ reqMap $
sendResponse :: ToJSON a => ResponseMessage a -> Session ()
sendResponse = sendMessage
-sendMessage :: ToJSON a => a -> Session ()
-sendMessage msg = do
- h <- serverIn <$> ask
- liftIO $ B.hPut h $ addHeader (encode msg)
-
-- | 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.
let fp = rootDir context </> file
return $ filePathToUri fp
-getDiagnostics :: Session [Diagnostic]
-getDiagnostics = do
- diagsNot <- notification :: Session PublishDiagnosticsNotification
+waitForDiagnostics :: Session [Diagnostic]
+waitForDiagnostics = do
+ diagsNot <- skipManyTill anyMessage notification :: Session PublishDiagnosticsNotification
let (List diags) = diagsNot ^. params . LSP.diagnostics
return diags
when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
-- | Returns the symbols in a document.
-getDocumentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse
+getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
getDocumentSymbols doc = do
- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
- response
\ No newline at end of file
+ ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
+ maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
+ let (Just (List symbols)) = mRes
+ return symbols
+
+getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
+getAllCodeActions doc = do
+ curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
+ let ctx = CodeActionContext (List curDiags) Nothing
+
+ foldM (go ctx) [] curDiags
+
+ where
+ go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
+ go ctx acc diag = do
+ ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
+
+ case mErr of
+ Just e -> throw (UnexpectedResponseError rspLid e)
+ Nothing ->
+ let Just (List cmdOrCAs) = mRes
+ in return (acc ++ cmdOrCAs)
+
+executeCommand :: Command -> Session ()
+executeCommand cmd = do
+ let args = decode $ encode $ fromJust $ cmd ^. arguments
+ execParams = ExecuteCommandParams (cmd ^. command) args
+ sendRequest_ WorkspaceExecuteCommand execParams
+
+executeCodeAction :: CodeAction -> Session ()
+executeCodeAction action = do
+ maybe (return ()) handleEdit $ action ^. edit
+ maybe (return ()) executeCommand $ action ^. command
+
+ where handleEdit :: WorkspaceEdit -> Session ()
+ handleEdit e =
+ let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
+ in processMessage (ReqApplyWorkspaceEdit req)
\ No newline at end of file