{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.LSP.Test.Parsing
(
satisfy
, satisfyMaybe
, message
, anyRequest
, anyResponse
, anyNotification
, anyMessage
, loggingNotification
, publishDiagnosticsNotification
, responseForId
) where
import Control.Applicative
import Control.Concurrent
import Control.Lens
import Control.Monad.IO.Class
import Control.Monad
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Conduit.Parser hiding (named)
import qualified Data.Conduit.Parser (named)
import qualified Data.Text as T
import Data.Typeable
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types
import qualified Language.Haskell.LSP.Types.Lens as LSP
import Language.Haskell.LSP.Test.Messages
import Language.Haskell.LSP.Test.Session
satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy FromServerMessage -> Bool
pred = (FromServerMessage -> Maybe FromServerMessage)
-> Session FromServerMessage
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe (\FromServerMessage
msg -> if FromServerMessage -> Bool
pred FromServerMessage
msg then FromServerMessage -> Maybe FromServerMessage
forall a. a -> Maybe a
Just FromServerMessage
msg else Maybe FromServerMessage
forall a. Maybe a
Nothing)
satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe FromServerMessage -> Maybe a
pred = do
Bool
skipTimeout <- SessionState -> Bool
overridingTimeout (SessionState -> Bool) -> Session SessionState -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session SessionState
forall s (m :: * -> *). HasState s m => m s
get
Int
timeoutId <- Session Int
forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
m Int
getCurTimeoutId
Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
skipTimeout (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ do
Chan SessionMessage
chan <- (SessionContext -> Chan SessionMessage)
-> Session (Chan SessionMessage)
forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks SessionContext -> Chan SessionMessage
messageChan
Int
timeout <- (SessionContext -> Int) -> Session Int
forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks (SessionConfig -> Int
messageTimeout (SessionConfig -> Int)
-> (SessionContext -> SessionConfig) -> SessionContext -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionContext -> SessionConfig
config)
Session ThreadId -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Session ThreadId -> Session ()) -> Session ThreadId -> Session ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> Session ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> Session ThreadId)
-> IO ThreadId -> Session 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
$ do
Int -> IO ()
threadDelay (Int
timeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
Chan SessionMessage -> SessionMessage -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan SessionMessage
chan (Int -> SessionMessage
TimeoutMessage Int
timeoutId)
FromServerMessage
x <- ConduitParser
FromServerMessage
(StateT SessionState (ReaderT SessionContext IO))
FromServerMessage
-> Session FromServerMessage
forall a.
ConduitParser
FromServerMessage
(StateT SessionState (ReaderT SessionContext IO))
a
-> Session a
Session ConduitParser
FromServerMessage
(StateT SessionState (ReaderT SessionContext IO))
FromServerMessage
forall (m :: * -> *) i. Monad m => ConduitParser i m i
await
Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
skipTimeout (Int -> Session ()
forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
Int -> m ()
bumpTimeoutId Int
timeoutId)
(SessionState -> SessionState) -> Session ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> Session ())
-> (SessionState -> SessionState) -> Session ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> SessionState
s { lastReceivedMessage :: Maybe FromServerMessage
lastReceivedMessage = FromServerMessage -> Maybe FromServerMessage
forall a. a -> Maybe a
Just FromServerMessage
x }
case FromServerMessage -> Maybe a
pred FromServerMessage
x of
Just a
a -> do
LogMsgType -> FromServerMessage -> Session ()
forall a (m :: * -> *).
(ToJSON a, MonadIO m, HasReader SessionContext m) =>
LogMsgType -> a -> m ()
logMsg LogMsgType
LogServer FromServerMessage
x
a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Maybe a
Nothing -> Session a
forall (f :: * -> *) a. Alternative f => f a
empty
named :: T.Text -> Session a -> Session a
named :: Text -> Session a -> Session a
named Text
s (Session ConduitParser
FromServerMessage
(StateT SessionState (ReaderT SessionContext IO))
a
x) = ConduitParser
FromServerMessage
(StateT SessionState (ReaderT SessionContext IO))
a
-> Session a
forall a.
ConduitParser
FromServerMessage
(StateT SessionState (ReaderT SessionContext IO))
a
-> Session a
Session (Text
-> ConduitParser
FromServerMessage
(StateT SessionState (ReaderT SessionContext IO))
a
-> ConduitParser
FromServerMessage
(StateT SessionState (ReaderT SessionContext IO))
a
forall (m :: * -> *) i a.
Monad m =>
Text -> ConduitParser i m a -> ConduitParser i m a
Data.Conduit.Parser.named Text
s ConduitParser
FromServerMessage
(StateT SessionState (ReaderT SessionContext IO))
a
x)
message :: forall a. (Typeable a, FromJSON a) => Session a
message :: Session a
message =
let parser :: FromServerMessage -> Maybe a
parser = ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe a)
-> (FromServerMessage -> ByteString)
-> FromServerMessage
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromServerMessage -> ByteString
encodeMsg :: FromServerMessage -> Maybe a
in Text -> Session a -> Session a
forall a. Text -> Session a -> Session a
named (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ [TypeRep] -> TypeRep
forall a. [a] -> a
head ([TypeRep] -> TypeRep) -> [TypeRep] -> TypeRep
forall a b. (a -> b) -> a -> b
$ (TyCon, [TypeRep]) -> [TypeRep]
forall a b. (a, b) -> b
snd ((TyCon, [TypeRep]) -> [TypeRep])
-> (TyCon, [TypeRep]) -> [TypeRep]
forall a b. (a -> b) -> a -> b
$ TypeRep -> (TyCon, [TypeRep])
splitTyConApp (TypeRep -> (TyCon, [TypeRep])) -> TypeRep -> (TyCon, [TypeRep])
forall a b. (a -> b) -> a -> b
$ [TypeRep] -> TypeRep
forall a. [a] -> a
last ([TypeRep] -> TypeRep) -> [TypeRep] -> TypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep -> [TypeRep]
typeRepArgs (TypeRep -> [TypeRep]) -> TypeRep -> [TypeRep]
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Maybe a) -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf FromServerMessage -> Maybe a
parser) (Session a -> Session a) -> Session a -> Session a
forall a b. (a -> b) -> a -> b
$
(FromServerMessage -> Maybe a) -> Session a
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe FromServerMessage -> Maybe a
parser
anyNotification :: Session FromServerMessage
anyNotification :: Session FromServerMessage
anyNotification = Text -> Session FromServerMessage -> Session FromServerMessage
forall a. Text -> Session a -> Session a
named Text
"Any notification" (Session FromServerMessage -> Session FromServerMessage)
-> Session FromServerMessage -> Session FromServerMessage
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy FromServerMessage -> Bool
isServerNotification
anyRequest :: Session FromServerMessage
anyRequest :: Session FromServerMessage
anyRequest = Text -> Session FromServerMessage -> Session FromServerMessage
forall a. Text -> Session a -> Session a
named Text
"Any request" (Session FromServerMessage -> Session FromServerMessage)
-> Session FromServerMessage -> Session FromServerMessage
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy FromServerMessage -> Bool
isServerRequest
anyResponse :: Session FromServerMessage
anyResponse :: Session FromServerMessage
anyResponse = Text -> Session FromServerMessage -> Session FromServerMessage
forall a. Text -> Session a -> Session a
named Text
"Any response" (Session FromServerMessage -> Session FromServerMessage)
-> Session FromServerMessage -> Session FromServerMessage
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy FromServerMessage -> Bool
isServerResponse
responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
responseForId :: LspId -> Session (ResponseMessage a)
responseForId LspId
lid = Text -> Session (ResponseMessage a) -> Session (ResponseMessage a)
forall a. Text -> Session a -> Session a
named (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Response for id: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show LspId
lid) (Session (ResponseMessage a) -> Session (ResponseMessage a))
-> Session (ResponseMessage a) -> Session (ResponseMessage a)
forall a b. (a -> b) -> a -> b
$ do
let parser :: FromServerMessage -> Maybe (ResponseMessage a)
parser = ByteString -> Maybe (ResponseMessage a)
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe (ResponseMessage a))
-> (FromServerMessage -> ByteString)
-> FromServerMessage
-> Maybe (ResponseMessage a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromServerMessage -> ByteString
encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
(FromServerMessage -> Maybe (ResponseMessage a))
-> Session (ResponseMessage a)
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe ((FromServerMessage -> Maybe (ResponseMessage a))
-> Session (ResponseMessage a))
-> (FromServerMessage -> Maybe (ResponseMessage a))
-> Session (ResponseMessage a)
forall a b. (a -> b) -> a -> b
$ \FromServerMessage
msg -> do
ResponseMessage a
z <- FromServerMessage -> Maybe (ResponseMessage a)
parser FromServerMessage
msg
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ResponseMessage a
z 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
LSP.id LspIdRsp -> LspIdRsp -> Bool
forall a. Eq a => a -> a -> Bool
== LspId -> LspIdRsp
responseId LspId
lid)
ResponseMessage a -> Maybe (ResponseMessage a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseMessage a
z
anyMessage :: Session FromServerMessage
anyMessage :: Session FromServerMessage
anyMessage = (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy (Bool -> FromServerMessage -> Bool
forall a b. a -> b -> a
const Bool
True)
encodeMsg :: FromServerMessage -> B.ByteString
encodeMsg :: FromServerMessage -> ByteString
encodeMsg = Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString)
-> (FromServerMessage -> Value) -> FromServerMessage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> FromServerMessage -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (Options
defaultOptions { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
UntaggedValue })
loggingNotification :: Session FromServerMessage
loggingNotification :: Session FromServerMessage
loggingNotification = Text -> Session FromServerMessage -> Session FromServerMessage
forall a. Text -> Session a -> Session a
named Text
"Logging notification" (Session FromServerMessage -> Session FromServerMessage)
-> Session FromServerMessage -> Session FromServerMessage
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy FromServerMessage -> Bool
shouldSkip
where
shouldSkip :: FromServerMessage -> Bool
shouldSkip (NotLogMessage LogMessageNotification
_) = Bool
True
shouldSkip (NotShowMessage ShowMessageNotification
_) = Bool
True
shouldSkip (ReqShowMessage ShowMessageRequest
_) = Bool
True
shouldSkip FromServerMessage
_ = Bool
False
publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
publishDiagnosticsNotification = Text
-> Session PublishDiagnosticsNotification
-> Session PublishDiagnosticsNotification
forall a. Text -> Session a -> Session a
named Text
"Publish diagnostics notification" (Session PublishDiagnosticsNotification
-> Session PublishDiagnosticsNotification)
-> Session PublishDiagnosticsNotification
-> Session PublishDiagnosticsNotification
forall a b. (a -> b) -> a -> b
$
(FromServerMessage -> Maybe PublishDiagnosticsNotification)
-> Session PublishDiagnosticsNotification
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe ((FromServerMessage -> Maybe PublishDiagnosticsNotification)
-> Session PublishDiagnosticsNotification)
-> (FromServerMessage -> Maybe PublishDiagnosticsNotification)
-> Session PublishDiagnosticsNotification
forall a b. (a -> b) -> a -> b
$ \FromServerMessage
msg -> case FromServerMessage
msg of
NotPublishDiagnostics PublishDiagnosticsNotification
diags -> PublishDiagnosticsNotification
-> Maybe PublishDiagnosticsNotification
forall a. a -> Maybe a
Just PublishDiagnosticsNotification
diags
FromServerMessage
_ -> Maybe PublishDiagnosticsNotification
forall a. Maybe a
Nothing