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.Monad.IO.Class
  10 import Control.Monad.Trans.Class
  11 import Data.Aeson
  12 import qualified Data.ByteString.Lazy.Char8 as B
  13 import Data.Conduit.Parser
  14 import Data.Maybe
  15 import Language.Haskell.LSP.Messages
  16 import Language.Haskell.LSP.Types hiding (error)
  17 import Language.Haskell.LSP.Test.Exceptions
  18 import Language.Haskell.LSP.Test.Messages
  19 import Language.Haskell.LSP.Test.Session
  20 import System.Console.ANSI
  21
  22 satisfy :: (MonadIO m, MonadSessionConfig m) => (FromServerMessage -> Bool) -> ConduitParser FromServerMessage m FromServerMessage
  23 satisfy pred = do
  24   timeout <- timeout <$> lift sessionConfig
  25   tId <- liftIO myThreadId
  26   timeoutThread <- liftIO $ forkIO $ do
  27     threadDelay (timeout * 1000000)
  28     throwTo tId TimeoutException
  29   x <- await
  30   liftIO $ killThread timeoutThread
  31
  32   if pred x
  33     then do
  34       liftIO $ do
  35         setSGR [SetColor Foreground Vivid Magenta]
  36         putStrLn $ "<-- " ++ B.unpack (encodeMsg x)
  37         setSGR [Reset]
  38       return x
  39     else empty
  40
  41 -- | Matches if the message is a notification.
  42 anyNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
  43 anyNotification = named "Any notification" $ satisfy isServerNotification
  44
  45 notification :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a)
  46 notification = named "Notification" $ do
  47   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a)
  48   x <- satisfy (isJust . parser)
  49   return $ castMsg x
  50
  51 -- | Matches if the message is a request.
  52 anyRequest :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
  53 anyRequest = named "Any request" $ satisfy isServerRequest
  54
  55 request :: forall m a b. (MonadIO m, MonadSessionConfig m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b)
  56 request = named "Request" $ do
  57   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b)
  58   x <- satisfy (isJust . parser)
  59   return $ castMsg x
  60
  61 -- | Matches if the message is a response.
  62 anyResponse :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
  63 anyResponse = named "Any response" $ satisfy isServerResponse
  64
  65 response :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a)
  66 response = named "Response" $ do
  67   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
  68   x <- satisfy (isJust . parser)
  69   return $ castMsg x
  70
  71 -- | A stupid method for getting out the inner message.
  72 castMsg :: FromJSON a => FromServerMessage -> a
  73 castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg
  74
  75 -- | A version of encode that encodes FromServerMessages as if they
  76 -- weren't wrapped.
  77 encodeMsg :: FromServerMessage -> B.ByteString
  78 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
  79
  80 -- | Matches if the message is a log message notification or a show message notification/request.
  81 loggingNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
  82 loggingNotification = named "Logging notification" $ satisfy shouldSkip
  83   where
  84     shouldSkip (NotLogMessage _) = True
  85     shouldSkip (NotShowMessage _) = True
  86     shouldSkip (ReqShowMessage _) = True
  87     shouldSkip _ = False
  88
  89 publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification
  90 publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
  91   NotPublishDiagnostics diags <- satisfy test
  92   return diags
  93   where test (NotPublishDiagnostics _) = True
  94         test _ = False