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

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5
   6 module Language.Haskell.LSP.Test.Parsing
   7   ( -- $receiving
   8     satisfy
   9   , message
  10   , anyRequest
  11   , anyResponse
  12   , anyNotification
  13   , anyMessage
  14   , loggingNotification
  15   , publishDiagnosticsNotification
  16   , responseForId
  17   ) where
  18
  19 import Control.Applicative
  20 import Control.Concurrent
  21 import Control.Lens
  22 import Control.Monad.IO.Class
  23 import Control.Monad
  24 import Data.Aeson
  25 import qualified Data.ByteString.Lazy.Char8 as B
  26 import Data.Conduit.Parser
  27 import qualified Data.Text as T
  28 import Data.Typeable
  29 import Language.Haskell.LSP.Messages
  30 import Language.Haskell.LSP.Types
  31 import qualified Language.Haskell.LSP.Types.Lens as LSP
  32 import Language.Haskell.LSP.Test.Messages
  33 import Language.Haskell.LSP.Test.Session
  34
  35 -- $receiving
  36 -- To receive a message, just specify the type that expect:
  37 --
  38 -- @
  39 -- msg1 <- message :: Session ApplyWorkspaceEditRequest
  40 -- msg2 <- message :: Session HoverResponse
  41 -- @
  42 --
  43 -- 'Language.Haskell.LSP.Test.Session' is actually just a parser
  44 -- that operates on messages under the hood. This means that you
  45 -- can create and combine parsers to match speicifc sequences of
  46 -- messages that you expect.
  47 --
  48 -- For example, if you wanted to match either a definition or
  49 -- references request:
  50 --
  51 -- > defOrImpl = (message :: Session DefinitionRequest)
  52 -- >          <|> (message :: Session ReferencesRequest)
  53 --
  54 -- If you wanted to match any number of telemetry
  55 -- notifications immediately followed by a response:
  56 --
  57 -- @
  58 -- logThenDiags =
  59 --  skipManyTill (message :: Session TelemetryNotification)
  60 --               anyResponse
  61 -- @
  62
  63 -- | Consumes and returns the next message, if it satisfies the specified predicate.
  64 --
  65 -- @since 0.5.2.0
  66 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
  67 satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)
  68
  69 -- | Consumes and returns the result of the specified predicate if it returns `Just`.
  70 --
  71 -- @since 0.6.1.0
  72 satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
  73 satisfyMaybe pred = do
  74
  75   skipTimeout <- overridingTimeout <$> get
  76   timeoutId <- curTimeoutId <$> get
  77   unless skipTimeout $ do
  78     chan <- asks messageChan
  79     timeout <- asks (messageTimeout . config)
  80     void $ liftIO $ forkIO $ do
  81       threadDelay (timeout * 1000000)
  82       writeChan chan (TimeoutMessage timeoutId)
  83
  84   x <- Session await
  85
  86   unless skipTimeout $
  87     modify $ \s -> s { curTimeoutId = timeoutId + 1 }
  88
  89   modify $ \s -> s { lastReceivedMessage = Just x }
  90
  91   case pred x of
  92     Just a -> do
  93       logMsg LogServer x
  94       return a
  95     Nothing -> empty
  96
  97 -- | Matches a message of type @a@.
  98 message :: forall a. (Typeable a, FromJSON a) => Session a
  99 message =
 100   let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
 101   in satisfyMaybe parser
 102
 103 -- | Matches if the message is a notification.
 104 anyNotification :: Session FromServerMessage
 105 anyNotification = satisfy isServerNotification
 106
 107 -- | Matches if the message is a request.
 108 anyRequest :: Session FromServerMessage
 109 anyRequest = satisfy isServerRequest
 110
 111 -- | Matches if the message is a response.
 112 anyResponse :: Session FromServerMessage
 113 anyResponse = satisfy isServerResponse
 114
 115 -- | Matches a response for a specific id.
 116 responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
 117 responseForId lid = do
 118   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
 119   satisfyMaybe $ \msg -> do
 120     z <- parser msg
 121     guard (z ^. LSP.id == responseId lid)
 122     pure z
 123
 124 -- | Matches any type of message.
 125 anyMessage :: Session FromServerMessage
 126 anyMessage = satisfy (const True)
 127
 128 -- | A version of encode that encodes FromServerMessages as if they
 129 -- weren't wrapped.
 130 encodeMsg :: FromServerMessage -> B.ByteString
 131 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
 132
 133 -- | Matches if the message is a log message notification or a show message notification/request.
 134 loggingNotification :: Session FromServerMessage
 135 loggingNotification = satisfy shouldSkip
 136   where
 137     shouldSkip (NotLogMessage _) = True
 138     shouldSkip (NotShowMessage _) = True
 139     shouldSkip (ReqShowMessage _) = True
 140     shouldSkip _ = False
 141
 142 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
 143 -- (textDocument/publishDiagnostics) notification.
 144 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
 145 publishDiagnosticsNotification = satisfyMaybe $
 146   \msg -> case msg of
 147     NotPublishDiagnostics diags -> Just diags
 148     _ -> Nothing