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

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