{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.LSP.Test.Parsing
  ( -- $receiving
    satisfy
  , satisfyMaybe
  , message
  , response
  , responseForId
  , customRequest
  , customNotification
  , anyRequest
  , anyResponse
  , anyNotification
  , anyMessage
  , loggingNotification
  , publishDiagnosticsNotification
  ) where

import Control.Applicative
import Control.Concurrent
import Control.Monad.IO.Class
import Control.Monad
import Data.Conduit.Parser hiding (named)
import qualified Data.Conduit.Parser (named)
import qualified Data.Text as T
import Data.Typeable
import Language.LSP.Types
import Language.LSP.Test.Session

-- $receiving
-- To receive a message, specify the method of the message to expect:
--
-- @
-- msg1 <- message SWorkspaceApplyEdit
-- msg2 <- message STextDocumentHover
-- @
--
-- 'Language.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 specific sequences of
-- messages that you expect.
--
-- For example, if you wanted to match either a definition or
-- references request:
--
-- > defOrImpl = message STextDocumentDefinition
-- >          <|> message STextDocumentReferences
--
-- If you wanted to match any number of telemetry
-- notifications immediately followed by a response:
--
-- @
-- logThenDiags =
--  skipManyTill (message STelemetryEvent)
--               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 = forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe (\FromServerMessage
msg -> if FromServerMessage -> Bool
pred FromServerMessage
msg then forall a. a -> Maybe a
Just FromServerMessage
msg else 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 :: forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe FromServerMessage -> Maybe a
pred = forall a. (FromServerMessage -> Session (Maybe a)) -> Session a
satisfyMaybeM (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromServerMessage -> Maybe a
pred)

satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a
satisfyMaybeM :: forall a. (FromServerMessage -> Session (Maybe a)) -> Session a
satisfyMaybeM FromServerMessage -> Session (Maybe a)
pred = do 
  
  Bool
skipTimeout <- SessionState -> Bool
overridingTimeout forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). HasState s m => m s
get
  Int
timeoutId <- forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
m Int
getCurTimeoutId
  Maybe ThreadId
mtid <-
    if Bool
skipTimeout
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      Chan SessionMessage
chan <- forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks SessionContext -> Chan SessionMessage
messageChan
      Int
timeout <- forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks (SessionConfig -> Int
messageTimeout forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionContext -> SessionConfig
config)
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
threadDelay (Int
timeout forall a. Num a => a -> a -> a
* Int
1000000)
        forall a. Chan a -> a -> IO ()
writeChan Chan SessionMessage
chan (Int -> SessionMessage
TimeoutMessage Int
timeoutId)

  FromServerMessage
x <- forall a.
ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> Session a
Session forall (m :: * -> *) i. Monad m => ConduitParser i m i
await

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ThreadId
mtid forall a b. (a -> b) -> a -> b
$ \ThreadId
tid -> do
    forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
Int -> m ()
bumpTimeoutId Int
timeoutId
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
tid

  forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \SessionState
s -> SessionState
s { lastReceivedMessage :: Maybe FromServerMessage
lastReceivedMessage = forall a. a -> Maybe a
Just FromServerMessage
x }

  Maybe a
res <- FromServerMessage -> Session (Maybe a)
pred FromServerMessage
x

  case Maybe a
res of
    Just a
a -> do
      forall a (m :: * -> *).
(ToJSON a, MonadIO m, HasReader SessionContext m) =>
LogMsgType -> a -> m ()
logMsg LogMsgType
LogServer FromServerMessage
x
      forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Maybe a
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty

named :: T.Text -> Session a -> Session a
named :: forall a. Text -> Session a -> Session a
named Text
s (Session ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
x) = forall a.
ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> Session a
Session (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 request or a notification coming from the server.
-- Doesn't match Custom Messages
message :: SServerMethod m -> Session (ServerMessage m)
message :: forall {t :: MethodType} (m :: Method 'FromServer t).
SServerMethod m -> Session (ServerMessage m)
message (SCustomMethod Text
_) = forall a. HasCallStack => String -> a
error String
"message can't be used with CustomMethod, use customRequest or customNotification instead"
message SServerMethod m
m1 = forall a. Text -> Session a -> Session a
named (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Request for: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SServerMethod m
m1) forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess SMethod m
m2 Message m
msg -> do
    Either (CustomEq m m) (m :~~: m)
res <- forall {t1 :: MethodType} {t2 :: MethodType}
       (m1 :: Method 'FromServer t1) (m2 :: Method 'FromServer t2).
SServerMethod m1
-> SServerMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2))
mEqServer SServerMethod m
m1 SMethod m
m2
    case Either (CustomEq m m) (m :~~: m)
res of
      Right m :~~: m
HRefl -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Message m
msg
      Left CustomEq m m
_f -> forall a. Maybe a
Nothing
  FromServerMessage
_ -> forall a. Maybe a
Nothing

customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))
customRequest :: Text -> Session (ServerMessage 'CustomMethod)
customRequest Text
m = forall a. Text -> Session a -> Session a
named Text
m forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess SMethod m
m1 Message m
msg -> case forall {t :: MethodType} (m :: Method 'FromServer t).
SServerMethod m -> ServerNotOrReq m
splitServerMethod SMethod m
m1 of
    ServerNotOrReq m
IsServerEither -> case Message m
msg of
      ReqMess RequestMessage 'CustomMethod
_ | SMethod m
m1 forall a. Eq a => a -> a -> Bool
== forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
m -> forall a. a -> Maybe a
Just Message m
msg
      Message m
_ -> forall a. Maybe a
Nothing
    ServerNotOrReq m
_ -> forall a. Maybe a
Nothing
  FromServerMessage
_ -> forall a. Maybe a
Nothing

customNotification :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Notification))
customNotification :: Text -> Session (ServerMessage 'CustomMethod)
customNotification Text
m = forall a. Text -> Session a -> Session a
named Text
m forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess SMethod m
m1 Message m
msg -> case forall {t :: MethodType} (m :: Method 'FromServer t).
SServerMethod m -> ServerNotOrReq m
splitServerMethod SMethod m
m1 of
    ServerNotOrReq m
IsServerEither -> case Message m
msg of
      NotMess NotificationMessage 'CustomMethod
_ | SMethod m
m1 forall a. Eq a => a -> a -> Bool
== forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
m -> forall a. a -> Maybe a
Just Message m
msg
      Message m
_ -> forall a. Maybe a
Nothing
    ServerNotOrReq m
_ -> forall a. Maybe a
Nothing
  FromServerMessage
_ -> forall a. Maybe a
Nothing

-- | Matches if the message is a notification.
anyNotification :: Session FromServerMessage
anyNotification :: Session FromServerMessage
anyNotification = forall a. Text -> Session a -> Session a
named Text
"Any notification" forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess SMethod m
m Message m
msg -> case forall {t :: MethodType} (m :: Method 'FromServer t).
SServerMethod m -> ServerNotOrReq m
splitServerMethod SMethod m
m of
    ServerNotOrReq m
IsServerNot -> Bool
True
    ServerNotOrReq m
IsServerEither -> case Message m
msg of
      NotMess NotificationMessage 'CustomMethod
_ -> Bool
True
      Message m
_ -> Bool
False
    ServerNotOrReq m
_ -> Bool
False
  FromServerRsp SMethod m
_ ResponseMessage m
_ -> Bool
False

-- | Matches if the message is a request.
anyRequest :: Session FromServerMessage
anyRequest :: Session FromServerMessage
anyRequest = forall a. Text -> Session a -> Session a
named Text
"Any request" forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess SMethod m
m Message m
_ -> case forall {t :: MethodType} (m :: Method 'FromServer t).
SServerMethod m -> ServerNotOrReq m
splitServerMethod SMethod m
m of
    ServerNotOrReq m
IsServerReq -> Bool
True
    ServerNotOrReq m
_ -> Bool
False
  FromServerRsp SMethod m
_ ResponseMessage m
_ -> Bool
False

-- | Matches if the message is a response.
anyResponse :: Session FromServerMessage
anyResponse :: Session FromServerMessage
anyResponse = forall a. Text -> Session a -> Session a
named Text
"Any response" forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess SMethod m
_ Message m
_ -> Bool
False
  FromServerRsp SMethod m
_ ResponseMessage m
_ -> Bool
True

-- | Matches a response coming from the server.
response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)
response :: forall (m :: Method 'FromClient 'Request).
SMethod m -> Session (ResponseMessage m)
response SMethod m
m1 = forall a. Text -> Session a -> Session a
named (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Response for: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SMethod m
m1) forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
  FromServerRsp SMethod m
m2 ResponseMessage m
msg -> do
    m :~~: m
HRefl <- forall (t1 :: MethodType) (t2 :: MethodType) (f :: From)
       (m1 :: Method f t1) (m2 :: Method f t2).
(t1 ~ t2) =>
(SMethod m1
 -> SMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2)))
-> SMethod m1 -> SMethod m2 -> Maybe (m1 :~~: m2)
runEq forall {t1 :: MethodType} {t2 :: MethodType}
       (m1 :: Method 'FromClient t1) (m2 :: Method 'FromClient t2).
SClientMethod m1
-> SClientMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2))
mEqClient SMethod m
m1 SMethod m
m2
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseMessage m
msg
  FromServerMessage
