1 {-# LANGUAGE MultiParamTypeClasses #-}
2 {-# LANGUAGE EmptyCase #-}
3 {-# LANGUAGE TypeOperators #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TypeInType #-}
6 {-# LANGUAGE KindSignatures #-}
7 {-# LANGUAGE TypeInType #-}
9 {-# LANGUAGE LambdaCase #-}
10 {-# LANGUAGE RankNTypes #-}
11 {-# LANGUAGE OverloadedStrings #-}
13 module Language.LSP.Test.Parsing
27 , publishDiagnosticsNotification
30 import Control.Applicative
31 import Control.Concurrent
32 import Control.Monad.IO.Class
34 import Data.Conduit.Parser hiding (named)
35 import qualified Data.Conduit.Parser (named)
36 import qualified Data.Text as T
38 import Language.LSP.Types
39 import Language.LSP.Test.Session
42 -- To receive a message, specify the method of the message to expect:
45 -- msg1 <- message SWorkspaceApplyEdit
46 -- msg2 <- message STextDocumentHover
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.
54 -- For example, if you wanted to match either a definition or
55 -- references request:
57 -- > defOrImpl = message STextDocumentDefinition
58 -- > <|> message STextDocumentReferences
60 -- If you wanted to match any number of telemetry
61 -- notifications immediately followed by a response:
65 -- skipManyTill (message STelemetryEvent)
69 -- | Consumes and returns the next message, if it satisfies the specified predicate.
72 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
73 satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)
75 -- | Consumes and returns the result of the specified predicate if it returns `Just`.
78 satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
79 satisfyMaybe pred = satisfyMaybeM (pure . pred)
81 satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a
82 satisfyMaybeM pred = do
84 skipTimeout <- overridingTimeout <$> get
85 timeoutId <- getCurTimeoutId
90 chan <- asks messageChan
91 timeout <- asks (messageTimeout . config)
93 threadDelay (timeout * 1000000)
94 writeChan chan (TimeoutMessage timeoutId)
98 forM_ mtid $ \tid -> do
99 bumpTimeoutId timeoutId
100 liftIO $ killThread tid
102 modify $ \s -> s { lastReceivedMessage = Just x }
112 named :: T.Text -> Session a -> Session a
113 named s (Session x) = Session (Data.Conduit.Parser.named s x)
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
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
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
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
147 IsServerEither -> case msg of
151 FromServerRsp _ _ -> False
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
159 FromServerRsp _ _ -> False
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
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
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
180 FromServerMess _ _ -> Nothing
181 FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) ->
182 case mEqClient m m' of
184 guard (lid' == Just lid)
187 | SCustomMethod tm <- m
188 , SCustomMethod tm' <- m'
190 , lid' == Just lid -> pure rspMsg
193 -- | Matches any type of message.
194 anyMessage :: Session FromServerMessage
195 anyMessage = satisfy (const True)
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
201 shouldSkip (FromServerMess SWindowLogMessage _) = True
202 shouldSkip (FromServerMess SWindowShowMessage _) = True
203 shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
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