{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.LSP.Test.Decoding where

import           Prelude                 hiding ( id )
import           Data.Aeson
import           Data.Foldable
import           Control.Exception
import           Control.Lens
import qualified Data.ByteString.Lazy.Char8    as B
import           Data.Maybe
import           System.IO
import           System.IO.Error
import           Language.Haskell.LSP.Types
import           Language.Haskell.LSP.Types.Lens
import           Language.Haskell.LSP.Messages
import           Language.Haskell.LSP.Test.Exceptions
import qualified Data.HashMap.Strict           as HM

getAllMessages :: Handle -> IO [B.ByteString]
getAllMessages :: Handle -> IO [ByteString]
getAllMessages Handle
h = do
  Bool
done <- Handle -> IO Bool
hIsEOF Handle
h
  if Bool
done
    then [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else do
      ByteString
msg <- Handle -> IO ByteString
getNextMessage Handle
h

      (ByteString
msg ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO [ByteString]
getAllMessages Handle
h

-- | Fetches the next message bytes based on
-- the Content-Length header
getNextMessage :: Handle -> IO B.ByteString
getNextMessage :: Handle -> IO ByteString
getNextMessage Handle
h = do
  [(String, String)]
headers <- Handle -> IO [(String, String)]
getHeaders Handle
h
  case String -> Int
forall a. Read a => String -> a
read (String -> Int) -> (String -> String) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
init (String -> Int) -> Maybe String -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Content-Length" [(String, String)]
headers of
    Maybe Int
Nothing   -> SessionException -> IO ByteString
forall a e. Exception e => e -> a
throw SessionException
NoContentLengthHeader
    Just Int
size -> Handle -> Int -> IO ByteString
B.hGet Handle
h Int
size

addHeader :: B.ByteString -> B.ByteString
addHeader :: ByteString -> ByteString
addHeader ByteString
content = [ByteString] -> ByteString
B.concat
  [ ByteString
"Content-Length: "
  , String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
B.length ByteString
content
  , ByteString
"\r\n"
  , ByteString
"\r\n"
  , ByteString
content
  ]

getHeaders :: Handle -> IO [(String, String)]
getHeaders :: Handle -> IO [(String, String)]
getHeaders Handle
h = do
  String
l <- IO String -> (IOError -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Handle -> IO String
hGetLine Handle
h) IOError -> IO String
forall p. IOError -> p
eofHandler
  let (String
name, String
val) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
l
  if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
val then [(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else ((String
name, Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 String
val) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:) ([(String, String)] -> [(String, String)])
-> IO [(String, String)] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO [(String, String)]
getHeaders Handle
h
  where eofHandler :: IOError -> p
eofHandler IOError
e
          | IOError -> Bool
isEOFError IOError
e = SessionException -> p
forall a e. Exception e => e -> a
throw SessionException
UnexpectedServerTermination
          | Bool
otherwise = IOError -> p
forall a e. Exception e => e -> a
throw IOError
e

type RequestMap = HM.HashMap LspId ClientMethod

newRequestMap :: RequestMap
newRequestMap :: RequestMap
newRequestMap = RequestMap
forall k v. HashMap k v
HM.empty

updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap
updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap
updateRequestMap RequestMap
reqMap LspId
id ClientMethod
method = LspId -> ClientMethod -> RequestMap -> RequestMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert LspId
id ClientMethod
method RequestMap
reqMap

getRequestMap :: [FromClientMessage] -> RequestMap
getRequestMap :: [FromClientMessage] -> RequestMap
getRequestMap = (RequestMap -> FromClientMessage -> RequestMap)
-> RequestMap -> [FromClientMessage] -> RequestMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl RequestMap -> FromClientMessage -> RequestMap
helper RequestMap
forall k v. HashMap k v
HM.empty
 where
  helper :: RequestMap -> FromClientMessage -> RequestMap
helper RequestMap
acc FromClientMessage
msg = case FromClientMessage
msg of
    (ReqInitialize InitializeRequest
val) -> InitializeRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert InitializeRequest
val RequestMap
acc
    (ReqShutdown ShutdownRequest
val) -> ShutdownRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert ShutdownRequest
val RequestMap
acc
    (ReqHover HoverRequest
val) -> HoverRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert HoverRequest
val RequestMap
acc
    (ReqCompletion CompletionRequest
val) -> CompletionRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert CompletionRequest
val RequestMap
acc
    (ReqCompletionItemResolve CompletionItemResolveRequest
val) -> CompletionItemResolveRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert CompletionItemResolveRequest
val RequestMap
acc
    (ReqSignatureHelp SignatureHelpRequest
val) -> SignatureHelpRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert SignatureHelpRequest
val RequestMap
acc
    (ReqDefinition DefinitionRequest
val) -> DefinitionRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert DefinitionRequest
val RequestMap
acc
    (ReqTypeDefinition DefinitionRequest
val) -> DefinitionRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert DefinitionRequest
val RequestMap
acc
    (ReqFindReferences ReferencesRequest
val) -> ReferencesRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert ReferencesRequest
val RequestMap
acc
    (ReqDocumentHighlights DocumentHighlightRequest
val) -> DocumentHighlightRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert DocumentHighlightRequest
val RequestMap
acc
    (ReqDocumentSymbols DocumentSymbolRequest
val) -> DocumentSymbolRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert DocumentSymbolRequest
val RequestMap
acc
    (ReqWorkspaceSymbols WorkspaceSymbolRequest
val) -> WorkspaceSymbolRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert WorkspaceSymbolRequest
val RequestMap
acc
    (ReqCodeAction CodeActionRequest
val) -> CodeActionRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert CodeActionRequest
val RequestMap
acc
    (ReqCodeLens CodeLensRequest
val) -> CodeLensRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert CodeLensRequest
val RequestMap
acc
    (ReqCodeLensResolve CodeLensResolveRequest
val) -> CodeLensResolveRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert CodeLensResolveRequest
val RequestMap
acc
    (ReqDocumentFormatting DocumentFormattingRequest
val) -> DocumentFormattingRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert DocumentFormattingRequest
val RequestMap
acc
    (ReqDocumentRangeFormatting DocumentRangeFormattingRequest
val) -> DocumentRangeFormattingRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert DocumentRangeFormattingRequest
val RequestMap
acc
    (ReqDocumentOnTypeFormatting DocumentOnTypeFormattingRequest
val) -> DocumentOnTypeFormattingRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert DocumentOnTypeFormattingRequest
val RequestMap
acc
    (ReqRename RenameRequest
val) -> RenameRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert RenameRequest
val RequestMap
acc
    (ReqExecuteCommand ExecuteCommandRequest
val) -> ExecuteCommandRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert ExecuteCommandRequest
val RequestMap
acc
    (ReqDocumentLink DocumentLinkRequest
val) -> DocumentLinkRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert DocumentLinkRequest
val RequestMap
acc
    (ReqDocumentLinkResolve DocumentLinkResolveRequest
val) -> DocumentLinkResolveRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert DocumentLinkResolveRequest
val RequestMap
acc
    (ReqWillSaveWaitUntil WillSaveWaitUntilTextDocumentRequest
val) -> WillSaveWaitUntilTextDocumentRequest -> RequestMap -> RequestMap
forall k s v.
(Eq k, Hashable k, HasId s k, HasMethod s v) =>
s -> HashMap k v -> HashMap k v
insert WillSaveWaitUntilTextDocumentRequest
val RequestMap
acc
    FromClientMessage
_ -> RequestMap
acc
  insert :: s -> HashMap k v -> HashMap k v
insert s
m = k -> v -> HashMap k v -> HashMap k v
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (s
m s -> Getting k s k -> k
forall s a. s -> Getting a s a -> a
^. Getting k s k
forall s a. HasId s a => Lens' s a
id) (s
m s -> Getting v s v -> v
forall s a. s -> Getting a s a -> a
^. Getting v s v
forall s a. HasMethod s a => Lens' s a
method)

matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage
matchResponseMsgType :: ClientMethod -> ByteString -> FromServerMessage
matchResponseMsgType ClientMethod
req = case ClientMethod
req of
  ClientMethod
Initialize                    -> InitializeResponse -> FromServerMessage
RspInitialize (InitializeResponse -> FromServerMessage)
-> (ByteString -> InitializeResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> InitializeResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
Shutdown                      -> ShutdownResponse -> FromServerMessage
RspShutdown (ShutdownResponse -> FromServerMessage)
-> (ByteString -> ShutdownResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShutdownResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentHover             -> HoverResponse -> FromServerMessage
RspHover (HoverResponse -> FromServerMessage)
-> (ByteString -> HoverResponse) -> ByteString -> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HoverResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentCompletion        -> CompletionResponse -> FromServerMessage
RspCompletion (CompletionResponse -> FromServerMessage)
-> (ByteString -> CompletionResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> CompletionResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
CompletionItemResolve         -> CompletionItemResolveResponse -> FromServerMessage
RspCompletionItemResolve (CompletionItemResolveResponse -> FromServerMessage)
-> (ByteString -> CompletionItemResolveResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> CompletionItemResolveResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentSignatureHelp     -> SignatureHelpResponse -> FromServerMessage
RspSignatureHelp (SignatureHelpResponse -> FromServerMessage)
-> (ByteString -> SignatureHelpResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> SignatureHelpResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentDefinition        -> DefinitionResponse -> FromServerMessage
RspDefinition (DefinitionResponse -> FromServerMessage)
-> (ByteString -> DefinitionResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DefinitionResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentTypeDefinition    -> DefinitionResponse -> FromServerMessage
RspTypeDefinition (DefinitionResponse -> FromServerMessage)
-> (ByteString -> DefinitionResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DefinitionResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentReferences        -> ReferencesResponse -> FromServerMessage
RspFindReferences (ReferencesResponse -> FromServerMessage)
-> (ByteString -> ReferencesResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ReferencesResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentDocumentHighlight -> DocumentHighlightsResponse -> FromServerMessage
RspDocumentHighlights (DocumentHighlightsResponse -> FromServerMessage)
-> (ByteString -> DocumentHighlightsResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DocumentHighlightsResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentDocumentSymbol    -> DocumentSymbolsResponse -> FromServerMessage
RspDocumentSymbols (DocumentSymbolsResponse -> FromServerMessage)
-> (ByteString -> DocumentSymbolsResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DocumentSymbolsResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
WorkspaceSymbol               -> WorkspaceSymbolsResponse -> FromServerMessage
RspWorkspaceSymbols (WorkspaceSymbolsResponse -> FromServerMessage)
-> (ByteString -> WorkspaceSymbolsResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> WorkspaceSymbolsResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentCodeAction        -> CodeActionResponse -> FromServerMessage
RspCodeAction (CodeActionResponse -> FromServerMessage)
-> (ByteString -> CodeActionResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> CodeActionResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentCodeLens          -> CodeLensResponse -> FromServerMessage
RspCodeLens (CodeLensResponse -> FromServerMessage)
-> (ByteString -> CodeLensResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> CodeLensResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
CodeLensResolve               -> CodeLensResolveResponse -> FromServerMessage
RspCodeLensResolve (CodeLensResolveResponse -> FromServerMessage)
-> (ByteString -> CodeLensResolveResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> CodeLensResolveResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentFormatting        -> DocumentFormattingResponse -> FromServerMessage
RspDocumentFormatting (DocumentFormattingResponse -> FromServerMessage)
-> (ByteString -> DocumentFormattingResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DocumentFormattingResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentRangeFormatting   -> DocumentFormattingResponse -> FromServerMessage
RspDocumentRangeFormatting (DocumentFormattingResponse -> FromServerMessage)
-> (ByteString -> DocumentFormattingResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DocumentFormattingResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentOnTypeFormatting  -> DocumentFormattingResponse -> FromServerMessage
RspDocumentOnTypeFormatting (DocumentFormattingResponse -> FromServerMessage)
-> (ByteString -> DocumentFormattingResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DocumentFormattingResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentRename            -> RenameResponse -> FromServerMessage
RspRename (RenameResponse -> FromServerMessage)
-> (ByteString -> RenameResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> RenameResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
WorkspaceExecuteCommand       -> ExecuteCommandResponse -> FromServerMessage
RspExecuteCommand (ExecuteCommandResponse -> FromServerMessage)
-> (ByteString -> ExecuteCommandResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ExecuteCommandResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentDocumentLink      -> DocumentLinkResponse -> FromServerMessage
RspDocumentLink (DocumentLinkResponse -> FromServerMessage)
-> (ByteString -> DocumentLinkResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DocumentLinkResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
DocumentLinkResolve           -> DocumentLinkResolveResponse -> FromServerMessage
RspDocumentLinkResolve (DocumentLinkResolveResponse -> FromServerMessage)
-> (ByteString -> DocumentLinkResolveResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DocumentLinkResolveResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
TextDocumentWillSaveWaitUntil -> DocumentFormattingResponse -> FromServerMessage
RspWillSaveWaitUntil (DocumentFormattingResponse -> FromServerMessage)
-> (ByteString -> DocumentFormattingResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DocumentFormattingResponse
forall a. FromJSON a => ByteString -> a
decoded
  CustomClientMethod{}          -> ExecuteCommandResponse -> FromServerMessage
RspCustomServer (ExecuteCommandResponse -> FromServerMessage)
-> (ByteString -> ExecuteCommandResponse)
-> ByteString
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ExecuteCommandResponse
forall a. FromJSON a => ByteString -> a
decoded
  ClientMethod
x                             -> String -> FromServerMessage
forall a. HasCallStack => String -> a
error (String -> FromServerMessage)
-> (ByteString -> String) -> ByteString -> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ClientMethod -> String
forall a. Show a => a -> String
show ClientMethod
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a request: ") String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
forall a. Show a => a -> String
show
  where decoded :: ByteString -> a
decoded ByteString
x = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Couldn't decode response for the request type: "
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ClientMethod -> String
forall a. Show a => a -> String
show ClientMethod
req String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
x)
                              (ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
x)

decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
decodeFromServerMsg :: RequestMap -> ByteString -> FromServerMessage
decodeFromServerMsg RequestMap
reqMap ByteString
bytes =
  case Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"method" HashMap Text Value
obj of
    Just Value
methodStr -> case Value -> Result ServerMethod
forall a. FromJSON a => Value -> Result a
fromJSON Value
methodStr of
      Success ServerMethod
method -> case ServerMethod
method of
        -- We can work out the type of the message
        ServerMethod
TextDocumentPublishDiagnostics -> PublishDiagnosticsNotification -> FromServerMessage
NotPublishDiagnostics (PublishDiagnosticsNotification -> FromServerMessage)
-> PublishDiagnosticsNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe PublishDiagnosticsNotification
-> PublishDiagnosticsNotification
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe PublishDiagnosticsNotification
 -> PublishDiagnosticsNotification)
-> Maybe PublishDiagnosticsNotification
-> PublishDiagnosticsNotification
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe PublishDiagnosticsNotification
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
        ServerMethod
WindowShowMessage              -> ShowMessageNotification -> FromServerMessage
NotShowMessage (ShowMessageNotification -> FromServerMessage)
-> ShowMessageNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe ShowMessageNotification -> ShowMessageNotification
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ShowMessageNotification -> ShowMessageNotification)
-> Maybe ShowMessageNotification -> ShowMessageNotification
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ShowMessageNotification
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
        ServerMethod
WindowLogMessage               -> LogMessageNotification -> FromServerMessage
NotLogMessage (LogMessageNotification -> FromServerMessage)
-> LogMessageNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe LogMessageNotification -> LogMessageNotification
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe LogMessageNotification -> LogMessageNotification)
-> Maybe LogMessageNotification -> LogMessageNotification
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe LogMessageNotification
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
        ServerMethod
CancelRequestServer            -> CancelNotificationServer -> FromServerMessage
NotCancelRequestFromServer (CancelNotificationServer -> FromServerMessage)
-> CancelNotificationServer -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe CancelNotificationServer -> CancelNotificationServer
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CancelNotificationServer -> CancelNotificationServer)
-> Maybe CancelNotificationServer -> CancelNotificationServer
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe CancelNotificationServer
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
        ServerMethod
Progress                       ->
          Maybe FromServerMessage -> FromServerMessage
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FromServerMessage -> FromServerMessage)
-> Maybe FromServerMessage -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ [Maybe FromServerMessage] -> Maybe FromServerMessage
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [WorkDoneProgressBeginNotification -> FromServerMessage
NotWorkDoneProgressBegin (WorkDoneProgressBeginNotification -> FromServerMessage)
-> Maybe WorkDoneProgressBeginNotification
-> Maybe FromServerMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe WorkDoneProgressBeginNotification
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes, WorkDoneProgressReportNotification -> FromServerMessage
NotWorkDoneProgressReport (WorkDoneProgressReportNotification -> FromServerMessage)
-> Maybe WorkDoneProgressReportNotification
-> Maybe FromServerMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe WorkDoneProgressReportNotification
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes, WorkDoneProgressEndNotification -> FromServerMessage
NotWorkDoneProgressEnd (WorkDoneProgressEndNotification -> FromServerMessage)
-> Maybe WorkDoneProgressEndNotification -> Maybe FromServerMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe WorkDoneProgressEndNotification
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes]
        ServerMethod
WindowWorkDoneProgressCreate   -> WorkDoneProgressCreateRequest -> FromServerMessage
ReqWorkDoneProgressCreate (WorkDoneProgressCreateRequest -> FromServerMessage)
-> WorkDoneProgressCreateRequest -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe WorkDoneProgressCreateRequest
-> WorkDoneProgressCreateRequest
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe WorkDoneProgressCreateRequest
 -> WorkDoneProgressCreateRequest)
-> Maybe WorkDoneProgressCreateRequest
-> WorkDoneProgressCreateRequest
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe WorkDoneProgressCreateRequest
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
        ServerMethod
TelemetryEvent                 -> TelemetryNotification -> FromServerMessage
NotTelemetry (TelemetryNotification -> FromServerMessage)
-> TelemetryNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe TelemetryNotification -> TelemetryNotification
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe TelemetryNotification -> TelemetryNotification)
-> Maybe TelemetryNotification -> TelemetryNotification
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe TelemetryNotification
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
        ServerMethod
WindowShowMessageRequest       -> ShowMessageRequest -> FromServerMessage
ReqShowMessage (ShowMessageRequest -> FromServerMessage)
-> ShowMessageRequest -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe ShowMessageRequest -> ShowMessageRequest
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ShowMessageRequest -> ShowMessageRequest)
-> Maybe ShowMessageRequest -> ShowMessageRequest
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ShowMessageRequest
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
        ServerMethod
ClientRegisterCapability       -> RegisterCapabilityRequest -> FromServerMessage
ReqRegisterCapability (RegisterCapabilityRequest -> FromServerMessage)
-> RegisterCapabilityRequest -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe RegisterCapabilityRequest -> RegisterCapabilityRequest
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe RegisterCapabilityRequest -> RegisterCapabilityRequest)
-> Maybe RegisterCapabilityRequest -> RegisterCapabilityRequest
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe RegisterCapabilityRequest
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
        ServerMethod
ClientUnregisterCapability     -> UnregisterCapabilityRequest -> FromServerMessage
ReqUnregisterCapability (UnregisterCapabilityRequest -> FromServerMessage)
-> UnregisterCapabilityRequest -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe UnregisterCapabilityRequest -> UnregisterCapabilityRequest
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe UnregisterCapabilityRequest -> UnregisterCapabilityRequest)
-> Maybe UnregisterCapabilityRequest -> UnregisterCapabilityRequest
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe UnregisterCapabilityRequest
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
        ServerMethod
WorkspaceApplyEdit             -> ApplyWorkspaceEditRequest -> FromServerMessage
ReqApplyWorkspaceEdit (ApplyWorkspaceEditRequest -> FromServerMessage)
-> ApplyWorkspaceEditRequest -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe ApplyWorkspaceEditRequest -> ApplyWorkspaceEditRequest
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ApplyWorkspaceEditRequest -> ApplyWorkspaceEditRequest)
-> Maybe ApplyWorkspaceEditRequest -> ApplyWorkspaceEditRequest
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ApplyWorkspaceEditRequest
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
        ServerMethod
WorkspaceWorkspaceFolders      -> String -> FromServerMessage
forall a. HasCallStack => String -> a
error String
"ReqWorkspaceFolders not supported yet"
        ServerMethod
WorkspaceConfiguration         -> String -> FromServerMessage
forall a. HasCallStack => String -> a
error String
"ReqWorkspaceConfiguration not supported yet"
        CustomServerMethod Text
_
            | Text
"id" Text -> HashMap Text Value -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` HashMap Text Value
obj Bool -> Bool -> Bool
&& Text
"method" Text -> HashMap Text Value -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` HashMap Text Value
obj -> CustomServerRequest -> FromServerMessage
ReqCustomServer (CustomServerRequest -> FromServerMessage)
-> CustomServerRequest -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe CustomServerRequest -> CustomServerRequest
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CustomServerRequest -> CustomServerRequest)
-> Maybe CustomServerRequest -> CustomServerRequest
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe CustomServerRequest
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
            | Text
"id" Text -> HashMap Text Value -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` HashMap Text Value
obj -> ExecuteCommandResponse -> FromServerMessage
RspCustomServer (ExecuteCommandResponse -> FromServerMessage)
-> ExecuteCommandResponse -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe ExecuteCommandResponse -> ExecuteCommandResponse
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ExecuteCommandResponse -> ExecuteCommandResponse)
-> Maybe ExecuteCommandResponse -> ExecuteCommandResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ExecuteCommandResponse
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes
            | Bool
otherwise -> TelemetryNotification -> FromServerMessage
NotCustomServer (TelemetryNotification -> FromServerMessage)
-> TelemetryNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe TelemetryNotification -> TelemetryNotification
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe TelemetryNotification -> TelemetryNotification)
-> Maybe TelemetryNotification -> TelemetryNotification
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe TelemetryNotification
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes

      Error String
e -> String -> FromServerMessage
forall a. HasCallStack => String -> a
error String
e

    Maybe Value
Nothing -> case ByteString -> Maybe ExecuteCommandResponse
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes :: Maybe (ResponseMessage Value) of
      Just ExecuteCommandResponse
msg -> case LspId -> RequestMap -> Maybe ClientMethod
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (LspIdRsp -> LspId
requestId (LspIdRsp -> LspId) -> LspIdRsp -> LspId
forall a b. (a -> b) -> a -> b
$ ExecuteCommandResponse
msg ExecuteCommandResponse
-> Getting LspIdRsp ExecuteCommandResponse LspIdRsp -> LspIdRsp
forall s a. s -> Getting a s a -> a
^. Getting LspIdRsp ExecuteCommandResponse LspIdRsp
forall s a. HasId s a => Lens' s a
id) RequestMap
reqMap of
        Just ClientMethod
req -> ClientMethod -> ByteString -> FromServerMessage
matchResponseMsgType ClientMethod
req ByteString
bytes -- try to decode it to more specific type
        Maybe ClientMethod
Nothing  -> String -> FromServerMessage
forall a. HasCallStack => String -> a
error String
"Couldn't match up response with request"
      Maybe ExecuteCommandResponse
Nothing -> String -> FromServerMessage
forall a. HasCallStack => String -> a
error String
"Couldn't decode message"
    where obj :: HashMap Text Value
obj = Maybe (HashMap Text Value) -> HashMap Text Value
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (HashMap Text Value) -> HashMap Text Value)
-> Maybe (HashMap Text Value) -> HashMap Text Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (HashMap Text Value)
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes :: Object