1 {-# LANGUAGE MultiParamTypeClasses #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE OverloadedStrings #-}
6 module Language.Haskell.LSP.Test.Parsing
15 , publishDiagnosticsNotification
19 import Control.Applicative
20 import Control.Concurrent
22 import Control.Monad.IO.Class
25 import qualified Data.ByteString.Lazy.Char8 as B
26 import Data.Conduit.Parser
28 import Language.Haskell.LSP.Messages
29 import Language.Haskell.LSP.Types
30 import qualified Language.Haskell.LSP.Types.Lens as LSP
31 import Language.Haskell.LSP.Test.Messages
32 import Language.Haskell.LSP.Test.Session
35 -- To receive a message, just specify the type that expect:
38 -- msg1 <- message :: Session ApplyWorkspaceEditRequest
39 -- msg2 <- message :: Session HoverResponse
42 -- 'Language.Haskell.LSP.Test.Session' is actually just a parser
43 -- that operates on messages under the hood. This means that you
44 -- can create and combine parsers to match speicifc sequences of
45 -- messages that you expect.
47 -- For example, if you wanted to match either a definition or
48 -- references request:
50 -- > defOrImpl = (message :: Session DefinitionRequest)
51 -- > <|> (message :: Session ReferencesRequest)
53 -- If you wanted to match any number of telemetry
54 -- notifications immediately followed by a response:
58 -- skipManyTill (message :: Session TelemetryNotification)
62 -- | Consumes and returns the next message, if it satisfies the specified predicate.
65 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
66 satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)
68 -- | Consumes and returns the result of the specified predicate if it returns `Just`.
71 satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
72 satisfyMaybe pred = do
74 skipTimeout <- overridingTimeout <$> get
75 timeoutId <- curTimeoutId <$> get
76 unless skipTimeout $ do
77 chan <- asks messageChan
78 timeout <- asks (messageTimeout . config)
79 void $ liftIO $ forkIO $ do
80 threadDelay (timeout * 1000000)
81 writeChan chan (TimeoutMessage timeoutId)
86 modify $ \s -> s { curTimeoutId = timeoutId + 1 }
88 modify $ \s -> s { lastReceivedMessage = Just x }
96 -- | Matches a message of type @a@.
97 message :: forall a. (Typeable a, FromJSON a) => Session a
99 let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
100 in satisfyMaybe parser
102 -- | Matches if the message is a notification.
103 anyNotification :: Session FromServerMessage
104 anyNotification = satisfy isServerNotification
106 -- | Matches if the message is a request.
107 anyRequest :: Session FromServerMessage
108 anyRequest = satisfy isServerRequest
110 -- | Matches if the message is a response.
111 anyResponse :: Session FromServerMessage
112 anyResponse = satisfy isServerResponse
114 -- | Matches a response for a specific id.
115 responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
116 responseForId lid = do
117 let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
118 satisfyMaybe $ \msg -> do
120 guard (z ^. LSP.id == responseId lid)
123 -- | Matches any type of message.
124 anyMessage :: Session FromServerMessage
125 anyMessage = satisfy (const True)
127 -- | A version of encode that encodes FromServerMessages as if they
129 encodeMsg :: FromServerMessage -> B.ByteString
130 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
132 -- | Matches if the message is a log message notification or a show message notification/request.
133 loggingNotification :: Session FromServerMessage
134 loggingNotification = satisfy shouldSkip
136 shouldSkip (NotLogMessage _) = True
137 shouldSkip (NotShowMessage _) = True
138 shouldSkip (ReqShowMessage _) = True
141 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
142 -- (textDocument/publishDiagnostics) notification.
143 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
144 publishDiagnosticsNotification = satisfyMaybe $
146 NotPublishDiagnostics diags -> Just diags