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.Trans.Class
  12 import Data.Aeson
  13 import qualified Data.ByteString.Lazy.Char8 as B
  14 import Data.Conduit.Parser
  15 import Data.Maybe
  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
  22
  23 satisfy :: (MonadIO m, MonadSessionConfig m) => (FromServerMessage -> Bool) -> ConduitParser FromServerMessage m FromServerMessage
  24 satisfy pred = do
  25   timeout <- timeout <$> lift sessionConfig
  26   tId <- liftIO myThreadId
  27   timeoutThread <- liftIO $ forkIO $ do
  28     threadDelay (timeout * 1000000)
  29     throwTo tId TimeoutException
  30   x <- await
  31   liftIO $ killThread timeoutThread
  32
  33   if pred x
  34     then do
  35       liftIO $ do
  36         setSGR [SetColor Foreground Vivid Magenta]
  37         putStrLn $ "<-- " ++ B.unpack (encodeMsg x)
  38         setSGR [Reset]
  39       return x
  40     else empty
  41
  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
  45
  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)
  50   return $ castMsg x
  51
  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
  55
  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)
  60   return $ castMsg x
  61
  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
  65
  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)
  70   return $ castMsg x
  71
  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)
  76   return $ castMsg x
  77
  78 anyMessage :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
  79 anyMessage = satisfy (const True)
  80
  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
  84
  85 -- | A version of encode that encodes FromServerMessages as if they
  86 -- weren't wrapped.
  87 encodeMsg :: FromServerMessage -> B.ByteString
  88 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
  89
  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
  93   where
  94     shouldSkip (NotLogMessage _) = True
  95     shouldSkip (NotShowMessage _) = True
  96     shouldSkip (ReqShowMessage _) = True
  97     shouldSkip _ = False
  98
  99 publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification
 100 publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
 101   NotPublishDiagnostics diags <- satisfy test
 102   return diags
 103   where test (NotPublishDiagnostics _) = True
 104         test _ = False