1 {-# LANGUAGE MultiParamTypeClasses #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE PolyKinds #-}
4 {-# LANGUAGE KindSignatures #-}
5 {-# LANGUAGE DataKinds #-}
7 {-# LANGUAGE LambdaCase #-}
8 {-# LANGUAGE RankNTypes #-}
9 {-# LANGUAGE OverloadedStrings #-}
11 module Language.Haskell.LSP.Test.Parsing
21 , publishDiagnosticsNotification
25 import Control.Applicative
26 import Control.Concurrent
28 import Control.Monad.IO.Class
31 import qualified Data.ByteString.Lazy.Char8 as B
32 import Data.Conduit.Parser hiding (named)
33 import qualified Data.Conduit.Parser (named)
34 import qualified Data.Text as T
36 import Language.Haskell.LSP.Types
37 import qualified Language.Haskell.LSP.Types.Lens as LSP
38 import Language.Haskell.LSP.Test.Session
41 -- To receive a message, just specify the type that expect:
44 -- msg1 <- message :: Session ApplyWorkspaceEditRequest
45 -- msg2 <- message :: Session HoverResponse
48 -- 'Language.Haskell.LSP.Test.Session' is actually just a parser
49 -- that operates on messages under the hood. This means that you
50 -- can create and combine parsers to match speicifc sequences of
51 -- messages that you expect.
53 -- For example, if you wanted to match either a definition or
54 -- references request:
56 -- > defOrImpl = (message :: Session DefinitionRequest)
57 -- > <|> (message :: Session ReferencesRequest)
59 -- If you wanted to match any number of telemetry
60 -- notifications immediately followed by a response:
64 -- skipManyTill (message :: Session TelemetryNotification)
68 -- | Consumes and returns the next message, if it satisfies the specified predicate.
71 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
72 satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)
74 -- | Consumes and returns the result of the specified predicate if it returns `Just`.
77 satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
78 satisfyMaybe pred = do
80 skipTimeout <- overridingTimeout <$> get
81 timeoutId <- getCurTimeoutId
82 unless skipTimeout $ do
83 chan <- asks messageChan
84 timeout <- asks (messageTimeout . config)
85 void $ liftIO $ forkIO $ do
86 threadDelay (timeout * 1000000)
87 writeChan chan (TimeoutMessage timeoutId)
91 unless skipTimeout (bumpTimeoutId timeoutId)
93 modify $ \s -> s { lastReceivedMessage = Just x }
101 named :: T.Text -> Session a -> Session a
102 named s (Session x) = Session (Data.Conduit.Parser.named s x)
104 message :: SServerMethod m -> Session (ServerMessage m)
105 message = undefined -- TODO
107 -- | Matches if the message is a notification.
108 anyNotification :: Session FromServerMessage
109 anyNotification = named "Any notification" $ satisfy $ \case
110 FromServerMess m _ -> case splitServerMethod m of
113 FromServerRsp _ _ -> False
115 -- | Matches if the message is a request.
116 anyRequest :: Session FromServerMessage
117 anyRequest = named "Any request" $ satisfy $ \case
118 FromServerMess m _ -> case splitServerMethod m of
121 FromServerRsp _ _ -> False
123 -- | Matches if the message is a response.
124 anyResponse :: Session FromServerMessage
125 anyResponse = named "Any response" $ satisfy $ \case
126 FromServerMess _ _ -> False
127 FromServerRsp _ _ -> True
129 -- | Matches a response for a specific id.
130 responseForId :: LspId (m :: Method FromClient Request) -> Session (ResponseMessage m)
131 responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
132 satisfyMaybe $ \msg -> do
134 FromServerMess _ _ -> Nothing
135 FromServerRsp m rsp -> undefined -- TODO
137 -- | Matches any type of message.
138 anyMessage :: Session FromServerMessage
139 anyMessage = satisfy (const True)
141 -- | Matches if the message is a log message notification or a show message notification/request.
142 loggingNotification :: Session FromServerMessage
143 loggingNotification = named "Logging notification" $ satisfy shouldSkip
145 shouldSkip (FromServerMess SWindowLogMessage _) = True
146 shouldSkip (FromServerMess SWindowShowMessage _) = True
147 shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
150 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
151 -- (textDocument/publishDiagnostics) notification.
152 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
153 publishDiagnosticsNotification = named "Publish diagnostics notification" $
154 satisfyMaybe $ \msg -> case msg of
155 FromServerMess STextDocumentPublishDiagnostics diags -> Just diags