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