{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeInType #-}
{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
skipTimeout <- overridingTimeout <$> get
timeoutId <- getCurTimeoutId
- unless skipTimeout $ do
+ mtid <-
+ if skipTimeout
+ then pure Nothing
+ else Just <$> do
chan <- asks messageChan
timeout <- asks (messageTimeout . config)
- void $ liftIO $ forkIO $ do
+ liftIO $ forkIO $ do
threadDelay (timeout * 1000000)
writeChan chan (TimeoutMessage timeoutId)
x <- Session await
- unless skipTimeout (bumpTimeoutId timeoutId)
+ forM_ mtid $ \tid -> do
+ bumpTimeoutId timeoutId
+ liftIO $ killThread tid
modify $ \s -> s { lastReceivedMessage = Just x }
-- | Matches a request or a notification coming from the server.
message :: SServerMethod m -> Session (ServerMessage m)
-message m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case
FromServerMess m2 msg -> do
- HRefl <- mEqServer m1 m2
- pure msg
+ res <- mEqServer m1 m2
+ case res of
+ Right HRefl -> pure msg
+ Left f -> Nothing
_ -> Nothing
customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))
-- | Matches a response coming from the server.
response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)
-response m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+response m1 = named (T.pack $ "Response for: " <> show m1) $ satisfyMaybe $ \case
FromServerRsp m2 msg -> do
- HRefl <- mEqClient m1 m2
+ HRefl <- runEq mEqClient m1 m2
pure msg
_ -> Nothing
satisfyMaybe $ \msg -> do
case msg of
FromServerMess _ _ -> Nothing
- FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) ->
- case mEqClient m m' of
- Just HRefl -> do
- guard (lid' == Just lid)
+ FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) -> do
+ HRefl <- runEq mEqClient m m'
+ guard (Just lid == lid')
pure rspMsg
- Nothing
- | SCustomMethod tm <- m
- , SCustomMethod tm' <- m'
- , tm == tm'
- , lid' == Just lid -> pure rspMsg
- _ -> empty
-- | Matches any type of message.
anyMessage :: Session FromServerMessage
shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
shouldSkip _ = False
--- | Matches a 'Language.LSP.Test.PublishDiagnosticsNotification'
+-- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'
-- (textDocument/publishDiagnostics) notification.
-publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
+publishDiagnosticsNotification :: Session (Message TextDocumentPublishDiagnostics)
publishDiagnosticsNotification = named "Publish diagnostics notification" $
satisfyMaybe $ \msg -> case msg of
FromServerMess STextDocumentPublishDiagnostics diags -> Just diags