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

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 {-# LANGUAGE KindSignatures #-}
   4 {-# LANGUAGE DataKinds #-}
   5 {-# LANGUAGE GADTs #-}
   6 {-# LANGUAGE LambdaCase #-}
   7 {-# LANGUAGE RankNTypes #-}
   8 {-# LANGUAGE OverloadedStrings #-}
   9
  10 module Language.Haskell.LSP.Test.Parsing
  11   ( -- $receiving
  12     satisfy
  13   , satisfyMaybe
  14   , anyRequest
  15   , anyResponse
  16   , anyNotification
  17   , anyMessage
  18   , loggingNotification
  19   , publishDiagnosticsNotification
  20   , responseForId
  21   ) where
  22
  23 import Control.Applicative
  24 import Control.Concurrent
  25 import Control.Lens
  26 import Control.Monad.IO.Class
  27 import Control.Monad
  28 import Data.Aeson
  29 import qualified Data.ByteString.Lazy.Char8 as B
  30 import Data.Conduit.Parser hiding (named)
  31 import qualified Data.Conduit.Parser (named)
  32 import qualified Data.Text as T
  33 import Data.Typeable
  34 import Language.Haskell.LSP.Types
  35 import qualified Language.Haskell.LSP.Types.Lens as LSP
  36 import Language.Haskell.LSP.Test.Messages
  37 import Language.Haskell.LSP.Test.Session
  38
  39 -- $receiving
  40 -- To receive a message, just specify the type that expect:
  41 --
  42 -- @
  43 -- msg1 <- message :: Session ApplyWorkspaceEditRequest
  44 -- msg2 <- message :: Session HoverResponse
  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 :: Session DefinitionRequest)
  56 -- >          <|> (message :: Session ReferencesRequest)
  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 :: Session TelemetryNotification)
  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 = do
  78
  79   skipTimeout <- overridingTimeout <$> get
  80   timeoutId <- getCurTimeoutId
  81   unless skipTimeout $ do
  82     chan <- asks messageChan
  83     timeout <- asks (messageTimeout . config)
  84     void $ liftIO $ forkIO $ do
  85       threadDelay (timeout * 1000000)
  86       writeChan chan (TimeoutMessage timeoutId)
  87
  88   x <- Session await
  89
  90   unless skipTimeout (bumpTimeoutId timeoutId)
  91
  92   modify $ \s -> s { lastReceivedMessage = Just x }
  93
  94   case pred x of
  95     Just a -> do
  96       logMsg LogServer x
  97       return a
  98     Nothing -> empty
  99
 100 named :: T.Text -> Session a -> Session a
 101 named s (Session x) = Session (Data.Conduit.Parser.named s x)
 102
 103 {-
 104 -- | Matches a message of type @a@.
 105 message :: forall a. (Typeable a, FromJSON a) => Session a
 106 message =
 107   let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
 108   in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
 109      satisfyMaybe parser
 110 -}
 111
 112 -- | Matches if the message is a notification.
 113 anyNotification :: Session FromServerMessage
 114 anyNotification = named "Any notification" $ satisfy $ \case
 115   FromServerMess m _ -> case splitServerMethod m of
 116     IsServerNot -> True
 117     _ -> False
 118   FromServerRsp _ _ -> False
 119
 120 -- | Matches if the message is a request.
 121 anyRequest :: Session FromServerMessage
 122 anyRequest = named "Any request" $ satisfy $ \case
 123   FromServerMess m _ -> case splitServerMethod m of
 124     IsServerReq -> True
 125     _ -> False
 126   FromServerRsp _ _ -> False
 127
 128 -- | Matches if the message is a response.
 129 anyResponse :: Session FromServerMessage
 130 anyResponse = named "Any response" $ satisfy $ \case
 131   FromServerMess _ _ -> False
 132   FromServerRsp _ _ -> True
 133
 134 -- | Matches a response for a specific id.
 135 responseForId :: LspId (m :: Method FromClient Request) -> Session (ResponseMessage m)
 136 responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
 137   satisfyMaybe $ \msg -> do
 138     case msg of
 139       FromServerMess _ _ -> Nothing
 140       FromServerRsp m rsp -> undefined -- TODO
 141
 142 -- | Matches any type of message.
 143 anyMessage :: Session FromServerMessage
 144 anyMessage = satisfy (const True)
 145
 146 -- | Matches if the message is a log message notification or a show message notification/request.
 147 loggingNotification :: Session FromServerMessage
 148 loggingNotification = named "Logging notification" $ satisfy shouldSkip
 149   where
 150     shouldSkip (FromServerMess SWindowLogMessage _) = True
 151     shouldSkip (FromServerMess SWindowShowMessage _) = True
 152     shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
 153     shouldSkip _ = False
 154
 155 -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
 156 -- (textDocument/publishDiagnostics) notification.
 157 publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
 158 publishDiagnosticsNotification = named "Publish diagnostics notification" $
 159   satisfyMaybe $ \msg -> case msg of
 160     FromServerMess STextDocumentPublishDiagnostics diags -> Just diags
 161     _ -> Nothing