{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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
  , configurationRequest
  , loggingOrConfiguration
  , 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.Protocol.Message
import Language.LSP.Test.Session
import GHC.TypeLits (KnownSymbol, symbolVal)
import Data.GADT.Compare

-- $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