1 {-# LANGUAGE OverloadedStrings #-}
2 module Language.Haskell.LSP.Test.Decoding where
4 import Prelude hiding ( id )
7 import qualified Data.ByteString.Lazy.Char8 as B
10 import Language.Haskell.LSP.Types
12 import Language.Haskell.LSP.Messages
13 import qualified Data.HashMap.Strict as HM
15 getAllMessages :: Handle -> IO [B.ByteString]
21 msg <- getNextMessage h
23 (msg :) <$> getAllMessages h
25 -- | Fetches the next message bytes based on
26 -- the Content-Length header
27 getNextMessage :: Handle -> IO B.ByteString
29 headers <- getHeaders h
30 case read . init <$> lookup "Content-Length" headers of
31 Nothing -> error "Couldn't read Content-Length header"
32 Just size -> B.hGet h size
34 addHeader :: B.ByteString -> B.ByteString
35 addHeader content = B.concat
37 , B.pack $ show $ B.length content
43 getHeaders :: Handle -> IO [(String, String)]
46 let (name, val) = span (/= ':') l
47 if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
49 type RequestMap = HM.HashMap LspId FromClientMessage
51 getRequestMap :: [FromClientMessage] -> RequestMap
52 getRequestMap = foldl helper HM.empty
54 helper acc msg = case msg of
55 (ReqInitialize val) -> insert val msg acc
56 (ReqShutdown val) -> insert val msg acc
57 (ReqHover val) -> insert val msg acc
58 (ReqCompletion val) -> insert val msg acc
59 (ReqCompletionItemResolve val) -> insert val msg acc
60 (ReqSignatureHelp val) -> insert val msg acc
61 (ReqDefinition val) -> insert val msg acc
62 (ReqFindReferences val) -> insert val msg acc
63 (ReqDocumentHighlights val) -> insert val msg acc
64 (ReqDocumentSymbols val) -> insert val msg acc
65 (ReqWorkspaceSymbols val) -> insert val msg acc
66 (ReqCodeAction val) -> insert val msg acc
67 (ReqCodeLens val) -> insert val msg acc
68 (ReqCodeLensResolve val) -> insert val msg acc
69 (ReqDocumentFormatting val) -> insert val msg acc
70 (ReqDocumentRangeFormatting val) -> insert val msg acc
71 (ReqDocumentOnTypeFormatting val) -> insert val msg acc
72 (ReqRename val) -> insert val msg acc
73 (ReqExecuteCommand val) -> insert val msg acc
74 (ReqDocumentLink val) -> insert val msg acc
75 (ReqDocumentLinkResolve val) -> insert val msg acc
76 (ReqWillSaveWaitUntil val) -> insert val msg acc
78 insert m = HM.insert (m ^. id)
80 matchResponseMsgType :: FromClientMessage -> B.ByteString -> FromServerMessage
81 matchResponseMsgType req bytes = case req of
82 ReqInitialize _ -> RspInitialize $ fromJust $ decode bytes
83 ReqShutdown _ -> RspShutdown $ fromJust $ decode bytes
84 ReqHover _ -> RspHover $ fromJust $ decode bytes
85 ReqCompletion _ -> RspCompletion $ fromJust $ decode bytes
86 ReqCompletionItemResolve _ ->
87 RspCompletionItemResolve $ fromJust $ decode bytes
88 ReqSignatureHelp _ -> RspSignatureHelp $ fromJust $ decode bytes
89 ReqDefinition _ -> RspDefinition $ fromJust $ decode bytes
90 ReqFindReferences _ -> RspFindReferences $ fromJust $ decode bytes
91 ReqDocumentHighlights _ -> RspDocumentHighlights $ fromJust $ decode bytes
92 ReqDocumentSymbols _ -> RspDocumentSymbols $ fromJust $ decode bytes
93 ReqWorkspaceSymbols _ -> RspWorkspaceSymbols $ fromJust $ decode bytes
94 ReqCodeAction _ -> RspCodeAction $ fromJust $ decode bytes
95 ReqCodeLens _ -> RspCodeLens $ fromJust $ decode bytes
96 ReqCodeLensResolve _ -> RspCodeLensResolve $ fromJust $ decode bytes
97 ReqDocumentFormatting _ -> RspDocumentFormatting $ fromJust $ decode bytes
98 ReqDocumentRangeFormatting _ ->
99 RspDocumentRangeFormatting $ fromJust $ decode bytes
100 ReqDocumentOnTypeFormatting _ ->
101 RspDocumentOnTypeFormatting $ fromJust $ decode bytes
102 ReqRename _ -> RspRename $ fromJust $ decode bytes
103 ReqExecuteCommand _ -> RspExecuteCommand $ fromJust $ decode bytes
104 ReqDocumentLink _ -> RspDocumentLink $ fromJust $ decode bytes
105 ReqDocumentLinkResolve _ -> RspDocumentLinkResolve $ fromJust $ decode bytes
106 ReqWillSaveWaitUntil _ -> RspWillSaveWaitUntil $ fromJust $ decode bytes
107 x -> error $ "Not a request: " ++ show x
109 decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
110 decodeFromServerMsg reqMap bytes =
111 case HM.lookup "method" (fromJust $ decode bytes :: Object) of
112 Just methodStr -> case fromJSON methodStr of
113 Success method -> case method of
114 -- We can work out the type of the message
115 TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes
116 WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes
117 WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes
118 CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes
119 TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes
120 WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes
121 ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes
122 ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes
123 WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes
127 Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of
128 Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of
129 Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type
130 Nothing -> error "Couldn't match up response with request"
131 Nothing -> error "Couldn't decode message"