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     message
   9   , anyRequest
  10   , anyResponse
  11   , anyNotification
  12   , anyMessage
  13   , loggingNotification
  14   , publishDiagnosticsNotification
  15   , responseForId
  16   ) where
  17
  18 import Control.Applicative
  19 import Control.Concurrent
  20 import Control.Lens
  21 import Control.Monad.IO.Class
  22 import Control.Monad
  23 import Data.Aeson
  24 import qualified Data.ByteString.Lazy.Char8 as B
  25 import Data.Conduit.Parser
  26 import Data.Maybe
  27 import qualified Data.Text as T
  28 import Data.Typeable
  29 import Language.Haskell.LSP.Messages
  30 import Language.Haskell.LSP.Types as LSP hiding (error, message)
  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 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
  63 satisfy pred = do
  64
  65   skipTimeout <- overridingTimeout <$> get
  66   timeoutId <- curTimeoutId <$> get
  67   unless skipTimeout $ do
  68     chan <- asks messageChan
  69     timeout <- asks (messageTimeout . config)
  70     void $ liftIO $ forkIO $ do
  71       threadDelay (timeout * 1000000)
  72       writeChan chan (TimeoutMessage timeoutId)
  73
  74   x <- await
  75
  76   unless skipTimeout $
  77     modify $ \s -> s { curTimeoutId = timeoutId + 1 }
  78
  79   modify $ \s -> s { lastReceivedMessage = Just x }
  80
  81   if pred x
  82     then do
  83       logMsg LogServer x
  84       return x
  85     else empty
  86
  87 -- | Matches a message of type 'a'.
  88 message :: forall a. (Typeable a, FromJSON a) => Session a
  89 message =
  90   let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
  91   in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
  92     castMsg <$> satisfy (isJust . parser)
  93
  94 -- | Matches if the message is a notification.
  95 anyNotification :: Session FromServerMessage
  96 anyNotification = named "Any notification" $ satisfy isServerNotification
  97
  98 -- | Matches if the message is a request.
  99 anyRequest :: Session FromServerMessage
 100 anyRequest = named "Any request" $ satisfy isServerRequest
 101
 102 -- | Matches if the message is a response.
 103 anyResponse :: Session FromServerMessage
 104 anyResponse = named "Any response" $ satisfy isServerResponse
 105
 106 -- | Matches a response for a specific id.
 107 responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
 108 responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
 109   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
 110   x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser)
 111   return $ castMsg x
 112
 113 -- | Matches any type of message.
 114 anyMessage :: Session FromServerMessage
 115 anyMessage = satisfy (const True)
 116
 117 -- | A stupid method for getting out the inner message.
 118 castMsg :: FromJSON a => FromServerMessage -> a
 119 castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg
 120
 121 -- | A version of encode that encodes FromServerMessages as if they
 122 -- weren't wrapped.
 123 encodeMsg :: FromServerMessage -> B.ByteString
 124 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
 125
 126 -- | Matches if the message is a log message notification or a show message notification/request.
 127 loggingNotification :: Session FromServerMessage
 128 loggingNotification = named "Logging notification" $ satisfy shouldSkip
 129   where
 130     shouldSkip (NotLogMessage _) = True
 131     shouldSkip (NotShowMessage _) = True
 132     shouldSkip (ReqShowMessage _) = True
 133     shouldSkip _ = False
 134
 135 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
 136 -- (textDocument/publishDiagnostics) notification.
 137 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
 138 publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
 139   NotPublishDiagnostics diags <- satisfy test
 140   return diags
 141   where test (NotPublishDiagnostics _) = True
 142         test _ = False