X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FParsing.hs;h=d1fec456221dca4168fe1fdcfa5cf076c7a1ef99;hb=98d03792f46f3ac870c010a78944822569e76763;hp=9d2dd702c78d2065b53835e12cc11a4f3dd4b9be;hpb=c78547478baf6c47849921fa8e1c391472685e99;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 9d2dd70..d1fec45 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -1,51 +1,161 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Language.Haskell.LSP.Test.Parsing where +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Test.Messages +module Language.Haskell.LSP.Test.Parsing + ( -- $receiving + satisfy + , satisfyMaybe + , anyRequest + , anyResponse + , anyNotification + , anyMessage + , loggingNotification + , publishDiagnosticsNotification + , responseForId + ) where + +import Control.Applicative import Control.Concurrent -import Text.Parsec hiding (satisfy) +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.Parser hiding (named) +import qualified Data.Conduit.Parser (named) +import qualified Data.Text as T +import Data.Typeable +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 + +-- $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 <- getCurTimeoutId + unless skipTimeout $ do + chan <- asks messageChan + timeout <- asks (messageTimeout . config) + void $ liftIO $ forkIO $ do + threadDelay (timeout * 1000000) + writeChan chan (TimeoutMessage timeoutId) + + x <- Session await + + unless skipTimeout (bumpTimeoutId timeoutId) + + modify $ \s -> s { lastReceivedMessage = Just x } -data MessageParserState = MessageParserState + case pred x of + Just a -> do + logMsg LogServer x + return a + Nothing -> empty -type MessageParser = ParsecT (Chan FromServerMessage) MessageParserState IO +named :: T.Text -> Session a -> Session a +named s (Session x) = Session (Data.Conduit.Parser.named s x) -notification :: MessageParser FromServerMessage -notification = satisfy isServerNotification +{- +-- | 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 +-} -request :: MessageParser FromServerMessage -request = satisfy isServerRequest +-- | Matches if the message is a notification. +anyNotification :: Session FromServerMessage +anyNotification = named "Any notification" $ satisfy $ \case + FromServerMess m _ -> case splitServerMethod m of + IsServerNot -> True + _ -> False + FromServerRsp _ _ -> False -response :: MessageParser FromServerMessage -response = satisfy isServerResponse +-- | Matches if the message is a request. +anyRequest :: Session FromServerMessage +anyRequest = named "Any request" $ satisfy $ \case + FromServerMess m _ -> case splitServerMethod m of + IsServerReq -> True + _ -> False + FromServerRsp _ _ -> False -satisfy :: (Stream s m a, Eq a, Show a) => (a -> Bool) -> ParsecT s u m a -satisfy pred = tokenPrim show nextPos test - where nextPos x _ _ = x - test x = if pred x then Just x else Nothing +-- | Matches if the message is a response. +anyResponse :: Session FromServerMessage +anyResponse = named "Any response" $ satisfy $ \case + FromServerMess _ _ -> False + FromServerRsp _ _ -> True -testLog = NotLogMessage (NotificationMessage "2.0" WindowLogMessage (LogMessageParams MtLog "Hello world")) +-- | Matches a response for a specific id. +responseForId :: LspId (m :: Method FromClient Request) -> Session (ResponseMessage m) +responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do + satisfyMaybe $ \msg -> do + case msg of + FromServerMess _ _ -> Nothing + FromServerRsp m rsp -> undefined -- TODO -testSymbols = RspDocumentSymbols (ResponseMessage "2.0" (IdRspInt 0) (Just (List [])) Nothing) +-- | Matches any type of message. +anyMessage :: Session FromServerMessage +anyMessage = satisfy (const True) -instance Stream (Chan a) IO a where - uncons c = do - x <- readChan c - return $ Just (x, c) +-- | Matches if the message is a log message notification or a show message notification/request. +loggingNotification :: Session FromServerMessage +loggingNotification = named "Logging notification" $ satisfy shouldSkip + where + shouldSkip (FromServerMess SWindowLogMessage _) = True + shouldSkip (FromServerMess SWindowShowMessage _) = True + shouldSkip (FromServerMess SWindowShowMessageRequest _) = True + shouldSkip _ = False -test :: IO () -test = do - chan <- newChan - let parser = do - n <- count 2 notification - rsp <- response - return (n, rsp) - forkIO $ forM_ [testLog, testLog, testSymbols] $ \x -> do - writeChan chan x - threadDelay 1000000 - x <- runParserT parser MessageParserState "" chan - print x \ 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 + FromServerMess STextDocumentPublishDiagnostics diags -> Just diags + _ -> Nothing