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

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

import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.Conduit.Parser hiding (named)
import Data.Conduit.Parser qualified (named)
import Data.GADT.Compare
import Data.Text qualified as T
import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal)
import Language.LSP.Protocol.Message
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 (TMessage m)
message :: forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod m -> Session (TMessage m)
message (SMethod_CustomMethod Proxy s
_) = 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 TMessage m
msg -> do
    Either (CustomEq m m) (m :~~: m)
res <- forall {t1 :: MessageKind} {t2 :: MessageKind}
       (m1 :: Method 'ServerToClient t1)
       (m2 :: Method 'ServerToClient 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 TMessage m
msg
      Left CustomEq m m
_f -> forall a. Maybe a
Nothing
  FromServerMessage
_ -> forall a. Maybe a
Nothing

customRequest :: KnownSymbol s => Proxy s -> Session (TMessage (Method_CustomMethod s :: Method ServerToClient Request))
customRequest :: forall (s :: Symbol).
KnownSymbol s =>
Proxy s -> Session (TMessage ('Method_CustomMethod s))
customRequest Proxy s
p =
  let m :: Text
m = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy s
p
   in 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 TMessage m
msg -> case forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod m -> ServerNotOrReq m
splitServerMethod SMethod m
m1 of
          ServerNotOrReq m
IsServerEither -> case TMessage m
msg of
            ReqMess TRequestMessage ('Method_CustomMethod s)
_ -> case SMethod m
m1 forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
`geq` forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod Proxy s
p of
              Just m :~: 'Method_CustomMethod s
Refl -> forall a. a -> Maybe a
Just TMessage m
msg
              Maybe (m :~: 'Method_CustomMethod s)
_ -> forall a. Maybe a
Nothing
            TMessage m
_ -> forall a. Maybe a
Nothing
          ServerNotOrReq m
_ -> forall a. Maybe a
Nothing
        FromServerMessage
_ -> forall a. Maybe a
Nothing

customNotification :: KnownSymbol s => Proxy s -> Session (TMessage (Method_CustomMethod s :: Method ServerToClient Notification))
customNotification :: forall (s :: Symbol).
KnownSymbol s =>
Proxy s -> Session (TMessage ('Method_CustomMethod s))
customNotification Proxy s
p =
  let m :: Text
m = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy s
p
   in 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 TMessage m
msg -> case forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod m -> ServerNotOrReq m
splitServerMethod SMethod m
m1 of
          ServerNotOrReq m
IsServerEither -> case TMessage m
msg of
            NotMess TNotificationMessage ('Method_CustomMethod s)
_ -> case SMethod m
m1 forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
`geq` forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod Proxy s
p of
              Just m :~: 'Method_CustomMethod s
Refl -> forall a. a -> Maybe a
Just TMessage m
msg
              Maybe (m :~: 'Method_CustomMethod s)
_ -> forall a. Maybe a
Nothing
            TMessage 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 TMessage m
msg -> case forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod m -> ServerNotOrReq m
splitServerMethod SMethod m
m of
    ServerNotOrReq m
IsServerNot -> Bool
True
    ServerNotOrReq m
IsServerEither -> case TMessage m
msg of
      NotMess TNotificationMessage ('Method_CustomMethod s)
_ -> Bool
True
      TMessage m
_ -> Bool
False
    ServerNotOrReq m
_ -> Bool
False
  FromServerRsp SMethod m
_ TResponseMessage 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 TMessage m
_ -> case forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod m -> ServerNotOrReq m
splitServerMethod SMethod m
m of
    ServerNotOrReq m
IsServerReq -> Bool
True
    ServerNotOrReq m
_ -> Bool
False
  FromServerRsp SMethod m
_ TResponseMessage 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
_ TMessage m
_ -> Bool
False
  FromServerRsp SMethod m
_ TResponseMessage m
_ -> Bool
True

-- | Matches a response coming from the server.
response :: SMethod (m :: Method ClientToServer Request) -> Session (TResponseMessage m)
response :: forall (m :: Method 'ClientToServer 'Request).
SMethod m -> Session (TResponseMessage 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 TResponseMessage m
msg -> do
    m :~~: m
HRefl <- forall (t1 :: MessageKind) (t2 :: MessageKind)
       (f :: MessageDirection) (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 :: MessageKind} {t2 :: MessageKind}
       (m1 :: Method 'ClientToServer t1)
       (m2 :: Method 'ClientToServer 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 TResponseMessage m
msg
  FromServerMessage
_ -> forall a. Maybe a
Nothing

-- | Like 'response', but matches a response for a specific id.
responseForId :: SMethod (m :: Method ClientToServer Request) -> LspId m -> Session (TResponseMessage m)
responseForId :: forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage 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
_ TMessage m
_ -> forall a. Maybe a
Nothing
      FromServerRsp SMethod m
m' rspMsg :: TResponseMessage m
rspMsg@(TResponseMessage Text
_ Maybe (LspId m)
lid' Either ResponseError (MessageResult m)
_) -> do
        m :~~: m
HRefl <- forall (t1 :: MessageKind) (t2 :: MessageKind)
       (f :: MessageDirection) (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 :: MessageKind} {t2 :: MessageKind}
       (m1 :: Method 'ClientToServer t1)
       (m2 :: Method 'ClientToServer 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 TResponseMessage 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 'ClientToServer 'Request -> *}.
FromServerMessage' a -> Bool
shouldSkip
 where
  shouldSkip :: FromServerMessage' a -> Bool
shouldSkip (FromServerMess SMethod m
SMethod_WindowLogMessage TMessage m
_) = Bool
True
  shouldSkip (FromServerMess SMethod m
SMethod_WindowShowMessage TMessage m
_) = Bool
True
  shouldSkip (FromServerMess SMethod m
SMethod_WindowShowMessageRequest TMessage m
_) = Bool
True
  shouldSkip (FromServerMess SMethod m
SMethod_WindowShowDocument TMessage m
_) = Bool
True
  shouldSkip FromServerMessage' a
_ = Bool
False

-- | Matches if the message is a configuration request from the server.
configurationRequest :: Session FromServerMessage
configurationRequest :: Session FromServerMessage
configurationRequest = forall a. Text -> Session a -> Session a
named Text
"Configuration request" forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy forall {a :: Method 'ClientToServer 'Request -> *}.
FromServerMessage' a -> Bool
shouldSkip
 where
  shouldSkip :: FromServerMessage' a -> Bool
shouldSkip (FromServerMess SMethod m
SMethod_WorkspaceConfiguration TMessage m
_) = Bool
True
  shouldSkip FromServerMessage' a
_ = Bool
False

loggingOrConfiguration :: Session FromServerMessage
loggingOrConfiguration :: Session FromServerMessage
loggingOrConfiguration = Session FromServerMessage
loggingNotification forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Session FromServerMessage
configurationRequest

{- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'
 (textDocument/publishDiagnostics) notification.
-}
publishDiagnosticsNotification :: Session (TMessage Method_TextDocumentPublishDiagnostics)
publishDiagnosticsNotification :: Session (TMessage 'Method_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
SMethod_TextDocumentPublishDiagnostics TMessage m
diags -> forall a. a -> Maybe a
Just TMessage m
diags
    FromServerMessage
_ -> forall a. Maybe a
Nothing