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 ClientMethod
51 newRequestMap :: RequestMap
52 newRequestMap = HM.empty
54 updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap
55 updateRequestMap reqMap id method = HM.insert id method reqMap
57 getRequestMap :: [FromClientMessage] -> RequestMap
58 getRequestMap = foldl helper HM.empty
60 helper acc msg = case msg of
61 (ReqInitialize val) -> insert val acc
62 (ReqShutdown val) -> insert val acc
63 (ReqHover val) -> insert val acc
64 (ReqCompletion val) -> insert val acc
65 (ReqCompletionItemResolve val) -> insert val acc
66 (ReqSignatureHelp val) -> insert val acc
67 (ReqDefinition val) -> insert val acc
68 (ReqFindReferences val) -> insert val acc
69 (ReqDocumentHighlights val) -> insert val acc
70 (ReqDocumentSymbols val) -> insert val acc
71 (ReqWorkspaceSymbols val) -> insert val acc
72 (ReqCodeAction val) -> insert val acc
73 (ReqCodeLens val) -> insert val acc
74 (ReqCodeLensResolve val) -> insert val acc
75 (ReqDocumentFormatting val) -> insert val acc
76 (ReqDocumentRangeFormatting val) -> insert val acc
77 (ReqDocumentOnTypeFormatting val) -> insert val acc
78 (ReqRename val) -> insert val acc
79 (ReqExecuteCommand val) -> insert val acc
80 (ReqDocumentLink val) -> insert val acc
81 (ReqDocumentLinkResolve val) -> insert val acc
82 (ReqWillSaveWaitUntil val) -> insert val acc
84 insert m = HM.insert (m ^. id) (m ^. method)
86 matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage
87 matchResponseMsgType req bytes = case req of
88 Initialize -> RspInitialize $ fromJust $ decode bytes
89 Shutdown -> RspShutdown $ fromJust $ decode bytes
90 TextDocumentHover -> RspHover $ fromJust $ decode bytes
91 TextDocumentCompletion -> RspCompletion $ fromJust $ decode bytes
92 CompletionItemResolve -> RspCompletionItemResolve $ fromJust $ decode bytes
93 TextDocumentSignatureHelp -> RspSignatureHelp $ fromJust $ decode bytes
94 TextDocumentDefinition -> RspDefinition $ fromJust $ decode bytes
95 TextDocumentReferences -> RspFindReferences $ fromJust $ decode bytes
96 TextDocumentDocumentHighlight -> RspDocumentHighlights $ fromJust $ decode bytes
97 TextDocumentDocumentSymbol -> RspDocumentSymbols $ fromJust $ decode bytes
98 WorkspaceSymbol -> RspWorkspaceSymbols $ fromJust $ decode bytes
99 TextDocumentCodeAction -> RspCodeAction $ fromJust $ decode bytes
100 TextDocumentCodeLens -> RspCodeLens $ fromJust $ decode bytes
101 CodeLensResolve -> RspCodeLensResolve $ fromJust $ decode bytes
102 TextDocumentFormatting -> RspDocumentFormatting $ fromJust $ decode bytes
103 TextDocumentRangeFormatting -> RspDocumentRangeFormatting $ fromJust $ decode bytes
104 TextDocumentOnTypeFormatting -> RspDocumentOnTypeFormatting $ fromJust $ decode bytes
105 TextDocumentRename -> RspRename $ fromJust $ decode bytes
106 WorkspaceExecuteCommand -> RspExecuteCommand $ fromJust $ decode bytes
107 TextDocumentDocumentLink -> RspDocumentLink $ fromJust $ decode bytes
108 DocumentLinkResolve -> RspDocumentLinkResolve $ fromJust $ decode bytes
109 TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil $ fromJust $ decode bytes
110 x -> error $ "Not a request: " ++ show x
112 decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
113 decodeFromServerMsg reqMap bytes =
114 case HM.lookup "method" (fromJust $ decode bytes :: Object) of
115 Just methodStr -> case fromJSON methodStr of
116 Success method -> case method of
117 -- We can work out the type of the message
118 TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes
119 WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes
120 WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes
121 CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes
122 TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes
123 WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes
124 ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes
125 ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes
126 WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes
130 Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of
131 Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of
132 Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type
133 Nothing -> error "Couldn't match up response with request"
134 Nothing -> error "Couldn't decode message"