1 {-# LANGUAGE MultiParamTypeClasses #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 module Language.Haskell.LSP.Test.Parsing where
7 import Control.Applicative
8 import Control.Concurrent
10 import Control.Monad.IO.Class
11 import Control.Monad.Trans.Class
13 import qualified Data.ByteString.Lazy.Char8 as B
14 import Data.Conduit.Parser
16 import Language.Haskell.LSP.Messages
17 import Language.Haskell.LSP.Types as LSP hiding (error)
18 import Language.Haskell.LSP.Test.Exceptions
19 import Language.Haskell.LSP.Test.Messages
20 import Language.Haskell.LSP.Test.Session
21 import System.Console.ANSI
23 satisfy :: (MonadIO m, MonadSessionConfig m) => (FromServerMessage -> Bool) -> ConduitParser FromServerMessage m FromServerMessage
25 timeout <- timeout <$> lift sessionConfig
26 tId <- liftIO myThreadId
27 timeoutThread <- liftIO $ forkIO $ do
28 threadDelay (timeout * 1000000)
29 throwTo tId TimeoutException
31 liftIO $ killThread timeoutThread
36 setSGR [SetColor Foreground Vivid Magenta]
37 putStrLn $ "<-- " ++ B.unpack (encodeMsg x)
42 -- | Matches if the message is a notification.
43 anyNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
44 anyNotification = named "Any notification" $ satisfy isServerNotification
46 notification :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a)
47 notification = named "Notification" $ do
48 let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a)
49 x <- satisfy (isJust . parser)
52 -- | Matches if the message is a request.
53 anyRequest :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
54 anyRequest = named "Any request" $ satisfy isServerRequest
56 request :: forall m a b. (MonadIO m, MonadSessionConfig m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b)
57 request = named "Request" $ do
58 let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b)
59 x <- satisfy (isJust . parser)
62 -- | Matches if the message is a response.
63 anyResponse :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
64 anyResponse = named "Any response" $ satisfy isServerResponse
66 response :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a)
67 response = named "Response" $ do
68 let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
69 x <- satisfy (isJust . parser)
72 responseForId :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => LspId -> ConduitParser FromServerMessage m (ResponseMessage a)
73 responseForId lid = named "Response for id" $ do
74 let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
75 x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser)
78 anyMessage :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
79 anyMessage = satisfy (const True)
81 -- | A stupid method for getting out the inner message.
82 castMsg :: FromJSON a => FromServerMessage -> a
83 castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg
85 -- | A version of encode that encodes FromServerMessages as if they
87 encodeMsg :: FromServerMessage -> B.ByteString
88 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
90 -- | Matches if the message is a log message notification or a show message notification/request.
91 loggingNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
92 loggingNotification = named "Logging notification" $ satisfy shouldSkip
94 shouldSkip (NotLogMessage _) = True
95 shouldSkip (NotShowMessage _) = True
96 shouldSkip (ReqShowMessage _) = True
99 publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification
100 publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
101 NotPublishDiagnostics diags <- satisfy test
103 where test (NotPublishDiagnostics _) = True