{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Haskell.LSP.Test.Parsing
  ( -- $receiving
    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

-- $receiving
-- To receive a message, just specify the type that expect:
--
-- @
-- msg1 <- message :: Session ApplyWorkspaceEditRequest
-- msg2 <- message :: Session HoverResponse
-- @
--
-- 'Language.Haskell.LSP.Test.Session' is actually just a parser
-- that operates on messages under the hood. This means that you
-- can create and combine parsers to match speicifc sequences of
-- messages that you expect.
--
-- For example, if you wanted to match either a definition or
-- references request:
--
-- > defOrImpl = (message :: Session DefinitionRequest)
-- >          <|> (message :: Session ReferencesRequest)
--
-- If you wanted to match any number of telemetry
-- notifications immediately followed by a response:
--
-- @
-- logThenDiags =
--  skipManyTill (message :: Session TelemetryNotification)
--               anyResponse
-- @

-- | Consumes and returns the next message, if it satisfies the specified predicate.
--
-- @since 0.5.2.0
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)

-- | Consumes and returns the result of the specified predicate if it returns `Just`.
--
-- @since 0.6.1.0
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)

-- | Matches a message of type @a@.
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

-- | Matches if the message is a notification.
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

-- | Matches if the message is a request.
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

-- | Matches if the message is a response.
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

-- | Matches a response for a specific id.
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

-- | Matches any type of message.
anyMessage :: Session FromServerMessage
anyMessage :: Session FromServerMessage
anyMessage = (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy (Bool -> FromServerMessage -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | A version of encode that encodes FromServerMessages as if they
-- weren't wrapped.
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 })

-- | Matches if the message is a log message notification or a show message notification/request.
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

-- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
-- (textDocument/publishDiagnostics) notification.
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