1 {-# LANGUAGE MultiParamTypeClasses #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE OverloadedStrings #-}
6 module Language.Haskell.LSP.Test.Parsing
16 , publishDiagnosticsNotification
20 import Control.Applicative
21 import Control.Concurrent
23 import Control.Monad.IO.Class
26 import qualified Data.ByteString.Lazy.Char8 as B
27 import Data.Conduit.Parser hiding (named)
28 import qualified Data.Conduit.Parser (named)
29 import qualified Data.Text as T
31 import Language.Haskell.LSP.Messages
32 import Language.Haskell.LSP.Types
33 import qualified Language.Haskell.LSP.Types.Lens as LSP
34 import Language.Haskell.LSP.Test.Messages
35 import Language.Haskell.LSP.Test.Session
38 -- To receive a message, just specify the type that expect:
41 -- msg1 <- message :: Session ApplyWorkspaceEditRequest
42 -- msg2 <- message :: Session HoverResponse
45 -- 'Language.Haskell.LSP.Test.Session' is actually just a parser
46 -- that operates on messages under the hood. This means that you
47 -- can create and combine parsers to match speicifc sequences of
48 -- messages that you expect.
50 -- For example, if you wanted to match either a definition or
51 -- references request:
53 -- > defOrImpl = (message :: Session DefinitionRequest)
54 -- > <|> (message :: Session ReferencesRequest)
56 -- If you wanted to match any number of telemetry
57 -- notifications immediately followed by a response:
61 -- skipManyTill (message :: Session TelemetryNotification)
65 -- | Consumes and returns the next message, if it satisfies the specified predicate.
68 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
69 satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)
71 -- | Consumes and returns the result of the specified predicate if it returns `Just`.
74 satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
75 satisfyMaybe pred = do
77 skipTimeout <- overridingTimeout <$> get
78 timeoutId <- getCurTimeoutId
79 unless skipTimeout $ do
80 chan <- asks messageChan
81 timeout <- asks (messageTimeout . config)
82 void $ liftIO $ forkIO $ do
83 threadDelay (timeout * 1000000)
84 writeChan chan (TimeoutMessage timeoutId)
88 unless skipTimeout (bumpTimeoutId timeoutId)
90 modify $ \s -> s { lastReceivedMessage = Just x }
98 named :: T.Text -> Session a -> Session a
99 named s (Session x) = Session (Data.Conduit.Parser.named s x)
101 -- | Matches a message of type @a@.
102 message :: forall a. (Typeable a, FromJSON a) => Session a
104 let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
105 in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
108 -- | Matches if the message is a notification.
109 anyNotification :: Session FromServerMessage
110 anyNotification = named "Any notification" $ satisfy isServerNotification
112 -- | Matches if the message is a request.
113 anyRequest :: Session FromServerMessage
114 anyRequest = named "Any request" $ satisfy isServerRequest
116 -- | Matches if the message is a response.
117 anyResponse :: Session FromServerMessage
118 anyResponse = named "Any response" $ satisfy isServerResponse
120 -- | Matches a response for a specific id.
121 responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
122 responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
123 let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
124 satisfyMaybe $ \msg -> do
126 guard (z ^. LSP.id == responseId lid)
129 -- | Matches any type of message.
130 anyMessage :: Session FromServerMessage
131 anyMessage = satisfy (const True)
133 -- | A version of encode that encodes FromServerMessages as if they
135 encodeMsg :: FromServerMessage -> B.ByteString
136 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
138 -- | Matches if the message is a log message notification or a show message notification/request.
139 loggingNotification :: Session FromServerMessage
140 loggingNotification = named "Logging notification" $ satisfy shouldSkip
142 shouldSkip (NotLogMessage _) = True
143 shouldSkip (NotShowMessage _) = True
144 shouldSkip (ReqShowMessage _) = True
147 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
148 -- (textDocument/publishDiagnostics) notification.
149 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
150 publishDiagnosticsNotification = named "Publish diagnostics notification" $
151 satisfyMaybe $ \msg -> case msg of
152 NotPublishDiagnostics diags -> Just diags