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