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