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