{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
satisfy
, satisfyMaybe
, message
+ , response
+ , responseForId
+ , customRequest
+ , customNotification
, 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.Conduit.Parser hiding (named)
import qualified Data.Conduit.Parser (named)
-import Data.GADT.Compare
import qualified Data.Text as T
import Data.Typeable
import Language.Haskell.LSP.Types
named :: T.Text -> Session a -> Session a
named s (Session x) = Session (Data.Conduit.Parser.named s x)
-mEq :: SServerMethod m1 -> SServerMethod m2 -> Maybe (m1 :~~: m2)
-mEq m1 m2 = case (splitServerMethod m1, splitServerMethod m2) of
- (IsServerNot, IsServerNot) -> do
- Refl <- geq m1 m2
- pure HRefl
- (IsServerReq, IsServerReq) -> do
- Refl <- geq m1 m2
- pure HRefl
- _ -> Nothing
-
-mEqClient :: SClientMethod m1 -> SClientMethod m2 -> Maybe (m1 :~~: m2)
-mEqClient m1 m2 = case (splitClientMethod m1, splitClientMethod m2) of
- (IsClientNot, IsClientNot) -> do
- Refl <- geq m1 m2
- pure HRefl
- (IsClientReq, IsClientReq) -> do
- Refl <- geq m1 m2
- pure HRefl
- _ -> Nothing
+-- | Matches a request or a notification coming from the server.
message :: SServerMethod m -> Session (ServerMessage m)
message m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
FromServerMess m2 msg -> do
- HRefl <- mEq m1 m2
+ HRefl <- mEqServer m1 m2
pure msg
_ -> Nothing
+customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))
+customRequest m = named m $ satisfyMaybe $ \case
+ FromServerMess m1 msg -> case splitServerMethod m1 of
+ IsServerEither -> case msg of
+ ReqMess _ | m1 == SCustomMethod m -> Just msg
+ _ -> Nothing
+ _ -> Nothing
+ _ -> Nothing
+
+customNotification :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Notification))
+customNotification m = named m $ satisfyMaybe $ \case
+ FromServerMess m1 msg -> case splitServerMethod m1 of
+ IsServerEither -> case msg of
+ NotMess _ | m1 == SCustomMethod m -> Just msg
+ _ -> Nothing
+ _ -> Nothing
+ _ -> Nothing
+
-- | Matches if the message is a notification.
anyNotification :: Session FromServerMessage
anyNotification = named "Any notification" $ satisfy $ \case
- FromServerMess m _ -> case splitServerMethod m of
+ FromServerMess m msg -> case splitServerMethod m of
IsServerNot -> True
+ IsServerEither -> case msg of
+ NotMess _ -> True
+ _ -> False
_ -> False
FromServerRsp _ _ -> False
FromServerMess _ _ -> False
FromServerRsp _ _ -> True
--- | Matches a response for a specific id.
+-- | Matches a response coming from the server.
+response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)
+response m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+ FromServerRsp m2 msg -> do
+ HRefl <- mEqClient m1 m2
+ pure msg
+ _ -> Nothing
+
+-- | Like 'response', but matches a response for a specific id.
responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m)
responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do
satisfyMaybe $ \msg -> do
Just HRefl -> do
guard (lid' == Just lid)
pure rspMsg
- Nothing -> empty
+ Nothing
+ | SCustomMethod tm <- m
+ , SCustomMethod tm' <- m'
+ , tm == tm'
+ , lid' == Just lid -> pure rspMsg
+ _ -> empty
-- | Matches any type of message.
anyMessage :: Session FromServerMessage