X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FParsing.hs;h=52f97ae8e80a62da02e4614f5f00a5241cd5f175;hb=9812e6a4ec0c6be7e2d59b49fca677a16c314359;hp=3496322ca6ff0f8d95bd799fb23ffc219484c04e;hpb=edee40c4aba2607c652cace2da780c373612665f;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 3496322..52f97ae 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -1,129 +1,149 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} -module Language.Haskell.LSP.Test.Parsing where +{-# LANGUAGE OverloadedStrings #-} + +module Language.Haskell.LSP.Test.Parsing + ( -- $receiving + satisfy + , message + , anyRequest + , anyResponse + , anyNotification + , anyMessage + , loggingNotification + , publishDiagnosticsNotification + , responseForId + ) where import Control.Applicative -import Control.Concurrent.Chan -import Control.Concurrent.MVar -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State +import Control.Concurrent +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B -import Data.Conduit hiding (await) 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.Compat -import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.Test.Messages -import System.IO +import Language.Haskell.LSP.Test.Session -data SessionContext = SessionContext - { - serverIn :: Handle, - rootDir :: FilePath, - messageChan :: Chan FromServerMessage, - requestMap :: MVar RequestMap - } - -newtype SessionState = SessionState - { - curReqId :: LspId - } - -type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) - --- | A session representing one instance of launching and connecting to a server. +-- $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: -- --- You can send and receive messages to the server within 'Session' via 'getMessage', --- 'sendRequest' and 'sendNotification'. +-- > defOrImpl = (message :: Session DefinitionRequest) +-- > <|> (message :: Session ReferencesRequest) +-- +-- If you wanted to match any number of telemetry +-- notifications immediately followed by a response: -- -- @ --- runSession \"path\/to\/root\/dir\" $ do --- docItem <- getDocItem "Desktop/simple.hs" "haskell" --- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) --- diagnostics <- getMessage :: Session PublishDiagnosticsNotification +-- logThenDiags = +-- skipManyTill (message :: Session TelemetryNotification) +-- anyResponse -- @ -type Session = ParserStateReader FromServerMessage SessionState SessionContext IO --- | Matches if the message is a notification. -anyNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage -anyNotification = satisfy isServerNotification +-- | 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) -notification :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a) -notification = do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a) - x <- satisfy (isJust . parser) - return $ decodeMsg $ encodeMsg x +-- | 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) + writeChan chan (TimeoutMessage timeoutId) --- | Matches if the message is a request. -anyRequest :: Monad m => ConduitParser FromServerMessage m FromServerMessage -anyRequest = satisfy isServerRequest + x <- await + + unless skipTimeout $ + modify $ \s -> s { curTimeoutId = timeoutId + 1 } -request :: forall m a b. (Monad m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b) -request = do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b) - x <- satisfy (isJust . parser) - return $ decodeMsg $ encodeMsg x + 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 :: Session FromServerMessage +anyNotification = named "Any notification" $ satisfy isServerNotification + +-- | Matches if the message is a request. +anyRequest :: Session FromServerMessage +anyRequest = named "Any request" $ satisfy isServerRequest -- | Matches if the message is a response. -anyResponse :: Monad m => ConduitParser FromServerMessage m FromServerMessage -anyResponse = satisfy isServerResponse +anyResponse :: Session FromServerMessage +anyResponse = named "Any response" $ satisfy isServerResponse -response :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a) -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 $ decodeMsg $ encodeMsg x + satisfyMaybe $ \msg -> do + z <- parser msg + guard (z ^. LSP.id == responseId lid) + pure z + +-- | 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. encodeMsg :: FromServerMessage -> B.ByteString encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue }) -decodeMsg :: FromJSON a => B.ByteString -> a -decodeMsg x = fromMaybe (error $ "Unexpected message type\nGot:\n " ++ show x) - (decode x) - -- | Matches if the message is a log message notification or a show message notification/request. -loggingNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage -loggingNotification = satisfy shouldSkip +loggingNotification :: Session FromServerMessage +loggingNotification = named "Logging notification" $ satisfy shouldSkip where shouldSkip (NotLogMessage _) = True shouldSkip (NotShowMessage _) = True shouldSkip (ReqShowMessage _) = True shouldSkip _ = False -publishDiagnosticsNotification :: Monad m => ConduitParser FromServerMessage m PublishDiagnosticsNotification -publishDiagnosticsNotification = do - NotPublishDiagnostics diags <- satisfy test - return diags - where test (NotPublishDiagnostics _) = True - test _ = False - -satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a -satisfy pred = do - x <- await - if pred x - then return x - else empty - -runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession' chan context state session = runReaderT (runStateT conduit state) context - where conduit = runConduit $ chanSource chan .| runConduitParser session - -get :: Monad m => ParserStateReader a s r m s -get = lift Control.Monad.Trans.State.get - -put :: Monad m => s -> ParserStateReader a s r m () -put = lift . Control.Monad.Trans.State.put - -modify :: Monad m => (s -> s) -> ParserStateReader a s r m () -modify = lift . Control.Monad.Trans.State.modify - -ask :: Monad m => ParserStateReader a s r m r -ask = lift $ lift Control.Monad.Trans.Reader.ask +-- | 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