X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FDecoding.hs;h=d99163e6f54e882afe10b56958cbf39495776c6f;hb=6f3106ce987b2a3794ee7ab444c8bcc204a7b3d2;hp=f71a52fe9620641a87cae74bfdbd8686d1346e13;hpb=f1238f8db54eafbf0e3352140818875ad4cfd997;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs index f71a52f..d99163e 100644 --- a/src/Language/Haskell/LSP/Test/Decoding.hs +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -1,17 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} module Language.Haskell.LSP.Test.Decoding where import Prelude hiding ( id ) import Data.Aeson +import Data.Aeson.Types +import Data.Foldable +import Data.Functor.Product +import Data.Functor.Const +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.Messages +import Language.Haskell.LSP.Types.Lens +import Language.Haskell.LSP.Test.Exceptions import qualified Data.HashMap.Strict as HM +import Data.IxMap +import Data.Kind +import Data.Maybe + getAllMessages :: Handle -> IO [B.ByteString] getAllMessages h = do done <- hIsEOF h @@ -28,7 +43,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,93 +57,51 @@ 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 ClientMethod +type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type ) newRequestMap :: RequestMap -newRequestMap = HM.empty +newRequestMap = emptyIxMap -updateRequestMap :: RequestMap -> RequestMessage ClientMethod a b -> RequestMap -updateRequestMap reqMap msg = HM.insert (msg ^. id) (msg ^. method) reqMap +updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap +updateRequestMap reqMap id method = insertIxMap id method reqMap getRequestMap :: [FromClientMessage] -> RequestMap -getRequestMap = foldl helper HM.empty +getRequestMap = foldl' helper emptyIxMap where + helper :: RequestMap -> FromClientMessage -> RequestMap helper acc msg = case msg of - (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 - (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 + FromClientMess m mess -> case splitClientMethod m of + IsClientNot -> acc + IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m + IsClientEither -> case mess of + NotMess _ -> acc + ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m _ -> acc - insert m = HM.insert (m ^. id) (m ^. method) -matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage -matchResponseMsgType req bytes = case req of - Initialize -> RspInitialize $ fromJust $ decode bytes - Shutdown -> RspShutdown $ fromJust $ decode bytes - TextDocumentHover -> RspHover $ fromJust $ decode bytes - TextDocumentCompletion -> RspCompletion $ fromJust $ decode bytes - CompletionItemResolve -> RspCompletionItemResolve $ fromJust $ decode bytes - TextDocumentSignatureHelp -> RspSignatureHelp $ fromJust $ decode bytes - TextDocumentDefinition -> RspDefinition $ fromJust $ decode bytes - TextDocumentReferences -> RspFindReferences $ fromJust $ decode bytes - TextDocumentDocumentHighlight -> RspDocumentHighlights $ fromJust $ decode bytes - TextDocumentDocumentSymbol -> RspDocumentSymbols $ fromJust $ decode bytes - WorkspaceSymbol -> RspWorkspaceSymbols $ fromJust $ decode bytes - TextDocumentCodeAction -> RspCodeAction $ fromJust $ decode bytes - TextDocumentCodeLens -> RspCodeLens $ fromJust $ decode bytes - CodeLensResolve -> RspCodeLensResolve $ fromJust $ decode bytes - TextDocumentFormatting -> RspDocumentFormatting $ fromJust $ decode bytes - TextDocumentRangeFormatting -> RspDocumentRangeFormatting $ fromJust $ decode bytes - TextDocumentOnTypeFormatting -> RspDocumentOnTypeFormatting $ fromJust $ decode bytes - TextDocumentRename -> RspRename $ fromJust $ decode bytes - WorkspaceExecuteCommand -> RspExecuteCommand $ fromJust $ decode bytes - TextDocumentDocumentLink -> RspDocumentLink $ fromJust $ decode bytes - DocumentLinkResolve -> RspDocumentLinkResolve $ fromJust $ decode bytes - TextDocumentWillSaveWaitUntil -> 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 +decodeFromServerMsg :: RequestMap -> B.ByteString -> (FromServerMessage, RequestMap) +decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe p obj + where obj = fromJust $ decode bytes :: Value + p = parseServerMessage $ \lid -> + let (mm, newMap) = pickFromIxMap lid reqMap + in case mm of + Nothing -> Nothing + Just m -> Just $ (m, Pair m (Const newMap)) + unP (FromServerMess m msg) = (FromServerMess m msg, reqMap) + unP (FromServerRsp (Pair m (Const newMap)) msg) = (FromServerRsp m msg, newMap) + {- + 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 - - 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 + -}