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]
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
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
(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
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
+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
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
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
projects / lsp-test.git / blobdiff