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

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE RankNTypes #-}
   5 module Language.Haskell.LSP.Test.Parsing where
   6
   7 import Control.Applicative
   8 import Data.Aeson
   9 import qualified Data.ByteString.Lazy.Char8 as B
  10 import Data.Conduit.Parser
  11 import Data.Maybe
  12 import Language.Haskell.LSP.Messages
  13 import Language.Haskell.LSP.Types hiding (error)
  14 import Language.Haskell.LSP.Test.Messages
  15
  16 -- | Matches if the message is a notification.
  17 anyNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  18 anyNotification = satisfy isServerNotification
  19
  20 notification :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a)
  21 notification = do
  22   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a)
  23   x <- satisfy (isJust . parser)
  24   return $ decodeMsg $ encodeMsg x
  25
  26 -- | Matches if the message is a request.
  27 anyRequest :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  28 anyRequest = satisfy isServerRequest
  29
  30 request :: forall m a b. (Monad m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b)
  31 request = do
  32   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b)
  33   x <- satisfy (isJust . parser)
  34   return $ decodeMsg $ encodeMsg x
  35
  36 -- | Matches if the message is a response.
  37 anyResponse :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  38 anyResponse = satisfy isServerResponse
  39
  40 response :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a)
  41 response = do
  42   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
  43   x <- satisfy (isJust . parser)
  44   return $ decodeMsg $ encodeMsg x
  45
  46 -- | A version of encode that encodes FromServerMessages as if they
  47 -- weren't wrapped.
  48 encodeMsg :: FromServerMessage -> B.ByteString
  49 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
  50
  51 decodeMsg :: FromJSON a => B.ByteString -> a
  52 decodeMsg x = fromMaybe (error $ "Unexpected message type\nGot:\n " ++ show x)
  53                   (decode x)
  54
  55 -- | Matches if the message is a log message notification or a show message notification/request.
  56 loggingNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  57 loggingNotification = satisfy shouldSkip
  58   where
  59     shouldSkip (NotLogMessage _) = True
  60     shouldSkip (NotShowMessage _) = True
  61     shouldSkip (ReqShowMessage _) = True
  62     shouldSkip _ = False
  63
  64 publishDiagnosticsNotification :: Monad m => ConduitParser FromServerMessage m PublishDiagnosticsNotification
  65 publishDiagnosticsNotification = do
  66   NotPublishDiagnostics diags <- satisfy test
  67   return diags
  68   where test (NotPublishDiagnostics _) = True
  69         test _ = False
  70
  71 satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a
  72 satisfy pred = do
  73   x <- await
  74   if pred x
  75     then return x
  76     else empty
  77