X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FParsing.hs;h=52f97ae8e80a62da02e4614f5f00a5241cd5f175;hb=9812e6a4ec0c6be7e2d59b49fca677a16c314359;hp=b28047ce0f93ac75fee9f54fad0581ab39d9ebf7;hpb=0da56e90a0fd4ada9acb01ca9ce769c5924653ec;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index b28047c..52f97ae 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -2,75 +2,129 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} -module Language.Haskell.LSP.Test.Parsing where + +module Language.Haskell.LSP.Test.Parsing + ( -- $receiving + satisfy + , message + , anyRequest + , anyResponse + , anyNotification + , anyMessage + , loggingNotification + , publishDiagnosticsNotification + , responseForId + ) where import Control.Applicative import Control.Concurrent +import Control.Lens import Control.Monad.IO.Class -import Control.Monad.Trans.Class +import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B import Data.Conduit.Parser -import Data.Maybe +import qualified Data.Text as T +import Data.Typeable import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types hiding (error) -import Language.Haskell.LSP.Test.Exceptions +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.Test.Messages import Language.Haskell.LSP.Test.Session -import System.Console.ANSI -satisfy :: (MonadIO m, MonadSessionConfig m) => (FromServerMessage -> Bool) -> ConduitParser FromServerMessage m FromServerMessage -satisfy pred = do - timeout <- timeout <$> lift sessionConfig - tId <- liftIO myThreadId - timeoutThread <- liftIO $ forkIO $ do +-- $receiving +-- To receive a message, just specify the type that expect: +-- +-- @ +-- msg1 <- message :: Session ApplyWorkspaceEditRequest +-- msg2 <- message :: Session HoverResponse +-- @ +-- +-- 'Language.Haskell.LSP.Test.Session' is actually just a parser +-- that operates on messages under the hood. This means that you +-- can create and combine parsers to match speicifc sequences of +-- messages that you expect. +-- +-- For example, if you wanted to match either a definition or +-- references request: +-- +-- > defOrImpl = (message :: Session DefinitionRequest) +-- > <|> (message :: Session ReferencesRequest) +-- +-- If you wanted to match any number of telemetry +-- notifications immediately followed by a response: +-- +-- @ +-- logThenDiags = +-- skipManyTill (message :: Session TelemetryNotification) +-- anyResponse +-- @ + +-- | Consumes and returns the next message, if it satisfies the specified predicate. +-- +-- @since 0.5.2.0 +satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage +satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing) + +-- | Consumes and returns the result of the specified predicate if it returns `Just`. +-- +-- @since 0.6.1.0 +satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a +satisfyMaybe pred = do + + skipTimeout <- overridingTimeout <$> get + timeoutId <- curTimeoutId <$> get + unless skipTimeout $ do + chan <- asks messageChan + timeout <- asks (messageTimeout . config) + void $ liftIO $ forkIO $ do threadDelay (timeout * 1000000) - throwTo tId TimeoutException + writeChan chan (TimeoutMessage timeoutId) + x <- await - liftIO $ killThread timeoutThread - if pred x - then do - liftIO $ do - setSGR [SetColor Foreground Vivid Magenta] - putStrLn $ "<-- " ++ B.unpack (encodeMsg x) - setSGR [Reset] - return x - else empty + unless skipTimeout $ + modify $ \s -> s { curTimeoutId = timeoutId + 1 } + + modify $ \s -> s { lastReceivedMessage = Just x } + + case pred x of + Just a -> do + logMsg LogServer x + return a + Nothing -> empty + +-- | Matches a message of type @a@. +message :: forall a. (Typeable a, FromJSON a) => Session a +message = + let parser = decode . encodeMsg :: FromServerMessage -> Maybe a + in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ + satisfyMaybe parser -- | Matches if the message is a notification. -anyNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +anyNotification :: Session FromServerMessage anyNotification = named "Any notification" $ satisfy isServerNotification -notification :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a) -notification = named "Notification" $ do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a) - x <- satisfy (isJust . parser) - return $ castMsg x - -- | Matches if the message is a request. -anyRequest :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +anyRequest :: Session FromServerMessage anyRequest = named "Any request" $ satisfy isServerRequest -request :: forall m a b. (MonadIO m, MonadSessionConfig m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b) -request = named "Request" $ do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b) - x <- satisfy (isJust . parser) - return $ castMsg x - -- | Matches if the message is a response. -anyResponse :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +anyResponse :: Session FromServerMessage anyResponse = named "Any response" $ satisfy isServerResponse -response :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a) -response = named "Response" $ do +-- | Matches a response for a specific id. +responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a) +responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) - x <- satisfy (isJust . parser) - return $ castMsg x + satisfyMaybe $ \msg -> do + z <- parser msg + guard (z ^. LSP.id == responseId lid) + pure z --- | A stupid method for getting out the inner message. -castMsg :: FromJSON a => FromServerMessage -> a -castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg +-- | Matches any type of message. +anyMessage :: Session FromServerMessage +anyMessage = satisfy (const True) -- | A version of encode that encodes FromServerMessages as if they -- weren't wrapped. @@ -78,7 +132,7 @@ encodeMsg :: FromServerMessage -> B.ByteString encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue }) -- | Matches if the message is a log message notification or a show message notification/request. -loggingNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +loggingNotification :: Session FromServerMessage loggingNotification = named "Logging notification" $ satisfy shouldSkip where shouldSkip (NotLogMessage _) = True @@ -86,9 +140,10 @@ loggingNotification = named "Logging notification" $ satisfy shouldSkip shouldSkip (ReqShowMessage _) = True shouldSkip _ = False -publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification -publishDiagnosticsNotification = named "Publish diagnostics notification" $ do - NotPublishDiagnostics diags <- satisfy test - return diags - where test (NotPublishDiagnostics _) = True - test _ = False \ No newline at end of file +-- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification' +-- (textDocument/publishDiagnostics) notification. +publishDiagnosticsNotification :: Session PublishDiagnosticsNotification +publishDiagnosticsNotification = named "Publish diagnostics notification" $ + satisfyMaybe $ \msg -> case msg of + NotPublishDiagnostics diags -> Just diags + _ -> Nothing