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 qualified Data.Text as T
30 import Language.Haskell.LSP.Messages
31 import Language.Haskell.LSP.Types
32 import qualified Language.Haskell.LSP.Types.Lens as LSP
33 import Language.Haskell.LSP.Test.Messages
34 import Language.Haskell.LSP.Test.Session
37 -- To receive a message, just specify the type that expect:
40 -- msg1 <- message :: Session ApplyWorkspaceEditRequest
41 -- msg2 <- message :: Session HoverResponse
44 -- 'Language.Haskell.LSP.Test.Session' is actually just a parser
45 -- that operates on messages under the hood. This means that you
46 -- can create and combine parsers to match speicifc sequences of
47 -- messages that you expect.
49 -- For example, if you wanted to match either a definition or
50 -- references request:
52 -- > defOrImpl = (message :: Session DefinitionRequest)
53 -- > <|> (message :: Session ReferencesRequest)
55 -- If you wanted to match any number of telemetry
56 -- notifications immediately followed by a response:
60 -- skipManyTill (message :: Session TelemetryNotification)
64 -- | Consumes and returns the next message, if it satisfies the specified predicate.
67 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
70 skipTimeout <- overridingTimeout <$> get
71 timeoutId <- curTimeoutId <$> get
72 unless skipTimeout $ do
73 chan <- asks messageChan
74 timeout <- asks (messageTimeout . config)
75 void $ liftIO $ forkIO $ do
76 threadDelay (timeout * 1000000)
77 writeChan chan (TimeoutMessage timeoutId)
82 modify $ \s -> s { curTimeoutId = timeoutId + 1 }
84 modify $ \s -> s { lastReceivedMessage = Just x }
92 -- | Matches a message of type @a@.
93 message :: forall a. (Typeable a, FromJSON a) => Session a
95 let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
96 in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
97 castMsg <$> satisfy (isJust . parser)
99 -- | Matches if the message is a notification.
100 anyNotification :: Session FromServerMessage
101 anyNotification = named "Any notification" $ satisfy isServerNotification
103 -- | Matches if the message is a request.
104 anyRequest :: Session FromServerMessage
105 anyRequest = named "Any request" $ satisfy isServerRequest
107 -- | Matches if the message is a response.
108 anyResponse :: Session FromServerMessage
109 anyResponse = named "Any response" $ satisfy isServerResponse
111 -- | Matches a response for a specific id.
112 responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
113 responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
114 let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
115 x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser)
118 -- | Matches any type of message.
119 anyMessage :: Session FromServerMessage
120 anyMessage = satisfy (const True)
122 -- | A stupid method for getting out the inner message.
123 castMsg :: FromJSON a => FromServerMessage -> a
124 castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg
126 -- | A version of encode that encodes FromServerMessages as if they
128 encodeMsg :: FromServerMessage -> B.ByteString
129 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
131 -- | Matches if the message is a log message notification or a show message notification/request.
132 loggingNotification :: Session FromServerMessage
133 loggingNotification = named "Logging notification" $ satisfy shouldSkip
135 shouldSkip (NotLogMessage _) = True
136 shouldSkip (NotShowMessage _) = True
137 shouldSkip (ReqShowMessage _) = True
140 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
141 -- (textDocument/publishDiagnostics) notification.
142 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
143 publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
144 NotPublishDiagnostics diags <- satisfy test
146 where test (NotPublishDiagnostics _) = True