src/Language/Haskell/LSP/Test/Parsing.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE EmptyCase #-}
   3 {-# LANGUAGE TypeOperators #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE PolyKinds #-}
   6 {-# LANGUAGE KindSignatures #-}
   7 {-# LANGUAGE DataKinds #-}
   8 {-# LANGUAGE GADTs #-}
   9 {-# LANGUAGE LambdaCase #-}
  10 {-# LANGUAGE RankNTypes #-}
  11 {-# LANGUAGE OverloadedStrings #-}
  12
  13 module Language.Haskell.LSP.Test.Parsing
  14   ( -- $receiving
  15     satisfy
  16   , satisfyMaybe
  17   , message
  18   , responseForId
  19   , customRequest
  20   , customNotification
  21   , anyRequest
  22   , anyResponse
  23   , anyNotification
  24   , anyMessage
  25   , loggingNotification
  26   , publishDiagnosticsNotification
  27   ) where
  28
  29 import Control.Applicative
  30 import Control.Concurrent
  31 import Control.Lens
  32 import Control.Monad.IO.Class
  33 import Control.Monad
  34 import Data.Conduit.Parser hiding (named)
  35 import qualified Data.Conduit.Parser (named)
  36 import Data.GADT.Compare
  37 import qualified Data.Text as T
  38 import Data.Typeable
  39 import Language.Haskell.LSP.Types
  40 import Language.Haskell.LSP.Test.Session
  41
  42 -- $receiving
  43 -- To receive a message, specify the method of the message to expect:
  44 --
  45 -- @
  46 -- msg1 <- message SWorkspaceApplyEdit
  47 -- msg2 <- message STextDocumentHover
  48 -- @
  49 --
  50 -- 'Language.Haskell.LSP.Test.Session' is actually just a parser
  51 -- that operates on messages under the hood. This means that you
  52 -- can create and combine parsers to match speicifc sequences of
  53 -- messages that you expect.
  54 --
  55 -- For example, if you wanted to match either a definition or
  56 -- references request:
  57 --
  58 -- > defOrImpl = message STextDocumentDefinition
  59 -- >          <|> message STextDocumentReferences
  60 --
  61 -- If you wanted to match any number of telemetry
  62 -- notifications immediately followed by a response:
  63 --
  64 -- @
  65 -- logThenDiags =
  66 --  skipManyTill (message STelemetryEvent)
  67 --               anyResponse
  68 -- @
  69
  70 -- | Consumes and returns the next message, if it satisfies the specified predicate.
  71 --
  72 -- @since 0.5.2.0
  73 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
  74 satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)
  75
  76 -- | Consumes and returns the result of the specified predicate if it returns `Just`.
  77 --
  78 -- @since 0.6.1.0
  79 satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
  80 satisfyMaybe pred = satisfyMaybeM (pure . pred)
  81
  82 satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a
  83 satisfyMaybeM pred = do
  84
  85   skipTimeout <- overridingTimeout <$> get
  86   timeoutId <- getCurTimeoutId
  87   unless skipTimeout $ do
  88     chan <- asks messageChan
  89     timeout <- asks (messageTimeout . config)
  90     void $ liftIO $ forkIO $ do
  91       threadDelay (timeout * 1000000)
  92       writeChan chan (TimeoutMessage timeoutId)
  93
  94   x <- Session await
  95
  96   unless skipTimeout (bumpTimeoutId timeoutId)
  97
  98   modify $ \s -> s { lastReceivedMessage = Just x }
  99
 100   res <- pred x
 101
 102   case res of
 103     Just a -> do
 104       logMsg LogServer x
 105       return a
 106     Nothing -> empty
 107
 108 named :: T.Text -> Session a -> Session a
 109 named s (Session x) = Session (Data.Conduit.Parser.named s x)
 110
 111 mEq :: SServerMethod m1 -> SServerMethod m2 -> Maybe (m1 :~~: m2)
 112 mEq m1 m2 = case (splitServerMethod m1, splitServerMethod m2) of
 113   (IsServerNot, IsServerNot) -> do
 114     Refl <- geq m1 m2
 115     pure HRefl
 116   (IsServerReq, IsServerReq) -> do
 117     Refl <- geq m1 m2
 118     pure HRefl
 119   _ -> Nothing
 120
 121 mEqClient :: SClientMethod m1 -> SClientMethod m2 -> Maybe (m1 :~~: m2)
 122 mEqClient m1 m2 = case (splitClientMethod m1, splitClientMethod m2) of
 123   (IsClientNot, IsClientNot) -> do
 124     Refl <- geq m1 m2
 125     pure HRefl
 126   (IsClientReq, IsClientReq) -> do
 127     Refl <- geq m1 m2
 128     pure HRefl
 129   _ -> Nothing
 130
 131 -- | Matches non-custom messages
 132 message :: SServerMethod m -> Session (ServerMessage m)
 133 message m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
 134   FromServerMess m2 msg -> do
 135     HRefl <- mEq m1 m2
 136     pure msg
 137   _ -> Nothing
 138
 139 customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))
 140 customRequest m = named m $ satisfyMaybe $ \case
 141   FromServerMess m1 msg -> case splitServerMethod m1 of
 142     IsServerEither -> case msg of
 143       ReqMess _ | m1 == SCustomMethod m -> Just msg
 144       _ -> Nothing
 145     _ -> Nothing
 146   _ -> Nothing
 147
 148 customNotification :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Notification))
 149 customNotification m = named m $ satisfyMaybe $ \case
 150   FromServerMess m1 msg -> case splitServerMethod m1 of
 151     IsServerEither -> case msg of
 152       NotMess _ | m1 == SCustomMethod m -> Just msg
 153       _ -> Nothing
 154     _ -> Nothing
 155   _ -> Nothing
 156
 157 -- | Matches if the message is a notification.
 158 anyNotification :: Session FromServerMessage
 159 anyNotification = named "Any notification" $ satisfy $ \case
 160   FromServerMess m msg -> case splitServerMethod m of
 161     IsServerNot -> True
 162     IsServerEither -> case msg of
 163       NotMess _ -> True
 164       _ -> False
 165     _ -> False
 166   FromServerRsp _ _ -> False
 167
 168 -- | Matches if the message is a request.
 169 anyRequest :: Session FromServerMessage
 170 anyRequest = named "Any request" $ satisfy $ \case
 171   FromServerMess m _ -> case splitServerMethod m of
 172     IsServerReq -> True
 173     _ -> False
 174   FromServerRsp _ _ -> False
 175
 176 -- | Matches if the message is a response.
 177 anyResponse :: Session FromServerMessage
 178 anyResponse = named "Any response" $ satisfy $ \case
 179   FromServerMess _ _ -> False
 180   FromServerRsp _ _ -> True
 181
 182 -- | Matches a response for a specific id.
 183 responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m)
 184 responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do
 185   satisfyMaybe $ \msg -> do
 186     case msg of
 187       FromServerMess _ _ -> Nothing
 188       FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) ->
 189         case mEqClient m m' of
 190           Just HRefl -> do
 191             guard (lid' == Just lid)
 192             pure rspMsg
 193           Nothing
 194             | SCustomMethod tm <- m
 195             , SCustomMethod tm' <- m'
 196             , tm == tm'
 197             , lid' == Just lid -> pure rspMsg
 198           _ -> empty
 199
 200 -- | Matches any type of message.
 201 anyMessage :: Session FromServerMessage
 202 anyMessage = satisfy (const True)
 203
 204 -- | Matches if the message is a log message notification or a show message notification/request.
 205 loggingNotification :: Session FromServerMessage
 206 loggingNotification = named "Logging notification" $ satisfy shouldSkip
 207   where
 208     shouldSkip (FromServerMess SWindowLogMessage _) = True
 209     shouldSkip (FromServerMess SWindowShowMessage _) = True
 210     shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
 211     shouldSkip _ = False
 212
 213 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
 214 -- (textDocument/publishDiagnostics) notification.
 215 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
 216 publishDiagnosticsNotification = named "Publish diagnostics notification" $
 217   satisfyMaybe $ \msg -> case msg of
 218     FromServerMess STextDocumentPublishDiagnostics diags -> Just diags
 219     _ -> Nothing