1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE TupleSections #-}
4 {-# LANGUAGE PolyKinds #-}
5 {-# LANGUAGE KindSignatures #-}
6 {-# LANGUAGE DataKinds #-}
7 module Language.Haskell.LSP.Test.Decoding where
9 import Prelude hiding ( id )
11 import Data.Aeson.Types
13 import Control.Exception
15 import qualified Data.ByteString.Lazy.Char8 as B
18 import System.IO.Error
19 import Language.Haskell.LSP.Types
20 import Language.Haskell.LSP.Types.Lens
21 import Language.Haskell.LSP.Test.Exceptions
22 import qualified Data.HashMap.Strict as HM
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
83 decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
84 decodeFromServerMsg reqMap bytes = fst $ fromJust $ parseMaybe p obj
85 where obj = fromJust $ decode bytes :: Value
86 p = parseServerMessage (\i -> (,()) <$> lookupIxMap i reqMap)
88 WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet"
89 WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet"
91 | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes
92 | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes
93 | otherwise -> NotCustomServer $ fromJust $ decode bytes