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
13 import Data.Aeson.Encode.Pretty
14 import qualified Data.ByteString.Lazy.Char8 as B
15 import Data.Conduit.Parser
17 import qualified Data.Text as T
19 import Language.Haskell.LSP.Messages
20 import Language.Haskell.LSP.Types as LSP hiding (error)
21 import Language.Haskell.LSP.Test.Messages
22 import Language.Haskell.LSP.Test.Session
23 import System.Console.ANSI
25 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
28 skipTimeout <- overridingTimeout <$> get
29 timeoutId <- curTimeoutId <$> get
30 unless skipTimeout $ do
31 chan <- asks messageChan
32 timeout <- asks (messageTimeout . config)
33 void $ liftIO $ forkIO $ do
34 threadDelay (timeout * 1000000)
35 writeChan chan (TimeoutMessage timeoutId)
40 modify $ \s -> s { curTimeoutId = timeoutId + 1 }
42 modify $ \s -> s { lastReceivedMessage = Just x }
46 shouldLog <- asks $ logMessages . config
47 liftIO $ when shouldLog $ do
48 setSGR [SetColor Foreground Dull Magenta]
49 putStrLn $ "<-- " ++ B.unpack (encodeMsgPretty x)
54 -- | Matches a message of type 'a'.
55 message :: forall a. (Typeable a, FromJSON a) => Session a
57 let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
58 in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
59 castMsg <$> satisfy (isJust . parser)
61 -- | Matches if the message is a notification.
62 anyNotification :: Session FromServerMessage
63 anyNotification = named "Any notification" $ satisfy isServerNotification
65 -- | Matches if the message is a request.
66 anyRequest :: Session FromServerMessage
67 anyRequest = named "Any request" $ satisfy isServerRequest
69 -- | Matches if the message is a response.
70 anyResponse :: Session FromServerMessage
71 anyResponse = named "Any response" $ satisfy isServerResponse
73 responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
74 responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
75 let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
76 x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser)
79 anyMessage :: Session FromServerMessage
80 anyMessage = satisfy (const True)
82 -- | A stupid method for getting out the inner message.
83 castMsg :: FromJSON a => FromServerMessage -> a
84 castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg
86 -- | A version of encode that encodes FromServerMessages as if they
88 encodeMsg :: FromServerMessage -> B.ByteString
89 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
91 encodeMsgPretty :: FromServerMessage -> B.ByteString
92 encodeMsgPretty = encodePretty . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
94 -- | Matches if the message is a log message notification or a show message notification/request.
95 loggingNotification :: Session FromServerMessage
96 loggingNotification = named "Logging notification" $ satisfy shouldSkip
98 shouldSkip (NotLogMessage _) = True
99 shouldSkip (NotShowMessage _) = True
100 shouldSkip (ReqShowMessage _) = True
103 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
104 publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
105 NotPublishDiagnostics diags <- satisfy test
107 where test (NotPublishDiagnostics _) = True