From: Luke Lau Date: Wed, 6 Jun 2018 21:06:08 +0000 (-0400) Subject: Start work on parser X-Git-Tag: 0.1.0.0~88 X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=208679fa3a42e2a81bc778218bab6376bd6f42d1 Start work on parser Move message case handlers to own module --- diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index 2e5969e..af51478 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -28,6 +28,7 @@ library , filepath , text , transformers + , parsec , process , directory , containers @@ -37,8 +38,10 @@ library else build-depends: unix other-modules: Language.Haskell.LSP.Test.Compat + Language.Haskell.LSP.Test.Decoding Language.Haskell.LSP.Test.Files Language.Haskell.LSP.Test.Parsing + Language.Haskell.LSP.Test.Messages ghc-options: -W test-suite tests diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index ce061e9..5c59417 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -49,7 +49,7 @@ import Language.Haskell.LSP.Test.Compat import System.IO import System.Directory import System.FilePath -import Language.Haskell.LSP.Test.Parsing +import Language.Haskell.LSP.Test.Decoding data SessionContext = SessionContext { diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs new file mode 100644 index 0000000..4e87115 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.LSP.Test.Decoding where + +import Prelude hiding ( id ) +import Data.Aeson +import Control.Lens +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Maybe +import System.IO +import Language.Haskell.LSP.Types + hiding ( error ) +import Language.Haskell.LSP.Messages +import qualified Data.HashMap.Strict as HM + +getAllMessages :: Handle -> IO [B.ByteString] +getAllMessages h = do + done <- hIsEOF h + if done + then return [] + else do + msg <- getNextMessage h + + (msg :) <$> getAllMessages h + +-- | Fetches the next message bytes based on +-- the Content-Length header +getNextMessage :: Handle -> IO B.ByteString +getNextMessage h = do + headers <- getHeaders h + case read . init <$> lookup "Content-Length" headers of + Nothing -> error "Couldn't read Content-Length header" + Just size -> B.hGet h size + +addHeader :: B.ByteString -> B.ByteString +addHeader content = B.concat + [ "Content-Length: " + , B.pack $ show $ B.length content + , "\r\n" + , "\r\n" + , content + ] + +getHeaders :: Handle -> IO [(String, String)] +getHeaders h = do + l <- hGetLine h + let (name, val) = span (/= ':') l + if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h + +type RequestMap = HM.HashMap LspId FromClientMessage + +getRequestMap :: [FromClientMessage] -> RequestMap +getRequestMap = foldl helper HM.empty + where + helper acc msg = case msg of + (ReqInitialize val) -> insert val msg acc + (ReqShutdown val) -> insert val msg acc + (ReqHover val) -> insert val msg acc + (ReqCompletion val) -> insert val msg acc + (ReqCompletionItemResolve val) -> insert val msg acc + (ReqSignatureHelp val) -> insert val msg acc + (ReqDefinition val) -> insert val msg acc + (ReqFindReferences val) -> insert val msg acc + (ReqDocumentHighlights val) -> insert val msg acc + (ReqDocumentSymbols val) -> insert val msg acc + (ReqWorkspaceSymbols val) -> insert val msg acc + (ReqCodeAction val) -> insert val msg acc + (ReqCodeLens val) -> insert val msg acc + (ReqCodeLensResolve val) -> insert val msg acc + (ReqDocumentFormatting val) -> insert val msg acc + (ReqDocumentRangeFormatting val) -> insert val msg acc + (ReqDocumentOnTypeFormatting val) -> insert val msg acc + (ReqRename val) -> insert val msg acc + (ReqExecuteCommand val) -> insert val msg acc + (ReqDocumentLink val) -> insert val msg acc + (ReqDocumentLinkResolve val) -> insert val msg acc + (ReqWillSaveWaitUntil val) -> insert val msg acc + _ -> acc + insert m = HM.insert (m ^. id) + +matchResponseMsgType :: FromClientMessage -> B.ByteString -> FromServerMessage +matchResponseMsgType req bytes = case req of + ReqInitialize _ -> RspInitialize $ fromJust $ decode bytes + ReqShutdown _ -> RspShutdown $ fromJust $ decode bytes + ReqHover _ -> RspHover $ fromJust $ decode bytes + ReqCompletion _ -> RspCompletion $ fromJust $ decode bytes + ReqCompletionItemResolve _ -> + RspCompletionItemResolve $ fromJust $ decode bytes + ReqSignatureHelp _ -> RspSignatureHelp $ fromJust $ decode bytes + ReqDefinition _ -> RspDefinition $ fromJust $ decode bytes + ReqFindReferences _ -> RspFindReferences $ fromJust $ decode bytes + ReqDocumentHighlights _ -> RspDocumentHighlights $ fromJust $ decode bytes + ReqDocumentSymbols _ -> RspDocumentSymbols $ fromJust $ decode bytes + ReqWorkspaceSymbols _ -> RspWorkspaceSymbols $ fromJust $ decode bytes + ReqCodeAction _ -> RspCodeAction $ fromJust $ decode bytes + ReqCodeLens _ -> RspCodeLens $ fromJust $ decode bytes + ReqCodeLensResolve _ -> RspCodeLensResolve $ fromJust $ decode bytes + ReqDocumentFormatting _ -> RspDocumentFormatting $ fromJust $ decode bytes + ReqDocumentRangeFormatting _ -> + RspDocumentRangeFormatting $ fromJust $ decode bytes + ReqDocumentOnTypeFormatting _ -> + RspDocumentOnTypeFormatting $ fromJust $ decode bytes + ReqRename _ -> RspRename $ fromJust $ decode bytes + ReqExecuteCommand _ -> RspExecuteCommand $ fromJust $ decode bytes + ReqDocumentLink _ -> RspDocumentLink $ fromJust $ decode bytes + ReqDocumentLinkResolve _ -> RspDocumentLinkResolve $ fromJust $ decode bytes + ReqWillSaveWaitUntil _ -> RspWillSaveWaitUntil $ fromJust $ decode bytes + x -> error $ "Not a request: " ++ show x + +decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage +decodeFromServerMsg reqMap bytes = + case HM.lookup "method" (fromJust $ decode bytes :: Object) of + Just methodStr -> case fromJSON methodStr of + Success method -> case method of + -- We can work out the type of the message + TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes + WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes + WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes + CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes + TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes + WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes + ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes + ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes + WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes + + Error e -> error e + + Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of + Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of + Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type + Nothing -> error "Couldn't match up response with request" + Nothing -> error "Couldn't decode message" \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Messages.hs b/src/Language/Haskell/LSP/Test/Messages.hs new file mode 100644 index 0000000..fd568c0 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Messages.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE RankNTypes #-} +module Language.Haskell.LSP.Test.Messages where + +import Data.Aeson +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types hiding (error) + +isServerResponse :: FromServerMessage -> Bool +isServerResponse (RspInitialize _) = True +isServerResponse (RspShutdown _) = True +isServerResponse (RspHover _) = True +isServerResponse (RspCompletion _) = True +isServerResponse (RspCompletionItemResolve _) = True +isServerResponse (RspSignatureHelp _) = True +isServerResponse (RspDefinition _) = True +isServerResponse (RspFindReferences _) = True +isServerResponse (RspDocumentHighlights _) = True +isServerResponse (RspDocumentSymbols _) = True +isServerResponse (RspWorkspaceSymbols _) = True +isServerResponse (RspCodeAction _) = True +isServerResponse (RspCodeLens _) = True +isServerResponse (RspCodeLensResolve _) = True +isServerResponse (RspDocumentFormatting _) = True +isServerResponse (RspDocumentRangeFormatting _) = True +isServerResponse (RspDocumentOnTypeFormatting _) = True +isServerResponse (RspRename _) = True +isServerResponse (RspExecuteCommand _) = True +isServerResponse (RspError _) = True +isServerResponse (RspDocumentLink _) = True +isServerResponse (RspDocumentLinkResolve _) = True +isServerResponse (RspWillSaveWaitUntil _) = True +isServerResponse _ = False + +isServerRequest :: FromServerMessage -> Bool +isServerRequest (ReqRegisterCapability _) = True +isServerRequest (ReqApplyWorkspaceEdit _) = True +isServerRequest (ReqShowMessage _) = True +isServerRequest (ReqUnregisterCapability _) = True +isServerRequest _ = False + +isServerNotification :: FromServerMessage -> Bool +isServerNotification (NotPublishDiagnostics _) = True +isServerNotification (NotLogMessage _) = True +isServerNotification (NotShowMessage _) = True +isServerNotification (NotTelemetry _) = True +isServerNotification (NotCancelRequestFromServer _) = True +isServerNotification _ = False + +handleServerMessage + :: forall a. + (forall b c . RequestMessage ServerMethod b c -> a) + -> (forall d . ResponseMessage d -> a) + -> (forall e . NotificationMessage ServerMethod e -> a) + -> FromServerMessage + -> a +handleServerMessage request response notification msg = case msg of + (ReqRegisterCapability m) -> request m + (ReqApplyWorkspaceEdit m) -> request m + (ReqShowMessage m) -> request m + (ReqUnregisterCapability m) -> request m + (RspInitialize m) -> response m + (RspShutdown m) -> response m + (RspHover m) -> response m + (RspCompletion m) -> response m + (RspCompletionItemResolve m) -> response m + (RspSignatureHelp m) -> response m + (RspDefinition m) -> response m + (RspFindReferences m) -> response m + (RspDocumentHighlights m) -> response m + (RspDocumentSymbols m) -> response m + (RspWorkspaceSymbols m) -> response m + (RspCodeAction m) -> response m + (RspCodeLens m) -> response m + (RspCodeLensResolve m) -> response m + (RspDocumentFormatting m) -> response m + (RspDocumentRangeFormatting m) -> response m + (RspDocumentOnTypeFormatting m) -> response m + (RspRename m) -> response m + (RspExecuteCommand m) -> response m + (RspError m) -> response m + (RspDocumentLink m) -> response m + (RspDocumentLinkResolve m) -> response m + (RspWillSaveWaitUntil m) -> response m + (NotPublishDiagnostics m) -> notification m + (NotLogMessage m) -> notification m + (NotShowMessage m) -> notification m + (NotTelemetry m) -> notification m + (NotCancelRequestFromServer m) -> notification m + +handleClientMessage + :: forall a. + (forall b c . (ToJSON b, ToJSON c) => RequestMessage ClientMethod b c -> a) + -> (forall d . ToJSON d => ResponseMessage d -> a) + -> (forall e . ToJSON e => NotificationMessage ClientMethod e -> a) + -> FromClientMessage + -> a +handleClientMessage request response notification 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 sent from client: " ++ show m \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 892f330..de2ca86 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -1,131 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} module Language.Haskell.LSP.Test.Parsing where -import Prelude hiding ( id ) -import Data.Aeson -import Control.Lens -import qualified Data.ByteString.Lazy.Char8 as B -import Data.Maybe -import System.IO -import Language.Haskell.LSP.Types - hiding ( error ) import Language.Haskell.LSP.Messages -import qualified Data.HashMap.Strict as HM - -getAllMessages :: Handle -> IO [B.ByteString] -getAllMessages h = do - done <- hIsEOF h - if done - then return [] - else do - msg <- getNextMessage h - - (msg :) <$> getAllMessages h +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Test.Messages +import Text.Parsec hiding (satisfy) --- | Fetches the next message bytes based on --- the Content-Length header -getNextMessage :: Handle -> IO B.ByteString -getNextMessage h = do - headers <- getHeaders h - case read . init <$> lookup "Content-Length" headers of - Nothing -> error "Couldn't read Content-Length header" - Just size -> B.hGet h size +data MessageParserState = MessageParserState -addHeader :: B.ByteString -> B.ByteString -addHeader content = B.concat - [ "Content-Length: " - , B.pack $ show $ B.length content - , "\r\n" - , "\r\n" - , content - ] +type MessageParser = Parsec [FromServerMessage] MessageParserState -getHeaders :: Handle -> IO [(String, String)] -getHeaders h = do - l <- hGetLine h - let (name, val) = span (/= ':') l - if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h +notification :: MessageParser FromServerMessage +notification = satisfy isServerNotification -type RequestMap = HM.HashMap LspId FromClientMessage +request :: MessageParser FromServerMessage +request = satisfy isServerRequest -getRequestMap :: [FromClientMessage] -> RequestMap -getRequestMap = foldl helper HM.empty - where - helper acc msg = case msg of - (ReqInitialize val) -> insert val msg acc - (ReqShutdown val) -> insert val msg acc - (ReqHover val) -> insert val msg acc - (ReqCompletion val) -> insert val msg acc - (ReqCompletionItemResolve val) -> insert val msg acc - (ReqSignatureHelp val) -> insert val msg acc - (ReqDefinition val) -> insert val msg acc - (ReqFindReferences val) -> insert val msg acc - (ReqDocumentHighlights val) -> insert val msg acc - (ReqDocumentSymbols val) -> insert val msg acc - (ReqWorkspaceSymbols val) -> insert val msg acc - (ReqCodeAction val) -> insert val msg acc - (ReqCodeLens val) -> insert val msg acc - (ReqCodeLensResolve val) -> insert val msg acc - (ReqDocumentFormatting val) -> insert val msg acc - (ReqDocumentRangeFormatting val) -> insert val msg acc - (ReqDocumentOnTypeFormatting val) -> insert val msg acc - (ReqRename val) -> insert val msg acc - (ReqExecuteCommand val) -> insert val msg acc - (ReqDocumentLink val) -> insert val msg acc - (ReqDocumentLinkResolve val) -> insert val msg acc - (ReqWillSaveWaitUntil val) -> insert val msg acc - _ -> acc - insert m = HM.insert (m ^. id) +response :: MessageParser FromServerMessage +response = satisfy isServerResponse -matchResponseMsgType :: FromClientMessage -> B.ByteString -> FromServerMessage -matchResponseMsgType req bytes = case req of - ReqInitialize _ -> RspInitialize $ fromJust $ decode bytes - ReqShutdown _ -> RspShutdown $ fromJust $ decode bytes - ReqHover _ -> RspHover $ fromJust $ decode bytes - ReqCompletion _ -> RspCompletion $ fromJust $ decode bytes - ReqCompletionItemResolve _ -> - RspCompletionItemResolve $ fromJust $ decode bytes - ReqSignatureHelp _ -> RspSignatureHelp $ fromJust $ decode bytes - ReqDefinition _ -> RspDefinition $ fromJust $ decode bytes - ReqFindReferences _ -> RspFindReferences $ fromJust $ decode bytes - ReqDocumentHighlights _ -> RspDocumentHighlights $ fromJust $ decode bytes - ReqDocumentSymbols _ -> RspDocumentSymbols $ fromJust $ decode bytes - ReqWorkspaceSymbols _ -> RspWorkspaceSymbols $ fromJust $ decode bytes - ReqCodeAction _ -> RspCodeAction $ fromJust $ decode bytes - ReqCodeLens _ -> RspCodeLens $ fromJust $ decode bytes - ReqCodeLensResolve _ -> RspCodeLensResolve $ fromJust $ decode bytes - ReqDocumentFormatting _ -> RspDocumentFormatting $ fromJust $ decode bytes - ReqDocumentRangeFormatting _ -> - RspDocumentRangeFormatting $ fromJust $ decode bytes - ReqDocumentOnTypeFormatting _ -> - RspDocumentOnTypeFormatting $ fromJust $ decode bytes - ReqRename _ -> RspRename $ fromJust $ decode bytes - ReqExecuteCommand _ -> RspExecuteCommand $ fromJust $ decode bytes - ReqDocumentLink _ -> RspDocumentLink $ fromJust $ decode bytes - ReqDocumentLinkResolve _ -> RspDocumentLinkResolve $ fromJust $ decode bytes - ReqWillSaveWaitUntil _ -> RspWillSaveWaitUntil $ fromJust $ decode bytes - x -> error $ "Not a request: " ++ show x +satisfy :: (Stream s m a, Eq a, Show a) => (a -> Bool) -> ParsecT s u m a +satisfy pred = tokenPrim show nextPos test + where nextPos x _ _ = x + test x = if pred x then Just x else Nothing -decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage -decodeFromServerMsg reqMap bytes = - case HM.lookup "method" (fromJust $ decode bytes :: Object) of - Just methodStr -> case fromJSON methodStr of - Success method -> case method of - -- We can work out the type of the message - TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes - WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes - WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes - CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes - TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes - WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes - ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes - ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes - WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes +testLog = NotLogMessage (NotificationMessage "2.0" WindowLogMessage (LogMessageParams MtLog "Hello world")) - Error e -> error e +testSymbols = RspDocumentSymbols (ResponseMessage "2.0" (IdRspInt 0) (Just (List [])) Nothing) - Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of - Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of - Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type - Nothing -> error "Couldn't match up response with request" - Nothing -> error "Couldn't decode message" \ No newline at end of file +parseMessages :: MessageParser a -> [FromServerMessage] -> Either ParseError a +parseMessages parser = runP parser MessageParserState "" \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index c9507b5..8c9e1d0 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -- | A testing tool for replaying captured client logs back to a server, -- and validating that the server output matches up with another log. module Language.Haskell.LSP.Test.Replay @@ -24,7 +21,8 @@ import System.IO import System.FilePath import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Files -import Language.Haskell.LSP.Test.Parsing +import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Test.Messages -- | Replays a captured client output and @@ -68,42 +66,7 @@ replaySession sessionDir = do sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session () sendMessages [] _ _ = return () sendMessages (nextMsg:remainingMsgs) reqSema rspSema = - case nextMsg 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 -> liftIO $ error $ "Unknown message was recorded from the client" ++ show m + handleClientMessage request response notification nextMsg where -- TODO: May need to prevent premature exit notification being sent notification msg@(NotificationMessage _ Exit _) = do @@ -155,39 +118,7 @@ listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do msgBytes <- liftIO $ getNextMessage serverOut let msg = decodeFromServerMsg reqMap msgBytes - case msg of - ReqRegisterCapability m -> request m - ReqApplyWorkspaceEdit m -> request m - ReqShowMessage m -> request m - ReqUnregisterCapability m -> request m - RspInitialize m -> response m - RspShutdown m -> response m - RspHover m -> response m - RspCompletion m -> response m - RspCompletionItemResolve m -> response m - RspSignatureHelp m -> response m - RspDefinition m -> response m - RspFindReferences m -> response m - RspDocumentHighlights m -> response m - RspDocumentSymbols m -> response m - RspWorkspaceSymbols m -> response m - RspCodeAction m -> response m - RspCodeLens m -> response m - RspCodeLensResolve m -> response m - RspDocumentFormatting m -> response m - RspDocumentRangeFormatting m -> response m - RspDocumentOnTypeFormatting m -> response m - RspRename m -> response m - RspExecuteCommand m -> response m - RspError m -> response m - RspDocumentLink m -> response m - RspDocumentLinkResolve m -> response m - RspWillSaveWaitUntil m -> response m - NotPublishDiagnostics m -> notification m - NotLogMessage m -> notification m - NotShowMessage m -> notification m - NotTelemetry m -> notification m - NotCancelRequestFromServer m -> notification m + handleServerMessage request response notification msg if shouldSkip msg then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut @@ -203,13 +134,13 @@ listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do putMVar passVar False where - response :: Show a => ResponseMessage a -> Session () + response :: ResponseMessage a -> Session () response res = do liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id) liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request - request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session () + request :: RequestMessage ServerMethod a b -> Session () request req = do liftIO $ putStrLn @@ -220,7 +151,7 @@ listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response - notification :: Show a => NotificationMessage ServerMethod a -> Session () + notification :: NotificationMessage ServerMethod a -> Session () notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)