X-Git-Url: https://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FDecoding.hs;h=350b5251ad8b49133d3be5086852e3984f682a8c;hp=4e871155aff4dece1318d6b25c1b851b6ecca0c5;hb=d755a0a431e88fe5c4b2a62743ee78c3a51a55e5;hpb=208679fa3a42e2a81bc778218bab6376bd6f42d1 diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs index 4e87115..350b525 100644 --- a/src/Language/Haskell/LSP/Test/Decoding.hs +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -3,13 +3,17 @@ module Language.Haskell.LSP.Test.Decoding where import Prelude hiding ( id ) import Data.Aeson +import Data.Foldable +import Control.Exception import Control.Lens import qualified Data.ByteString.Lazy.Char8 as B import Data.Maybe import System.IO +import System.IO.Error import Language.Haskell.LSP.Types - hiding ( error ) +import Language.Haskell.LSP.Types.Lens import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Test.Exceptions import qualified Data.HashMap.Strict as HM getAllMessages :: Handle -> IO [B.ByteString] @@ -28,7 +32,7 @@ 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" + Nothing -> throw NoContentLengthHeader Just size -> B.hGet h size addHeader :: B.ByteString -> B.ByteString @@ -42,73 +46,85 @@ addHeader content = B.concat getHeaders :: Handle -> IO [(String, String)] getHeaders h = do - l <- hGetLine h + l <- catch (hGetLine h) eofHandler let (name, val) = span (/= ':') l if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h + where eofHandler e + | isEOFError e = throw UnexpectedServerTermination + | otherwise = throw e -type RequestMap = HM.HashMap LspId FromClientMessage +type RequestMap = HM.HashMap LspId ClientMethod + +newRequestMap :: RequestMap +newRequestMap = HM.empty + +updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap +updateRequestMap reqMap id method = HM.insert id method reqMap 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 + (ReqInitialize val) -> insert val acc + (ReqShutdown val) -> insert val acc + (ReqHover val) -> insert val acc + (ReqCompletion val) -> insert val acc + (ReqCompletionItemResolve val) -> insert val acc + (ReqSignatureHelp val) -> insert val acc + (ReqDefinition val) -> insert val acc + (ReqTypeDefinition val) -> insert val acc + (ReqFindReferences val) -> insert val acc + (ReqDocumentHighlights val) -> insert val acc + (ReqDocumentSymbols val) -> insert val acc + (ReqWorkspaceSymbols val) -> insert val acc + (ReqCodeAction val) -> insert val acc + (ReqCodeLens val) -> insert val acc + (ReqCodeLensResolve val) -> insert val acc + (ReqDocumentFormatting val) -> insert val acc + (ReqDocumentRangeFormatting val) -> insert val acc + (ReqDocumentOnTypeFormatting val) -> insert val acc + (ReqRename val) -> insert val acc + (ReqExecuteCommand val) -> insert val acc + (ReqDocumentLink val) -> insert val acc + (ReqDocumentLinkResolve val) -> insert val acc + (ReqWillSaveWaitUntil val) -> insert val acc _ -> acc - insert m = HM.insert (m ^. id) + insert m = HM.insert (m ^. id) (m ^. method) -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 +matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage +matchResponseMsgType req = case req of + Initialize -> RspInitialize . decoded + Shutdown -> RspShutdown . decoded + TextDocumentHover -> RspHover . decoded + TextDocumentCompletion -> RspCompletion . decoded + CompletionItemResolve -> RspCompletionItemResolve . decoded + TextDocumentSignatureHelp -> RspSignatureHelp . decoded + TextDocumentDefinition -> RspDefinition . decoded + TextDocumentTypeDefinition -> RspTypeDefinition . decoded + TextDocumentReferences -> RspFindReferences . decoded + TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded + TextDocumentDocumentSymbol -> RspDocumentSymbols . decoded + WorkspaceSymbol -> RspWorkspaceSymbols . decoded + TextDocumentCodeAction -> RspCodeAction . decoded + TextDocumentCodeLens -> RspCodeLens . decoded + CodeLensResolve -> RspCodeLensResolve . decoded + TextDocumentFormatting -> RspDocumentFormatting . decoded + TextDocumentRangeFormatting -> RspDocumentRangeFormatting . decoded + TextDocumentOnTypeFormatting -> RspDocumentOnTypeFormatting . decoded + TextDocumentRename -> RspRename . decoded + WorkspaceExecuteCommand -> RspExecuteCommand . decoded + TextDocumentDocumentLink -> RspDocumentLink . decoded + DocumentLinkResolve -> RspDocumentLinkResolve . decoded + TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded + CustomClientMethod{} -> RspCustomServer . decoded + x -> error . ((show x ++ " is not a request: ") ++) . show + where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: " + ++ show req ++ "\n" ++ show x) + (decode x) decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage decodeFromServerMsg reqMap bytes = - case HM.lookup "method" (fromJust $ decode bytes :: Object) of + case HM.lookup "method" obj of Just methodStr -> case fromJSON methodStr of Success method -> case method of -- We can work out the type of the message @@ -116,11 +132,20 @@ decodeFromServerMsg reqMap bytes = WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes + Progress -> + fromJust $ asum [NotWorkDoneProgressBegin <$> decode bytes, NotWorkDoneProgressReport <$> decode bytes, NotWorkDoneProgressEnd <$> decode bytes] + WindowWorkDoneProgressCreate -> ReqWorkDoneProgressCreate $ 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 + WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" + WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" + CustomServerMethod _ + | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes + | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes + | otherwise -> NotCustomServer $ fromJust $ decode bytes Error e -> error e @@ -129,3 +154,4 @@ decodeFromServerMsg reqMap bytes = 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" + where obj = fromJust $ decode bytes :: Object