- sendInitialize recH serverH = do
- headers <- getHeaders recH
- case read . init <$> lookup "Content-Length" headers of
- Nothing -> error "Failed to read the read the initialize request"
- Just size -> do
- message <- B.hGet recH size
- B.hPut serverH (addHeader message)
- -- bring the file back to the start for haskell-lsp
- hSeek recH AbsoluteSeek 0
-
-
-handlers :: Handle -> MVar () -> Handlers
-handlers serverH flag = def
- {
- -- Requests
- hoverHandler = Just request
- , completionHandler = Just request
- , completionResolveHandler = Just request
- , signatureHelpHandler = Just request
- , definitionHandler = Just request
- , referencesHandler = Just request
- , documentHighlightHandler = Just request
- , documentSymbolHandler = Just request
- , workspaceSymbolHandler = Just request
- , codeActionHandler = Just request
- , codeLensHandler = Just request
- , codeLensResolveHandler = Just request
- , documentFormattingHandler = Just request
- , documentRangeFormattingHandler = Just request
- , documentTypeFormattingHandler = Just request
- , renameHandler = Just request
- , documentLinkHandler = Just request
- , documentLinkResolveHandler = Just request
- , executeCommandHandler = Just request
- -- Notifications
- , didChangeConfigurationParamsHandler = Just notification
- , didOpenTextDocumentNotificationHandler = Just notification
- , didChangeTextDocumentNotificationHandler = Just notification
- , didCloseTextDocumentNotificationHandler = Just notification
- , didSaveTextDocumentNotificationHandler = Just notification
- , didChangeWatchedFilesNotificationHandler = Just notification
- , initializedHandler = Just notification
- , willSaveTextDocumentNotificationHandler = Just notification
- , cancelNotificationHandler = Just notification
- , responseHandler = Just notification
- }
+ isClientMsg (FromClient _ _) = True
+ isClientMsg _ = False
+
+ isServerMsg (FromServer _ _) = True
+ isServerMsg _ = False
+
+processClient
+ :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> FromClientMessage -> IO ()
+processClient serverH rspSema reqSema msg = case msg of
+ ReqInitialize m -> request m
+ ReqShutdown m -> request m
+ ReqHover m -> request m
+ ReqCompletion m -> request m
+ ReqCompletionItemResolve m -> request m
+ ReqSignatureHelp m -> request m
+ ReqDefinition m -> request m
+ ReqFindReferences m -> request m
+ ReqDocumentHighlights m -> request m
+ ReqDocumentSymbols m -> request m
+ ReqWorkspaceSymbols m -> request m
+ ReqCodeAction m -> request m
+ ReqCodeLens m -> request m
+ ReqCodeLensResolve m -> request m
+ ReqDocumentFormatting m -> request m
+ ReqDocumentRangeFormatting m -> request m
+ ReqDocumentOnTypeFormatting m -> request m
+ ReqRename m -> request m
+ ReqExecuteCommand m -> request m
+ ReqDocumentLink m -> request m
+ ReqDocumentLinkResolve m -> request m
+ ReqWillSaveWaitUntil m -> request m
+ RspApplyWorkspaceEdit m -> response m
+ RspFromClient m -> response m
+ NotInitialized m -> notification m
+ NotExit m -> notification m
+ NotCancelRequestFromClient m -> notification m
+ NotDidChangeConfiguration m -> notification m
+ NotDidOpenTextDocument m -> notification m
+ NotDidChangeTextDocument m -> notification m
+ NotDidCloseTextDocument m -> notification m
+ NotWillSaveTextDocument m -> notification m
+ NotDidSaveTextDocument m -> notification m
+ NotDidChangeWatchedFiles m -> notification m
+ UnknownFromClientMessage m ->
+ error $ "Unknown message was recorded from the client" ++ show m
+ where
+ -- TODO: May need to prevent premature exit notification being sent
+ notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
+ putStrLn "Will send exit notification soon"
+ threadDelay 10000000
+ B.hPut serverH $ addHeader (encode msg)
+ notification msg@(LSP.NotificationMessage _ m _) = do
+ B.hPut serverH $ addHeader (encode msg)
+
+ putStrLn $ "Sent a notification " ++ show m
+
+ request msg@(LSP.RequestMessage _ id m _) = do
+
+ when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
+
+ B.hPut serverH $ addHeader (encode msg)
+ putStrLn
+ $ "Sent a request id "
+ ++ show id
+ ++ ": "
+ ++ show m
+ ++ "\nWaiting for a response"
+
+ rspId <- takeMVar reqSema
+ when (LSP.responseId id /= rspId)
+ $ error
+ $ "Expected id "
+ ++ show id
+ ++ ", got "
+ ++ show rspId
+
+ response msg@(LSP.ResponseMessage _ id _ _) = do
+ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
+ reqId <- takeMVar rspSema
+ if LSP.responseId reqId /= id
+ then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
+ else do
+ B.hPut serverH $ addHeader (encode msg)
+ putStrLn $ "Sent response to request id " ++ show id
+
+-- | The internal monad for tests that can fail or pass,
+-- ending execution early.
+type Session = ReaderT (MVar Bool) IO
+
+-- TODO: Make return type polymoprhic more like error
+failSession :: String -> Session ()
+failSession reason = do
+ lift $ putStrLn reason
+ passVar <- ask
+ lift $ putMVar passVar False
+
+passSession :: Session ()
+passSession = do
+ passVar <- ask
+ lift $ putMVar passVar True
+
+-- | Listens to the server output, makes sure it matches the record and
+-- signals any semaphores
+listenServer
+ :: [FromServerMessage]
+ -> Handle
+ -> RequestMap
+ -> (MVar LSP.LspIdRsp, MVar LSP.LspId)
+ -> Session ()
+listenServer [] _ _ _ = passSession
+listenServer expectedMsgs h reqMap semas@(reqSema, rspSema) = do
+ msgBytes <- lift $ getNextMessage h
+
+ let actualMsg = decodeFromServerMsg reqMap msgBytes
+
+ lift $ print actualMsg
+
+ newExpectedMsgs <- case actualMsg of
+ ReqRegisterCapability m -> request actualMsg m
+ ReqApplyWorkspaceEdit m -> request actualMsg m
+ ReqShowMessage m -> request actualMsg m
+ ReqUnregisterCapability m -> request actualMsg m
+ RspInitialize m -> response actualMsg m
+ RspShutdown m -> response actualMsg m
+ RspHover m -> response actualMsg m
+ RspCompletion m -> response actualMsg m
+ RspCompletionItemResolve m -> response actualMsg m
+ RspSignatureHelp m -> response actualMsg m
+ RspDefinition m -> response actualMsg m
+ RspFindReferences m -> response actualMsg m
+ RspDocumentHighlights m -> response actualMsg m
+ RspDocumentSymbols m -> response actualMsg m
+ RspWorkspaceSymbols m -> response actualMsg m
+ RspCodeAction m -> response actualMsg m
+ RspCodeLens m -> response actualMsg m
+ RspCodeLensResolve m -> response actualMsg m
+ RspDocumentFormatting m -> response actualMsg m
+ RspDocumentRangeFormatting m -> response actualMsg m
+ RspDocumentOnTypeFormatting m -> response actualMsg m
+ RspRename m -> response actualMsg m
+ RspExecuteCommand m -> response actualMsg m
+ RspError m -> response actualMsg m
+ RspDocumentLink m -> response actualMsg m
+ RspDocumentLinkResolve m -> response actualMsg m
+ RspWillSaveWaitUntil m -> response actualMsg m
+ NotPublishDiagnostics m -> notification actualMsg m
+ NotLogMessage m -> notification actualMsg m
+ NotShowMessage m -> notification actualMsg m
+ NotTelemetry m -> notification actualMsg m
+ NotCancelRequestFromServer m -> notification actualMsg m
+
+ listenServer newExpectedMsgs h reqMap semas