_ -> forall a. Maybe a
Nothing

-- | Like 'response', but matches a response for a specific id.
responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m)
responseForId :: forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId SMethod m
m LspId m
lid = forall a. Text -> Session a -> Session a
named (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Response for id: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LspId m
lid) forall a b. (a -> b) -> a -> b
$ do
  forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \FromServerMessage
msg -> do
    case FromServerMessage
msg of
      FromServerMess SMethod m
_ Message m
_ -> forall a. Maybe a
Nothing
      FromServerRsp SMethod m
m' rspMsg :: ResponseMessage m
rspMsg@(ResponseMessage Text
_ Maybe (LspId m)
lid' Either ResponseError (ResponseResult m)
_) -> do
        m :~~: m
HRefl <- forall (t1 :: MethodType) (t2 :: MethodType) (f :: From)
       (m1 :: Method f t1) (m2 :: Method f t2).
(t1 ~ t2) =>
(SMethod m1
 -> SMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2)))
-> SMethod m1 -> SMethod m2 -> Maybe (m1 :~~: m2)
runEq forall {t1 :: MethodType} {t2 :: MethodType}
       (m1 :: Method 'FromClient t1) (m2 :: Method 'FromClient t2).
SClientMethod m1
-> SClientMethod m2 -> Maybe (Either (CustomEq m1 m2) (m1 :~~: m2))
mEqClient SMethod m
m SMethod m
m'
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. a -> Maybe a
Just LspId m
lid forall a. Eq a => a -> a -> Bool
== Maybe (LspId m)
lid')
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseMessage m
rspMsg

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

