1 {-# LANGUAGE MultiParamTypeClasses #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE OverloadedStrings #-}
6 module Language.Haskell.LSP.Test.Parsing
14 , publishDiagnosticsNotification
18 import Control.Applicative
19 import Control.Concurrent
21 import Control.Monad.IO.Class
24 import qualified Data.ByteString.Lazy.Char8 as B
25 import Data.Conduit.Parser
27 import qualified Data.Text as T
29 import Language.Haskell.LSP.Messages
30 import Language.Haskell.LSP.Types as LSP hiding (error, message)
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 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
65 skipTimeout <- overridingTimeout <$> get
66 timeoutId <- curTimeoutId <$> get
67 unless skipTimeout $ do
68 chan <- asks messageChan
69 timeout <- asks (messageTimeout . config)
70 void $ liftIO $ forkIO $ do
71 threadDelay (timeout * 1000000)
72 writeChan chan (TimeoutMessage timeoutId)
77 modify $ \s -> s { curTimeoutId = timeoutId + 1 }
79 modify $ \s -> s { lastReceivedMessage = Just x }
87 -- | Matches a message of type 'a'.
88 message :: forall a. (Typeable a, FromJSON a) => Session a
90 let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
91 in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
92 castMsg <$> satisfy (isJust . parser)
94 -- | Matches if the message is a notification.
95 anyNotification :: Session FromServerMessage
96 anyNotification = named "Any notification" $ satisfy isServerNotification
98 -- | Matches if the message is a request.
99 anyRequest :: Session FromServerMessage
100 anyRequest = named "Any request" $ satisfy isServerRequest
102 -- | Matches if the message is a response.
103 anyResponse :: Session FromServerMessage
104 anyResponse = named "Any response" $ satisfy isServerResponse
106 -- | Matches a response for a specific id.
107 responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
108 responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
109 let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
110 x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser)
113 -- | Matches any type of message.
114 anyMessage :: Session FromServerMessage
115 anyMessage = satisfy (const True)
117 -- | A stupid method for getting out the inner message.
118 castMsg :: FromJSON a => FromServerMessage -> a
119 castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg
121 -- | A version of encode that encodes FromServerMessages as if they
123 encodeMsg :: FromServerMessage -> B.ByteString
124 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
126 -- | Matches if the message is a log message notification or a show message notification/request.
127 loggingNotification :: Session FromServerMessage
128 loggingNotification = named "Logging notification" $ satisfy shouldSkip
130 shouldSkip (NotLogMessage _) = True
131 shouldSkip (NotShowMessage _) = True
132 shouldSkip (ReqShowMessage _) = True
135 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
136 -- (textDocument/publishDiagnostics) notification.
137 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
138 publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
139 NotPublishDiagnostics diags <- satisfy test
141 where test (NotPublishDiagnostics _) = True