1 {-# LANGUAGE MultiParamTypeClasses #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE KindSignatures #-}
4 {-# LANGUAGE DataKinds #-}
6 {-# LANGUAGE LambdaCase #-}
7 {-# LANGUAGE RankNTypes #-}
8 {-# LANGUAGE OverloadedStrings #-}
10 module Language.Haskell.LSP.Test.Parsing
19 , publishDiagnosticsNotification
23 import Control.Applicative
24 import Control.Concurrent
26 import Control.Monad.IO.Class
29 import qualified Data.ByteString.Lazy.Char8 as B
30 import Data.Conduit.Parser hiding (named)
31 import qualified Data.Conduit.Parser (named)
32 import qualified Data.Text as T
34 import Language.Haskell.LSP.Types
35 import qualified Language.Haskell.LSP.Types.Lens as LSP
36 import Language.Haskell.LSP.Test.Messages
37 import Language.Haskell.LSP.Test.Session
40 -- To receive a message, just specify the type that expect:
43 -- msg1 <- message :: Session ApplyWorkspaceEditRequest
44 -- msg2 <- message :: Session HoverResponse
47 -- 'Language.Haskell.LSP.Test.Session' is actually just a parser
48 -- that operates on messages under the hood. This means that you
49 -- can create and combine parsers to match speicifc sequences of
50 -- messages that you expect.
52 -- For example, if you wanted to match either a definition or
53 -- references request:
55 -- > defOrImpl = (message :: Session DefinitionRequest)
56 -- > <|> (message :: Session ReferencesRequest)
58 -- If you wanted to match any number of telemetry
59 -- notifications immediately followed by a response:
63 -- skipManyTill (message :: Session TelemetryNotification)
67 -- | Consumes and returns the next message, if it satisfies the specified predicate.
70 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
71 satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)
73 -- | Consumes and returns the result of the specified predicate if it returns `Just`.
76 satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
77 satisfyMaybe pred = do
79 skipTimeout <- overridingTimeout <$> get
80 timeoutId <- getCurTimeoutId
81 unless skipTimeout $ do
82 chan <- asks messageChan
83 timeout <- asks (messageTimeout . config)
84 void $ liftIO $ forkIO $ do
85 threadDelay (timeout * 1000000)
86 writeChan chan (TimeoutMessage timeoutId)
90 unless skipTimeout (bumpTimeoutId timeoutId)
92 modify $ \s -> s { lastReceivedMessage = Just x }
100 named :: T.Text -> Session a -> Session a
101 named s (Session x) = Session (Data.Conduit.Parser.named s x)
104 -- | Matches a message of type @a@.
105 message :: forall a. (Typeable a, FromJSON a) => Session a
107 let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
108 in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
112 -- | Matches if the message is a notification.
113 anyNotification :: Session FromServerMessage
114 anyNotification = named "Any notification" $ satisfy $ \case
115 FromServerMess m _ -> case splitServerMethod m of
118 FromServerRsp _ _ -> False
120 -- | Matches if the message is a request.
121 anyRequest :: Session FromServerMessage
122 anyRequest = named "Any request" $ satisfy $ \case
123 FromServerMess m _ -> case splitServerMethod m of
126 FromServerRsp _ _ -> False
128 -- | Matches if the message is a response.
129 anyResponse :: Session FromServerMessage
130 anyResponse = named "Any response" $ satisfy $ \case
131 FromServerMess _ _ -> False
132 FromServerRsp _ _ -> True
134 -- | Matches a response for a specific id.
135 responseForId :: LspId (m :: Method FromClient Request) -> Session (ResponseMessage m)
136 responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
137 satisfyMaybe $ \msg -> do
139 FromServerMess _ _ -> Nothing
140 FromServerRsp m rsp -> undefined -- TODO
142 -- | Matches any type of message.
143 anyMessage :: Session FromServerMessage
144 anyMessage = satisfy (const True)
146 -- | Matches if the message is a log message notification or a show message notification/request.
147 loggingNotification :: Session FromServerMessage
148 loggingNotification = named "Logging notification" $ satisfy shouldSkip
150 shouldSkip (FromServerMess SWindowLogMessage _) = True
151 shouldSkip (FromServerMess SWindowShowMessage _) = True
152 shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
155 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
156 -- (textDocument/publishDiagnostics) notification.
157 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
158 publishDiagnosticsNotification = named "Publish diagnostics notification" $
159 satisfyMaybe $ \msg -> case msg of
160 FromServerMess STextDocumentPublishDiagnostics diags -> Just diags