1 {-# LANGUAGE OverloadedStrings #-}
2 module Language.Haskell.LSP.Test.Decoding where
4 import Prelude hiding ( id )
7 import Control.Exception
9 import qualified Data.ByteString.Lazy.Char8 as B
12 import System.IO.Error
13 import Language.Haskell.LSP.Types
14 import Language.Haskell.LSP.Types.Lens
16 import Language.Haskell.LSP.Messages
17 import Language.Haskell.LSP.Test.Exceptions
18 import qualified Data.HashMap.Strict as HM
20 getAllMessages :: Handle -> IO [B.ByteString]
26 msg <- getNextMessage h
28 (msg :) <$> getAllMessages h
30 -- | Fetches the next message bytes based on
31 -- the Content-Length header
32 getNextMessage :: Handle -> IO B.ByteString
34 headers <- getHeaders h
35 case read . init <$> lookup "Content-Length" headers of
36 Nothing -> throw NoContentLengthHeader
37 Just size -> B.hGet h size
39 addHeader :: B.ByteString -> B.ByteString
40 addHeader content = B.concat
42 , B.pack $ show $ B.length content
48 getHeaders :: Handle -> IO [(String, String)]
50 l <- catch (hGetLine h) eofHandler
51 let (name, val) = span (/= ':') l
52 if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
54 | isEOFError e = throw UnexpectedServerTermination
57 type RequestMap = HM.HashMap LspId ClientMethod
59 newRequestMap :: RequestMap
60 newRequestMap = HM.empty
62 updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap
63 updateRequestMap reqMap id method = HM.insert id method reqMap
65 getRequestMap :: [FromClientMessage] -> RequestMap
66 getRequestMap = foldl helper HM.empty
68 helper acc msg = case msg of
69 (ReqInitialize val) -> insert val acc
70 (ReqShutdown val) -> insert val acc
71 (ReqHover val) -> insert val acc
72 (ReqCompletion val) -> insert val acc
73 (ReqCompletionItemResolve val) -> insert val acc
74 (ReqSignatureHelp val) -> insert val acc
75 (ReqDefinition val) -> insert val acc
76 (ReqTypeDefinition val) -> insert val acc
77 (ReqFindReferences val) -> insert val acc
78 (ReqDocumentHighlights val) -> insert val acc
79 (ReqDocumentSymbols val) -> insert val acc
80 (ReqWorkspaceSymbols val) -> insert val acc
81 (ReqCodeAction val) -> insert val acc
82 (ReqCodeLens val) -> insert val acc
83 (ReqCodeLensResolve val) -> insert val acc
84 (ReqDocumentFormatting val) -> insert val acc
85 (ReqDocumentRangeFormatting val) -> insert val acc
86 (ReqDocumentOnTypeFormatting val) -> insert val acc
87 (ReqRename val) -> insert val acc
88 (ReqExecuteCommand val) -> insert val acc
89 (ReqDocumentLink val) -> insert val acc
90 (ReqDocumentLinkResolve val) -> insert val acc
91 (ReqWillSaveWaitUntil val) -> insert val acc
93 insert m = HM.insert (m ^. id) (m ^. method)
95 matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage
96 matchResponseMsgType req = case req of
97 Initialize -> RspInitialize . decoded
98 Shutdown -> RspShutdown . decoded
99 TextDocumentHover -> RspHover . decoded
100 TextDocumentCompletion -> RspCompletion . decoded
101 CompletionItemResolve -> RspCompletionItemResolve . decoded
102 TextDocumentSignatureHelp -> RspSignatureHelp . decoded
103 TextDocumentDefinition -> RspDefinition . decoded
104 TextDocumentTypeDefinition -> RspTypeDefinition . decoded
105 TextDocumentReferences -> RspFindReferences . decoded
106 TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded
107 TextDocumentDocumentSymbol -> RspDocumentSymbols . decoded
108 WorkspaceSymbol -> RspWorkspaceSymbols . decoded
109 TextDocumentCodeAction -> RspCodeAction . decoded
110 TextDocumentCodeLens -> RspCodeLens . decoded
111 CodeLensResolve -> RspCodeLensResolve . decoded
112 TextDocumentFormatting -> RspDocumentFormatting . decoded
113 TextDocumentRangeFormatting -> RspDocumentRangeFormatting . decoded
114 TextDocumentOnTypeFormatting -> RspDocumentOnTypeFormatting . decoded
115 TextDocumentRename -> RspRename . decoded
116 WorkspaceExecuteCommand -> RspExecuteCommand . decoded
117 TextDocumentDocumentLink -> RspDocumentLink . decoded
118 DocumentLinkResolve -> RspDocumentLinkResolve . decoded
119 TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded
120 x -> error . ((show x ++ " is not a request: ") ++) . show
121 where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: "
122 ++ show req ++ "\n" ++ show x)
125 decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
126 decodeFromServerMsg reqMap bytes =
127 case HM.lookup "method" obj of
128 Just methodStr -> case fromJSON methodStr of
129 Success method -> case method of
130 -- We can work out the type of the message
131 TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes
132 WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes
133 WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes
134 CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes
136 fromJust $ asum [NotWorkDoneProgressBegin <$> decode bytes, NotWorkDoneProgressReport <$> decode bytes, NotWorkDoneProgressEnd <$> decode bytes]
137 WindowWorkDoneProgressCreate -> ReqWorkDoneProgressCreate $ fromJust $ decode bytes
138 TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes
139 WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes
140 ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes
141 ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes
142 WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes
143 WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet"
144 WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet"
146 | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes
147 | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes
148 | otherwise -> NotCustomServer $ fromJust $ decode bytes
152 Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of
153 Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of
154 Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type
155 Nothing -> error "Couldn't match up response with request"
156 Nothing -> error "Couldn't decode message"
157 where obj = fromJust $ decode bytes :: Object