1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE TupleSections #-}
4 {-# LANGUAGE PolyKinds #-}
5 {-# LANGUAGE KindSignatures #-}
6 {-# LANGUAGE DataKinds #-}
7 module Language.LSP.Test.Decoding where
9 import Prelude hiding ( id )
11 import Data.Aeson.Types
13 import Data.Functor.Product
14 import Data.Functor.Const
15 import Control.Exception
17 import qualified Data.ByteString.Lazy.Char8 as B
20 import System.IO.Error
21 import Language.LSP.Types
22 import Language.LSP.Types.Lens
23 import Language.LSP.Test.Exceptions
28 getAllMessages :: Handle -> IO [B.ByteString]
34 msg <- getNextMessage h
36 (msg :) <$> getAllMessages h
38 -- | Fetches the next message bytes based on
39 -- the Content-Length header
40 getNextMessage :: Handle -> IO B.ByteString
42 headers <- getHeaders h
43 case read . init <$> lookup "Content-Length" headers of
44 Nothing -> throw NoContentLengthHeader
45 Just size -> B.hGet h size
47 addHeader :: B.ByteString -> B.ByteString
48 addHeader content = B.concat
50 , B.pack $ show $ B.length content
56 getHeaders :: Handle -> IO [(String, String)]
58 l <- catch (hGetLine h) eofHandler
59 let (name, val) = span (/= ':') l
60 if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
62 | isEOFError e = throw UnexpectedServerTermination
65 type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type )
67 newRequestMap :: RequestMap
68 newRequestMap = emptyIxMap
70 updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
71 updateRequestMap reqMap id method = insertIxMap id method reqMap
73 getRequestMap :: [FromClientMessage] -> RequestMap
74 getRequestMap = foldl' helper emptyIxMap
76 helper :: RequestMap -> FromClientMessage -> RequestMap
77 helper acc msg = case msg of
78 FromClientMess m mess -> case splitClientMethod m of
80 IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m
81 IsClientEither -> case mess of
83 ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m
86 decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage)
87 decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe p obj
88 where obj = fromJust $ decode bytes :: Value
89 p = parseServerMessage $ \lid ->
90 let (mm, newMap) = pickFromIxMap lid reqMap
93 Just m -> Just $ (m, Pair m (Const newMap))
94 unP (FromServerMess m msg) = (reqMap, FromServerMess m msg)
95 unP (FromServerRsp (Pair m (Const newMap)) msg) = (newMap, FromServerRsp m msg)
97 WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet"
98 WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet"
100 | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes
101 | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes
102 | otherwise -> NotCustomServer $ fromJust $ decode bytes