src/Language/LSP/Test/Parsing.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE EmptyCase #-}
   3 {-# LANGUAGE TypeOperators #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE TypeInType #-}
   6 {-# LANGUAGE KindSignatures #-}
   7 {-# LANGUAGE TypeInType #-}
   8 {-# LANGUAGE GADTs #-}
   9 {-# LANGUAGE LambdaCase #-}
  10 {-# LANGUAGE RankNTypes #-}
  11 {-# LANGUAGE OverloadedStrings #-}
  12
  13 module Language.LSP.Test.Parsing
  14   ( -- $receiving
  15     satisfy
  16   , satisfyMaybe
  17   , message
  18   , response
  19   , responseForId
  20   , customRequest
  21   , customNotification
  22   , anyRequest
  23   , anyResponse
  24   , anyNotification
  25   , anyMessage
  26   , loggingNotification
  27   , publishDiagnosticsNotification
  28   ) where
  29
  30 import Control.Applicative
  31 import Control.Concurrent
  32 import Control.Monad.IO.Class
  33 import Control.Monad
  34 import Data.Conduit.Parser hiding (named)
  35 import qualified Data.Conduit.Parser (named)
  36 import qualified Data.Text as T
  37 import Data.Typeable
  38 import Language.LSP.Types
  39 import Language.LSP.Test.Session
  40
  41 -- $receiving
  42 -- To receive a message, specify the method of the message to expect:
  43 --
  44 -- @
  45 -- msg1 <- message SWorkspaceApplyEdit
  46 -- msg2 <- message STextDocumentHover
  47 -- @
  48 --
  49 -- 'Language.LSP.Test.Session' is actually just a parser
  50 -- that operates on messages under the hood. This means that you
  51 -- can create and combine parsers to match speicifc sequences of
  52 -- messages that you expect.
  53 --
  54 -- For example, if you wanted to match either a definition or
  55 -- references request:
  56 --
  57 -- > defOrImpl = message STextDocumentDefinition
  58 -- >          <|> message STextDocumentReferences
  59 --
  60 -- If you wanted to match any number of telemetry
  61 -- notifications immediately followed by a response:
  62 --
  63 -- @
  64 -- logThenDiags =
  65 --  skipManyTill (message STelemetryEvent)
  66 --               anyResponse
  67 -- @
  68
  69 -- | Consumes and returns the next message, if it satisfies the specified predicate.
  70 --
  71 -- @since 0.5.2.0
  72 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
  73 satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)
  74
  75 -- | Consumes and returns the result of the specified predicate if it returns `Just`.
  76 --
  77 -- @since 0.6.1.0
  78 satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
  79 satisfyMaybe pred = satisfyMaybeM (pure . pred)
  80
  81 satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a
  82 satisfyMaybeM pred = do
  83
  84   skipTimeout <- overridingTimeout <$> get
  85   timeoutId <- getCurTimeoutId
  86   mtid <-
  87     if skipTimeout
  88     then pure Nothing
  89     else Just <$> do
  90       chan <- asks messageChan
  91       timeout <- asks (messageTimeout . config)
  92       liftIO $ forkIO $ do
  93         threadDelay (timeout * 1000000)
  94         writeChan chan (TimeoutMessage timeoutId)
  95
  96   x <- Session await
  97
  98   forM_ mtid $ \tid -> do
  99     bumpTimeoutId timeoutId
 100     liftIO $ killThread tid
 101
 102   modify $ \s -> s { lastReceivedMessage = Just x }
 103
 104   res <- pred x
 105
 106   case res of
 107     Just a -> do
 108       logMsg LogServer x
 109       return a
 110     Nothing -> empty
 111
 112 named :: T.Text -> Session a -> Session a
 113 named s (Session x) = Session (Data.Conduit.Parser.named s x)
 114
 115
 116 -- | Matches a request or a notification coming from the server.
 117 message :: SServerMethod m -> Session (ServerMessage m)
 118 message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case
 119   FromServerMess m2 msg -> do
 120     HRefl <- mEqServer m1 m2
 121     pure msg
 122   _ -> Nothing
 123
 124 customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))
 125 customRequest m = named m $ satisfyMaybe $ \case
 126   FromServerMess m1 msg -> case splitServerMethod m1 of
 127     IsServerEither -> case msg of
 128       ReqMess _ | m1 == SCustomMethod m -> Just msg
 129       _ -> Nothing
 130     _ -> Nothing
 131   _ -> Nothing
 132
 133 customNotification :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Notification))
 134 customNotification m = named m $ satisfyMaybe $ \case
 135   FromServerMess m1 msg -> case splitServerMethod m1 of
 136     IsServerEither -> case msg of
 137       NotMess _ | m1 == SCustomMethod m -> Just msg
 138       _ -> Nothing
 139     _ -> Nothing
 140   _ -> Nothing
 141
 142 -- | Matches if the message is a notification.
 143 anyNotification :: Session FromServerMessage
 144 anyNotification = named "Any notification" $ satisfy $ \case
 145   FromServerMess m msg -> case splitServerMethod m of
 146     IsServerNot -> True
 147     IsServerEither -> case msg of
 148       NotMess _ -> True
 149       _ -> False
 150     _ -> False
 151   FromServerRsp _ _ -> False
 152
 153 -- | Matches if the message is a request.
 154 anyRequest :: Session FromServerMessage
 155 anyRequest = named "Any request" $ satisfy $ \case
 156   FromServerMess m _ -> case splitServerMethod m of
 157     IsServerReq -> True
 158     _ -> False
 159   FromServerRsp _ _ -> False
 160
 161 -- | Matches if the message is a response.
 162 anyResponse :: Session FromServerMessage
 163 anyResponse = named "Any response" $ satisfy $ \case
 164   FromServerMess _ _ -> False
 165   FromServerRsp _ _ -> True
 166
 167 -- | Matches a response coming from the server.
 168 response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)
 169 response m1 = named (T.pack $ "Response for: " <> show m1) $ satisfyMaybe $ \case
 170   FromServerRsp m2 msg -> do
 171     HRefl <- mEqClient m1 m2
 172     pure msg
 173   _ -> Nothing
 174
 175 -- | Like 'response', but matches a response for a specific id.
 176 responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m)
 177 responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do
 178   satisfyMaybe $ \msg -> do
 179     case msg of
 180       FromServerMess _ _ -> Nothing
 181       FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) ->
 182         case mEqClient m m' of
 183           Just HRefl -> do
 184             guard (lid' == Just lid)
 185             pure rspMsg
 186           Nothing
 187             | SCustomMethod tm <- m
 188             , SCustomMethod tm' <- m'
 189             , tm == tm'
 190             , lid' == Just lid -> pure rspMsg
 191           _ -> empty
 192
 193 -- | Matches any type of message.
 194 anyMessage :: Session FromServerMessage
 195 anyMessage = satisfy (const True)
 196
 197 -- | Matches if the message is a log message notification or a show message notification/request.
 198 loggingNotification :: Session FromServerMessage
 199 loggingNotification = named "Logging notification" $ satisfy shouldSkip
 200   where
 201     shouldSkip (FromServerMess SWindowLogMessage _) = True
 202     shouldSkip (FromServerMess SWindowShowMessage _) = True
 203     shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
 204     shouldSkip _ = False
 205
 206 -- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'
 207 -- (textDocument/publishDiagnostics) notification.
 208 publishDiagnosticsNotification :: Session (Message TextDocumentPublishDiagnostics)
 209 publishDiagnosticsNotification = named "Publish diagnostics notification" $
 210   satisfyMaybe $ \msg -> case msg of
 211     FromServerMess STextDocumentPublishDiagnostics diags -> Just diags
 212     _ -> Nothing