src/Language/Haskell/LSP/Test/Parsing.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 module Language.Haskell.LSP.Test.Parsing where
   6
   7 import Control.Applicative
   8 import Control.Concurrent
   9 import Control.Lens
  10 import Control.Monad.IO.Class
  11 import Control.Monad
  12 import Data.Aeson
  13 import Data.Aeson.Encode.Pretty
  14 import qualified Data.ByteString.Lazy.Char8 as B
  15 import Data.Conduit.Parser
  16 import Data.Maybe
  17 import qualified Data.Text as T
  18 import Data.Typeable
  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
  24
  25 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
  26 satisfy pred = do
  27
  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)
  36
  37   x <- await
  38
  39   unless skipTimeout $
  40     modify $ \s -> s { curTimeoutId = timeoutId + 1 }
  41
  42   modify $ \s -> s { lastReceivedMessage = Just x }
  43
  44   if pred x
  45     then do
  46       shouldLog <- asks $ logMessages . config
  47       liftIO $ when shouldLog $ do
  48         setSGR [SetColor Foreground Dull Magenta]
  49         putStrLn $ "<-- " ++ B.unpack (encodeMsgPretty x)
  50         setSGR [Reset]
  51       return x
  52     else empty
  53
  54 -- | Matches a message of type 'a'.
  55 message :: forall a. (Typeable a, FromJSON a) => Session a
  56 message =
  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)
  60
  61 -- | Matches if the message is a notification.
  62 anyNotification :: Session FromServerMessage
  63 anyNotification = named "Any notification" $ satisfy isServerNotification
  64
  65 -- | Matches if the message is a request.
  66 anyRequest :: Session FromServerMessage
  67 anyRequest = named "Any request" $ satisfy isServerRequest
  68
  69 -- | Matches if the message is a response.
  70 anyResponse :: Session FromServerMessage
  71 anyResponse = named "Any response" $ satisfy isServerResponse
  72
  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)
  77   return $ castMsg x
  78
  79 anyMessage :: Session FromServerMessage
  80 anyMessage = satisfy (const True)
  81
  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
  85
  86 -- | A version of encode that encodes FromServerMessages as if they
  87 -- weren't wrapped.
  88 encodeMsg :: FromServerMessage -> B.ByteString
  89 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
  90
  91 encodeMsgPretty :: FromServerMessage -> B.ByteString
  92 encodeMsgPretty = encodePretty . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
  93
  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
  97   where
  98     shouldSkip (NotLogMessage _) = True
  99     shouldSkip (NotShowMessage _) = True
 100     shouldSkip (ReqShowMessage _) = True
 101     shouldSkip _ = False
 102
 103 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
 104 publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
 105   NotPublishDiagnostics diags <- satisfy test
 106   return diags
 107   where test (NotPublishDiagnostics _) = True
 108         test _ = False