module Language.Haskell.LSP.Test.Replay
( replaySession
)
where
import Prelude hiding (id)
import Control.Concurrent
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Text as T
import Language.Haskell.LSP.Capture
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Lens as LSP
import Data.Aeson
import Data.Default
import Data.List
import Data.Maybe
import Control.Lens hiding (List)
import Control.Monad
import System.FilePath
import System.IO
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Test.Compat
import Language.Haskell.LSP.Test.Files
import Language.Haskell.LSP.Test.Decoding
import Language.Haskell.LSP.Test.Messages
import Language.Haskell.LSP.Test.Server
import Language.Haskell.LSP.Test.Session
replaySession :: String
-> FilePath
-> IO ()
replaySession :: String -> String -> IO ()
replaySession String
serverExe String
sessionDir = do
[ByteString]
entries <- ByteString -> [ByteString]
B.lines (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile (String
sessionDir String -> String -> String
</> String
"session.log")
let unswappedEvents :: [Event]
unswappedEvents = (ByteString -> Event) -> [ByteString] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Event -> Event
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Event -> Event)
-> (ByteString -> Maybe Event) -> ByteString -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Event
forall a. FromJSON a => ByteString -> Maybe a
decode) [ByteString]
entries
String
-> Bool -> (Handle -> Handle -> ProcessHandle -> IO ()) -> IO ()
forall a.
String
-> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a
withServer String
serverExe Bool
False ((Handle -> Handle -> ProcessHandle -> IO ()) -> IO ())
-> (Handle -> Handle -> ProcessHandle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
serverIn Handle
serverOut ProcessHandle
serverProc -> do
Int
pid <- ProcessHandle -> IO Int
getProcessID ProcessHandle
serverProc
[Event]
events <- Int -> [Event] -> [Event]
swapCommands Int
pid ([Event] -> [Event]) -> IO [Event] -> IO [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [Event] -> IO [Event]
swapFiles String
sessionDir [Event]
unswappedEvents
let clientEvents :: [Event]
clientEvents = (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
filter Event -> Bool
isClientMsg [Event]
events
serverEvents :: [Event]
serverEvents = (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
filter Event -> Bool
isServerMsg [Event]
events
clientMsgs :: [FromClientMessage]
clientMsgs = (Event -> FromClientMessage) -> [Event] -> [FromClientMessage]
forall a b. (a -> b) -> [a] -> [b]
map (\(FromClient UTCTime
_ FromClientMessage
msg) -> FromClientMessage
msg) [Event]
clientEvents
serverMsgs :: [FromServerMessage]
serverMsgs = (FromServerMessage -> Bool)
-> [FromServerMessage] -> [FromServerMessage]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (FromServerMessage -> Bool) -> FromServerMessage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromServerMessage -> Bool
shouldSkip) ([FromServerMessage] -> [FromServerMessage])
-> [FromServerMessage] -> [FromServerMessage]
forall a b. (a -> b) -> a -> b
$ (Event -> FromServerMessage) -> [Event] -> [FromServerMessage]
forall a b. (a -> b) -> [a] -> [b]
map (\(FromServer UTCTime
_ FromServerMessage
msg) -> FromServerMessage
msg) [Event]
serverEvents
requestMap :: RequestMap
requestMap = [FromClientMessage] -> RequestMap
getRequestMap [FromClientMessage]
clientMsgs
MVar LspId
reqSema <- IO (MVar LspId)
forall a. IO (MVar a)
newEmptyMVar
MVar LspIdRsp
rspSema <- IO (MVar LspIdRsp)
forall a. IO (MVar a)
newEmptyMVar
MVar ()
passSema <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
ThreadId
mainThread <- IO ThreadId
myThreadId
ThreadId
sessionThread <- IO ThreadId -> IO ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
Handle
-> Handle
-> ProcessHandle
-> (Handle -> SessionContext -> IO ())
-> SessionConfig
-> ClientCapabilities
-> String
-> Session ()
-> Session ()
-> IO ()
forall a.
Handle
-> Handle
-> ProcessHandle
-> (Handle -> SessionContext -> IO ())
-> SessionConfig
-> ClientCapabilities
-> String
-> Session ()
-> Session a
-> IO a
runSessionWithHandles Handle
serverIn Handle
serverOut ProcessHandle
serverProc
([FromServerMessage]
-> RequestMap
-> MVar LspId
-> MVar LspIdRsp
-> MVar ()
-> ThreadId
-> Handle
-> SessionContext
-> IO ()
listenServer [FromServerMessage]
serverMsgs RequestMap
requestMap MVar LspId
reqSema MVar LspIdRsp
rspSema MVar ()
passSema ThreadId
mainThread)
SessionConfig
forall a. Default a => a
def
ClientCapabilities
fullCaps
String
sessionDir
(() -> Session ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
([FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages [FromClientMessage]
clientMsgs MVar LspId
reqSema MVar LspIdRsp
rspSema)
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
passSema
ThreadId -> IO ()
killThread ThreadId
sessionThread
where
isClientMsg :: Event -> Bool
isClientMsg (FromClient UTCTime
_ FromClientMessage
_) = Bool
True
isClientMsg Event
_ = Bool
False
isServerMsg :: Event -> Bool
isServerMsg (FromServer UTCTime
_ FromServerMessage
_) = Bool
True
isServerMsg Event
_ = Bool
False
sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages [] MVar LspId
_ MVar LspIdRsp
_ = () -> Session ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendMessages (FromClientMessage
nextMsg:[FromClientMessage]
remainingMsgs) MVar LspId
reqSema MVar LspIdRsp
rspSema =
(forall b c.
(ToJSON b, ToJSON c) =>
RequestMessage ClientMethod b c -> Session ())
-> (forall d. ToJSON d => ResponseMessage d -> Session ())
-> (forall e.
ToJSON e =>
NotificationMessage ClientMethod e -> Session ())
-> FromClientMessage
-> Session ()
forall a.
(forall b c.
(ToJSON b, ToJSON c) =>
RequestMessage ClientMethod b c -> a)
-> (forall d. ToJSON d => ResponseMessage d -> a)
-> (forall e. ToJSON e => NotificationMessage ClientMethod e -> a)
-> FromClientMessage
-> a
handleClientMessage forall b c.
(ToJSON b, ToJSON c) =>
RequestMessage ClientMethod b c -> Session ()
request forall d. ToJSON d => ResponseMessage d -> Session ()
response forall e.
ToJSON e =>
NotificationMessage ClientMethod e -> Session ()
notification FromClientMessage
nextMsg
where
notification :: NotificationMessage ClientMethod a -> Session ()
notification msg :: NotificationMessage ClientMethod a
msg@(NotificationMessage Text
_ ClientMethod
Exit a
_) = do
IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Will send exit notification soon"
IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
10000000
NotificationMessage ClientMethod a -> Session ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage NotificationMessage ClientMethod a
msg
IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"Done"
notification msg :: NotificationMessage ClientMethod a
msg@(NotificationMessage Text
_ ClientMethod
m a
_) = do
NotificationMessage ClientMethod a -> Session ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage NotificationMessage ClientMethod a
msg
IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sent a notification " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ClientMethod -> String
forall a. Show a => a -> String
show ClientMethod
m
[FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages [FromClientMessage]
remainingMsgs MVar LspId
reqSema MVar LspIdRsp
rspSema
request :: RequestMessage ClientMethod a b -> Session ()
request msg :: RequestMessage ClientMethod a b
msg@(RequestMessage Text
_ LspId
id ClientMethod
m a
_) = do
RequestMessage ClientMethod a b -> Session ()
forall b c.
(ToJSON b, ToJSON c) =>
RequestMessage ClientMethod b c -> Session ()
sendRequestMessage RequestMessage ClientMethod a b
msg
IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sent a request id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show LspId
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ClientMethod -> String
forall a. Show a => a -> String
show ClientMethod
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nWaiting for a response"
LspIdRsp
rsp <- IO LspIdRsp -> Session LspIdRsp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LspIdRsp -> Session LspIdRsp)
-> IO LspIdRsp -> Session LspIdRsp
forall a b. (a -> b) -> a -> b
$ MVar LspIdRsp -> IO LspIdRsp
forall a. MVar a -> IO a
takeMVar MVar LspIdRsp
rspSema
Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LspId -> LspIdRsp
responseId LspId
id LspIdRsp -> LspIdRsp -> Bool
forall a. Eq a => a -> a -> Bool
/= LspIdRsp
rsp) (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$
String -> Session ()
forall a. HasCallStack => String -> a
error (String -> Session ()) -> String -> Session ()
forall a b. (a -> b) -> a -> b
$ String
"Expected id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show LspId
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspIdRsp -> String
forall a. Show a => a -> String
show LspIdRsp
rsp
[FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages [FromClientMessage]
remainingMsgs MVar LspId
reqSema MVar LspIdRsp
rspSema
response :: ResponseMessage a -> Session ()
response msg :: ResponseMessage a
msg@(ResponseMessage Text
_ LspIdRsp
id Either ResponseError a
_) = do
IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Waiting for request id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspIdRsp -> String
forall a. Show a => a -> String
show LspIdRsp
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from the server"
LspId
reqId <- IO LspId -> Session LspId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LspId -> Session LspId) -> IO LspId -> Session LspId
forall a b. (a -> b) -> a -> b
$ MVar LspId -> IO LspId
forall a. MVar a -> IO a
takeMVar MVar LspId
reqSema
if LspId -> LspIdRsp
responseId LspId
reqId LspIdRsp -> LspIdRsp -> Bool
forall a. Eq a => a -> a -> Bool
/= LspIdRsp
id
then String -> Session ()
forall a. HasCallStack => String -> a
error (String -> Session ()) -> String -> Session ()
forall a b. (a -> b) -> a -> b
$ String
"Expected id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show LspId
reqId String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show LspId
reqId
else do
ResponseMessage a -> Session ()
forall d. ToJSON d => ResponseMessage d -> Session ()
sendResponse ResponseMessage a
msg
IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sent response to request id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspIdRsp -> String
forall a. Show a => a -> String
show LspIdRsp
id
[FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages [FromClientMessage]
remainingMsgs MVar LspId
reqSema MVar LspIdRsp
rspSema
sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
sendRequestMessage :: RequestMessage ClientMethod a b -> Session ()
sendRequestMessage RequestMessage ClientMethod a b
req = do
MVar RequestMap
reqMap <- SessionContext -> MVar RequestMap
requestMap (SessionContext -> MVar RequestMap)
-> Session SessionContext -> Session (MVar RequestMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session SessionContext
forall r (m :: * -> *). HasReader r m => m r
ask
IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ MVar RequestMap -> (RequestMap -> IO RequestMap) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar RequestMap
reqMap ((RequestMap -> IO RequestMap) -> IO ())
-> (RequestMap -> IO RequestMap) -> IO ()
forall a b. (a -> b) -> a -> b
$
\RequestMap
r -> RequestMap -> IO RequestMap
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestMap -> IO RequestMap) -> RequestMap -> IO RequestMap
forall a b. (a -> b) -> a -> b
$ RequestMap -> LspId -> ClientMethod -> RequestMap
updateRequestMap RequestMap
r (RequestMessage ClientMethod a b
req RequestMessage ClientMethod a b
-> Getting LspId (RequestMessage ClientMethod a b) LspId -> LspId
forall s a. s -> Getting a s a -> a
^. Getting LspId (RequestMessage ClientMethod a b) LspId
forall s a. HasId s a => Lens' s a
LSP.id) (RequestMessage ClientMethod a b
req RequestMessage ClientMethod a b
-> Getting
ClientMethod (RequestMessage ClientMethod a b) ClientMethod
-> ClientMethod
forall s a. s -> Getting a s a -> a
^. Getting ClientMethod (RequestMessage ClientMethod a b) ClientMethod
forall s a. HasMethod s a => Lens' s a
method)
RequestMessage ClientMethod a b -> Session ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage RequestMessage ClientMethod a b
req
isNotification :: FromServerMessage -> Bool
isNotification :: FromServerMessage -> Bool
isNotification (NotPublishDiagnostics PublishDiagnosticsNotification
_) = Bool
True
isNotification (NotLogMessage LogMessageNotification
_) = Bool
True
isNotification (NotShowMessage ShowMessageNotification
_) = Bool
True
isNotification (NotCancelRequestFromServer CancelNotificationServer
_) = Bool
True
isNotification FromServerMessage
_ = Bool
False
listenServer :: [FromServerMessage]
-> RequestMap
-> MVar LspId
-> MVar LspIdRsp
-> MVar ()
-> ThreadId
-> Handle
-> SessionContext
-> IO ()
listenServer :: [FromServerMessage]
-> RequestMap
-> MVar LspId
-> MVar LspIdRsp
-> MVar ()
-> ThreadId
-> Handle
-> SessionContext
-> IO ()
listenServer [] RequestMap
_ MVar LspId
_ MVar LspIdRsp
_ MVar ()
passSema ThreadId
_ Handle
_ SessionContext
_ = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
passSema ()
listenServer [FromServerMessage]
expectedMsgs RequestMap
reqMap MVar LspId
reqSema MVar LspIdRsp
rspSema MVar ()
passSema ThreadId
mainThreadId Handle
serverOut SessionContext
ctx = do
ByteString
msgBytes <- Handle -> IO ByteString
getNextMessage Handle
serverOut
let msg :: FromServerMessage
msg = RequestMap -> ByteString -> FromServerMessage
decodeFromServerMsg RequestMap
reqMap ByteString
msgBytes
(forall b c. RequestMessage ServerMethod b c -> IO ())
-> (forall d. ResponseMessage d -> IO ())
-> (forall e. NotificationMessage ServerMethod e -> IO ())
-> FromServerMessage
-> IO ()
forall a.
(forall b c. RequestMessage ServerMethod b c -> a)
-> (forall d. ResponseMessage d -> a)
-> (forall e. NotificationMessage ServerMethod e -> a)
-> FromServerMessage
-> a
handleServerMessage forall b c. RequestMessage ServerMethod b c -> IO ()
request forall d. ResponseMessage d -> IO ()
response forall e. NotificationMessage ServerMethod e -> IO ()
notification FromServerMessage
msg
if FromServerMessage -> Bool
shouldSkip FromServerMessage
msg
then [FromServerMessage]
-> RequestMap
-> MVar LspId
-> MVar LspIdRsp
-> MVar ()
-> ThreadId
-> Handle
-> SessionContext
-> IO ()
listenServer [FromServerMessage]
expectedMsgs RequestMap
reqMap MVar LspId
reqSema MVar LspIdRsp
rspSema MVar ()
passSema ThreadId
mainThreadId Handle
serverOut SessionContext
ctx
else if FromServerMessage -> [FromServerMessage] -> Bool
inRightOrder FromServerMessage
msg [FromServerMessage]
expectedMsgs
then [FromServerMessage]
-> RequestMap
-> MVar LspId
-> MVar LspIdRsp
-> MVar ()
-> ThreadId
-> Handle
-> SessionContext
-> IO ()
listenServer (FromServerMessage -> [FromServerMessage] -> [FromServerMessage]
forall a. Eq a => a -> [a] -> [a]
delete FromServerMessage
msg [FromServerMessage]
expectedMsgs) RequestMap
reqMap MVar LspId
reqSema MVar LspIdRsp
rspSema MVar ()
passSema ThreadId
mainThreadId Handle
serverOut SessionContext
ctx
else let remainingMsgs :: [FromServerMessage]
remainingMsgs = (FromServerMessage -> Bool)
-> [FromServerMessage] -> [FromServerMessage]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool)
-> (FromServerMessage -> Bool) -> FromServerMessage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromServerMessage -> Bool
isNotification) [FromServerMessage]
expectedMsgs
[FromServerMessage] -> [FromServerMessage] -> [FromServerMessage]
forall a. [a] -> [a] -> [a]
++ [[FromServerMessage] -> FromServerMessage
forall a. [a] -> a
head ([FromServerMessage] -> FromServerMessage)
-> [FromServerMessage] -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool)
-> [FromServerMessage] -> [FromServerMessage]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile FromServerMessage -> Bool
isNotification [FromServerMessage]
expectedMsgs]
exc :: SessionException
exc = FromServerMessage -> [FromServerMessage] -> SessionException
ReplayOutOfOrder FromServerMessage
msg [FromServerMessage]
remainingMsgs
in IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> SessionException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
mainThreadId SessionException
exc
where
response :: ResponseMessage a -> IO ()
response :: ResponseMessage a -> IO ()
response ResponseMessage a
res = do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Got response for id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspIdRsp -> String
forall a. Show a => a -> String
show (ResponseMessage a
res ResponseMessage a
-> Getting LspIdRsp (ResponseMessage a) LspIdRsp -> LspIdRsp
forall s a. s -> Getting a s a -> a
^. Getting LspIdRsp (ResponseMessage a) LspIdRsp
forall s a. HasId s a => Lens' s a
id)
MVar LspIdRsp -> LspIdRsp -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar LspIdRsp
rspSema (ResponseMessage a
res ResponseMessage a
-> Getting LspIdRsp (ResponseMessage a) LspIdRsp -> LspIdRsp
forall s a. s -> Getting a s a -> a
^. Getting LspIdRsp (ResponseMessage a) LspIdRsp
forall s a. HasId s a => Lens' s a
id)
request :: RequestMessage ServerMethod a b -> IO ()
request :: RequestMessage ServerMethod a b -> IO ()
request RequestMessage ServerMethod a b
req = do
String -> IO ()
putStrLn
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Got request for id "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show (RequestMessage ServerMethod a b
req RequestMessage ServerMethod a b
-> Getting LspId (RequestMessage ServerMethod a b) LspId -> LspId
forall s a. s -> Getting a s a -> a
^. Getting LspId (RequestMessage ServerMethod a b) LspId
forall s a. HasId s a => Lens' s a
id)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ServerMethod -> String
forall a. Show a => a -> String
show (RequestMessage ServerMethod a b
req RequestMessage ServerMethod a b
-> Getting
ServerMethod (RequestMessage ServerMethod a b) ServerMethod
-> ServerMethod
forall s a. s -> Getting a s a -> a
^. Getting ServerMethod (RequestMessage ServerMethod a b) ServerMethod
forall s a. HasMethod s a => Lens' s a
method)
MVar LspId -> LspId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar LspId
reqSema (RequestMessage ServerMethod a b
req RequestMessage ServerMethod a b
-> Getting LspId (RequestMessage ServerMethod a b) LspId -> LspId
forall s a. s -> Getting a s a -> a
^. Getting LspId (RequestMessage ServerMethod a b) LspId
forall s a. HasId s a => Lens' s a
id)
notification :: NotificationMessage ServerMethod a -> IO ()
notification :: NotificationMessage ServerMethod a -> IO ()
notification NotificationMessage ServerMethod a
n = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Got notification " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ServerMethod -> String
forall a. Show a => a -> String
show (NotificationMessage ServerMethod a
n NotificationMessage ServerMethod a
-> Getting
ServerMethod (NotificationMessage ServerMethod a) ServerMethod
-> ServerMethod
forall s a. s -> Getting a s a -> a
^. Getting
ServerMethod (NotificationMessage ServerMethod a) ServerMethod
forall s a. HasMethod s a => Lens' s a
method)
inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
inRightOrder FromServerMessage
_ [] = String -> Bool
forall a. HasCallStack => String -> a
error String
"Why is this empty"
inRightOrder FromServerMessage
received (FromServerMessage
expected : [FromServerMessage]
msgs)
| FromServerMessage
received FromServerMessage -> FromServerMessage -> Bool
forall a. Eq a => a -> a -> Bool
== FromServerMessage
expected = Bool
True
| FromServerMessage -> Bool
isNotification FromServerMessage
expected = FromServerMessage -> [FromServerMessage] -> Bool
inRightOrder FromServerMessage
received [FromServerMessage]
msgs
| Bool
otherwise = Bool
False
shouldSkip :: FromServerMessage -> Bool
shouldSkip :: FromServerMessage -> Bool
shouldSkip (NotLogMessage LogMessageNotification
_) = Bool
True
shouldSkip (NotShowMessage ShowMessageNotification
_) = Bool
True
shouldSkip (ReqShowMessage ShowMessageRequest
_) = Bool
True
shouldSkip FromServerMessage
_ = Bool
False
swapCommands :: Int -> [Event] -> [Event]
swapCommands :: Int -> [Event] -> [Event]
swapCommands Int
_ [] = []
swapCommands Int
pid (FromClient UTCTime
t (ReqExecuteCommand ExecuteCommandRequest
req):[Event]
xs) = UTCTime -> FromClientMessage -> Event
FromClient UTCTime
t (ExecuteCommandRequest -> FromClientMessage
ReqExecuteCommand ExecuteCommandRequest
swapped)Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:Int -> [Event] -> [Event]
swapCommands Int
pid [Event]
xs
where swapped :: ExecuteCommandRequest
swapped = (ExecuteCommandParams -> Identity ExecuteCommandParams)
-> ExecuteCommandRequest -> Identity ExecuteCommandRequest
forall s a. HasParams s a => Lens' s a
params ((ExecuteCommandParams -> Identity ExecuteCommandParams)
-> ExecuteCommandRequest -> Identity ExecuteCommandRequest)
-> ((Text -> Identity Text)
-> ExecuteCommandParams -> Identity ExecuteCommandParams)
-> (Text -> Identity Text)
-> ExecuteCommandRequest
-> Identity ExecuteCommandRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Identity Text)
-> ExecuteCommandParams -> Identity ExecuteCommandParams
forall s a. HasCommand s a => Lens' s a
command ((Text -> Identity Text)
-> ExecuteCommandRequest -> Identity ExecuteCommandRequest)
-> Text -> ExecuteCommandRequest -> ExecuteCommandRequest
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
newCmd (ExecuteCommandRequest -> ExecuteCommandRequest)
-> ExecuteCommandRequest -> ExecuteCommandRequest
forall a b. (a -> b) -> a -> b
$ ExecuteCommandRequest
req
newCmd :: Text
newCmd = Int -> Text -> Text
swapPid Int
pid (ExecuteCommandRequest
req ExecuteCommandRequest
-> Getting Text ExecuteCommandRequest Text -> Text
forall s a. s -> Getting a s a -> a
^. (ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> ExecuteCommandRequest -> Const Text ExecuteCommandRequest
forall s a. HasParams s a => Lens' s a
params ((ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> ExecuteCommandRequest -> Const Text ExecuteCommandRequest)
-> ((Text -> Const Text Text)
-> ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> Getting Text ExecuteCommandRequest Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> ExecuteCommandParams -> Const Text ExecuteCommandParams
forall s a. HasCommand s a => Lens' s a
command)
swapCommands Int
pid (FromServer UTCTime
t (RspInitialize InitializeResponse
rsp):[Event]
xs) = UTCTime -> FromServerMessage -> Event
FromServer UTCTime
t (InitializeResponse -> FromServerMessage
RspInitialize InitializeResponse
swapped)Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:Int -> [Event] -> [Event]
swapCommands Int
pid [Event]
xs
where swapped :: InitializeResponse
swapped = case Maybe (List Text)
newCommands of
Just List Text
cmds -> (Either ResponseError InitializeResponseCapabilities
-> Identity (Either ResponseError InitializeResponseCapabilities))
-> InitializeResponse -> Identity InitializeResponse
forall s a. HasResult s a => Lens' s a
result ((Either ResponseError InitializeResponseCapabilities
-> Identity (Either ResponseError InitializeResponseCapabilities))
-> InitializeResponse -> Identity InitializeResponse)
-> ((List Text -> Identity (List Text))
-> Either ResponseError InitializeResponseCapabilities
-> Identity (Either ResponseError InitializeResponseCapabilities))
-> (List Text -> Identity (List Text))
-> InitializeResponse
-> Identity InitializeResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializeResponseCapabilities
-> Identity InitializeResponseCapabilities)
-> Either ResponseError InitializeResponseCapabilities
-> Identity (Either ResponseError InitializeResponseCapabilities)
forall c a b. Prism (Either c a) (Either c b) a b
_Right ((InitializeResponseCapabilities
-> Identity InitializeResponseCapabilities)
-> Either ResponseError InitializeResponseCapabilities
-> Identity (Either ResponseError InitializeResponseCapabilities))
-> ((List Text -> Identity (List Text))
-> InitializeResponseCapabilities
-> Identity InitializeResponseCapabilities)
-> (List Text -> Identity (List Text))
-> Either ResponseError InitializeResponseCapabilities
-> Identity (Either ResponseError InitializeResponseCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializeResponseCapabilitiesInner
-> Identity InitializeResponseCapabilitiesInner)
-> InitializeResponseCapabilities
-> Identity InitializeResponseCapabilities
forall s a. HasCapabilities s a => Lens' s a
LSP.capabilities ((InitializeResponseCapabilitiesInner
-> Identity InitializeResponseCapabilitiesInner)
-> InitializeResponseCapabilities
-> Identity InitializeResponseCapabilities)
-> ((List Text -> Identity (List Text))
-> InitializeResponseCapabilitiesInner
-> Identity InitializeResponseCapabilitiesInner)
-> (List Text -> Identity (List Text))
-> InitializeResponseCapabilities
-> Identity InitializeResponseCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ExecuteCommandOptions
-> Identity (Maybe ExecuteCommandOptions))
-> InitializeResponseCapabilitiesInner
-> Identity InitializeResponseCapabilitiesInner
forall s a. HasExecuteCommandProvider s a => Lens' s a
executeCommandProvider ((Maybe ExecuteCommandOptions
-> Identity (Maybe ExecuteCommandOptions))
-> InitializeResponseCapabilitiesInner
-> Identity InitializeResponseCapabilitiesInner)
-> ((List Text -> Identity (List Text))
-> Maybe ExecuteCommandOptions
-> Identity (Maybe ExecuteCommandOptions))
-> (List Text -> Identity (List Text))
-> InitializeResponseCapabilitiesInner
-> Identity InitializeResponseCapabilitiesInner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExecuteCommandOptions -> Identity ExecuteCommandOptions)
-> Maybe ExecuteCommandOptions
-> Identity (Maybe ExecuteCommandOptions)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ExecuteCommandOptions -> Identity ExecuteCommandOptions)
-> Maybe ExecuteCommandOptions
-> Identity (Maybe ExecuteCommandOptions))
-> ((List Text -> Identity (List Text))
-> ExecuteCommandOptions -> Identity ExecuteCommandOptions)
-> (List Text -> Identity (List Text))
-> Maybe ExecuteCommandOptions
-> Identity (Maybe ExecuteCommandOptions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Text -> Identity (List Text))
-> ExecuteCommandOptions -> Identity ExecuteCommandOptions
forall s a. HasCommands s a => Lens' s a
commands ((List Text -> Identity (List Text))
-> InitializeResponse -> Identity InitializeResponse)
-> List Text -> InitializeResponse -> InitializeResponse
forall s t a b. ASetter s t a b -> b -> s -> t
.~ List Text
cmds (InitializeResponse -> InitializeResponse)
-> InitializeResponse -> InitializeResponse
forall a b. (a -> b) -> a -> b
$ InitializeResponse
rsp
Maybe (List Text)
Nothing -> InitializeResponse
rsp
oldCommands :: Maybe (List Text)
oldCommands = InitializeResponse
rsp InitializeResponse
-> Getting (First (List Text)) InitializeResponse (List Text)
-> Maybe (List Text)
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Either ResponseError InitializeResponseCapabilities
-> Const
(First (List Text))
(Either ResponseError InitializeResponseCapabilities))
-> InitializeResponse
-> Const (First (List Text)) InitializeResponse
forall s a. HasResult s a => Lens' s a
result ((Either ResponseError InitializeResponseCapabilities
-> Const
(First (List Text))
(Either ResponseError InitializeResponseCapabilities))
-> InitializeResponse
-> Const (First (List Text)) InitializeResponse)
-> ((List Text -> Const (First (List Text)) (List Text))
-> Either ResponseError InitializeResponseCapabilities
-> Const
(First (List Text))
(Either ResponseError InitializeResponseCapabilities))
-> Getting (First (List Text)) InitializeResponse (List Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializeResponseCapabilities
-> Const (First (List Text)) InitializeResponseCapabilities)
-> Either ResponseError InitializeResponseCapabilities
-> Const
(First (List Text))
(Either ResponseError InitializeResponseCapabilities)
forall c a b. Prism (Either c a) (Either c b) a b
_Right ((InitializeResponseCapabilities
-> Const (First (List Text)) InitializeResponseCapabilities)
-> Either ResponseError InitializeResponseCapabilities
-> Const
(First (List Text))
(Either ResponseError InitializeResponseCapabilities))
-> ((List Text -> Const (First (List Text)) (List Text))
-> InitializeResponseCapabilities
-> Const (First (List Text)) InitializeResponseCapabilities)
-> (List Text -> Const (First (List Text)) (List Text))
-> Either ResponseError InitializeResponseCapabilities
-> Const
(First (List Text))
(Either ResponseError InitializeResponseCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializeResponseCapabilitiesInner
-> Const (First (List Text)) InitializeResponseCapabilitiesInner)
-> InitializeResponseCapabilities
-> Const (First (List Text)) InitializeResponseCapabilities
forall s a. HasCapabilities s a => Lens' s a
LSP.capabilities ((InitializeResponseCapabilitiesInner
-> Const (First (List Text)) InitializeResponseCapabilitiesInner)
-> InitializeResponseCapabilities
-> Const (First (List Text)) InitializeResponseCapabilities)
-> ((List Text -> Const (First (List Text)) (List Text))
-> InitializeResponseCapabilitiesInner
-> Const (First (List Text)) InitializeResponseCapabilitiesInner)
-> (List Text -> Const (First (List Text)) (List Text))
-> InitializeResponseCapabilities
-> Const (First (List Text)) InitializeResponseCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ExecuteCommandOptions
-> Const (First (List Text)) (Maybe ExecuteCommandOptions))
-> InitializeResponseCapabilitiesInner
-> Const (First (List Text)) InitializeResponseCapabilitiesInner
forall s a. HasExecuteCommandProvider s a => Lens' s a
executeCommandProvider ((Maybe ExecuteCommandOptions
-> Const (First (List Text)) (Maybe ExecuteCommandOptions))
-> InitializeResponseCapabilitiesInner
-> Const (First (List Text)) InitializeResponseCapabilitiesInner)
-> ((List Text -> Const (First (List Text)) (List Text))
-> Maybe ExecuteCommandOptions
-> Const (First (List Text)) (Maybe ExecuteCommandOptions))
-> (List Text -> Const (First (List Text)) (List Text))
-> InitializeResponseCapabilitiesInner
-> Const (First (List Text)) InitializeResponseCapabilitiesInner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExecuteCommandOptions
-> Const (First (List Text)) ExecuteCommandOptions)
-> Maybe ExecuteCommandOptions
-> Const (First (List Text)) (Maybe ExecuteCommandOptions)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ExecuteCommandOptions
-> Const (First (List Text)) ExecuteCommandOptions)
-> Maybe ExecuteCommandOptions
-> Const (First (List Text)) (Maybe ExecuteCommandOptions))
-> ((List Text -> Const (First (List Text)) (List Text))
-> ExecuteCommandOptions
-> Const (First (List Text)) ExecuteCommandOptions)
-> (List Text -> Const (First (List Text)) (List Text))
-> Maybe ExecuteCommandOptions
-> Const (First (List Text)) (Maybe ExecuteCommandOptions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Text -> Const (First (List Text)) (List Text))
-> ExecuteCommandOptions
-> Const (First (List Text)) ExecuteCommandOptions
forall s a. HasCommands s a => Lens' s a
commands
newCommands :: Maybe (List Text)
newCommands = (List Text -> List Text) -> Maybe (List Text) -> Maybe (List Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Text) -> List Text -> List Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Text -> Text
swapPid Int
pid)) Maybe (List Text)
oldCommands
swapCommands Int
pid (Event
x:[Event]
xs) = Event
xEvent -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:Int -> [Event] -> [Event]
swapCommands Int
pid [Event]
xs
hasPid :: T.Text -> Bool
hasPid :: Text -> Bool
hasPid = (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> (Text -> Int) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length (Text -> Int) -> (Text -> Text) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.filter (Char
':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)
swapPid :: Int -> T.Text -> T.Text
swapPid :: Int -> Text -> Text
swapPid Int
pid Text
t
| Text -> Bool
hasPid Text
t = Text -> Text -> Text
T.append (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
pid) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') Text
t
| Bool
otherwise = Text
t