-- | Matches if the message is a log message notification or a show message notification/request.
loggingNotification :: Session FromServerMessage
loggingNotification :: Session FromServerMessage
loggingNotification = forall a. Text -> Session a -> Session a
named Text
"Logging notification" forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy forall {a :: Method 'FromClient 'Request -> *}.
FromServerMessage' a -> Bool
shouldSkip
  where
    shouldSkip :: FromServerMessage' a -> Bool
shouldSkip (FromServerMess SMethod m
SWindowLogMessage Message m
_) = Bool
True
    shouldSkip (FromServerMess SMethod m
SWindowShowMessage Message m
_) = Bool
True
    shouldSkip (FromServerMess SMethod m
SWindowShowMessageRequest Message m
_) = Bool
True
    shouldSkip (FromServerMess SMethod m
SWindowShowDocument Message m
_) = Bool
True
    shouldSkip FromServerMessage' a
_ = Bool
False

-- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'
-- (textDocument/publishDiagnostics) notification.
publishDiagnosticsNotification :: Session (Message TextDocumentPublishDiagnostics)
publishDiagnosticsNotification :: Session (Message 'TextDocumentPublishDiagnostics)
publishDiagnosticsNotification = forall a. Text -> Session a -> Session a
named Text
"Publish diagnostics notification" forall a b. (a -> b) -> a -> b
$
  forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \FromServerMessage
msg -> case FromServerMessage
msg of
    FromServerMess SMethod m
STextDocumentPublishDiagnostics Message m
diags -> forall a. a -> Maybe a
Just Message m
diags
    FromServerMessage
_ -> forall a. Maybe a
Nothing