X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FParsing.hs;h=d1fec456221dca4168fe1fdcfa5cf076c7a1ef99;hb=98d03792f46f3ac870c010a78944822569e76763;hp=f292af579b5b94951f873e0c695a55cd1ec1bd69;hpb=a8e8371de3168f0faae2f33eae0d97f466c4786f;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index f292af5..d1fec45 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -1,12 +1,16 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} module Language.Haskell.LSP.Test.Parsing ( -- $receiving satisfy - , message + , satisfyMaybe , anyRequest , anyResponse , anyNotification @@ -23,10 +27,10 @@ import Control.Monad.IO.Class import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B -import Data.Conduit.Parser +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.Messages import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.Test.Messages @@ -73,7 +77,7 @@ satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a satisfyMaybe pred = do skipTimeout <- overridingTimeout <$> get - timeoutId <- curTimeoutId <$> get + timeoutId <- getCurTimeoutId unless skipTimeout $ do chan <- asks messageChan timeout <- asks (messageTimeout . config) @@ -83,8 +87,7 @@ satisfyMaybe pred = do x <- Session await - unless skipTimeout $ - modify $ \s -> s { curTimeoutId = timeoutId + 1 } + unless skipTimeout (bumpTimeoutId timeoutId) modify $ \s -> s { lastReceivedMessage = Just x } @@ -94,55 +97,65 @@ satisfyMaybe pred = do return a Nothing -> empty +named :: T.Text -> Session a -> Session a +named s (Session x) = Session (Data.Conduit.Parser.named s x) + +{- -- | Matches a message of type @a@. message :: forall a. (Typeable a, FromJSON a) => Session a message = let parser = decode . encodeMsg :: FromServerMessage -> Maybe a - in satisfyMaybe parser + 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 = satisfy isServerNotification +anyNotification = named "Any notification" $ satisfy $ \case + FromServerMess m _ -> case splitServerMethod m of + IsServerNot -> True + _ -> False + FromServerRsp _ _ -> False -- | Matches if the message is a request. anyRequest :: Session FromServerMessage -anyRequest = satisfy isServerRequest +anyRequest = named "Any request" $ satisfy $ \case + FromServerMess m _ -> case splitServerMethod m of + IsServerReq -> True + _ -> False + FromServerRsp _ _ -> False -- | Matches if the message is a response. anyResponse :: Session FromServerMessage -anyResponse = satisfy isServerResponse +anyResponse = named "Any response" $ satisfy $ \case + FromServerMess _ _ -> False + FromServerRsp _ _ -> True -- | Matches a response for a specific id. -responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a) -responseForId lid = do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) +responseForId :: LspId (m :: Method FromClient Request) -> Session (ResponseMessage m) +responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do satisfyMaybe $ \msg -> do - z <- parser msg - guard (z ^. LSP.id == responseId lid) - pure z + case msg of + FromServerMess _ _ -> Nothing + FromServerRsp m rsp -> undefined -- TODO -- | 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 }) - -- | Matches if the message is a log message notification or a show message notification/request. loggingNotification :: Session FromServerMessage -loggingNotification = satisfy shouldSkip +loggingNotification = named "Logging notification" $ satisfy shouldSkip where - shouldSkip (NotLogMessage _) = True - shouldSkip (NotShowMessage _) = True - shouldSkip (ReqShowMessage _) = True + shouldSkip (FromServerMess SWindowLogMessage _) = True + shouldSkip (FromServerMess SWindowShowMessage _) = True + shouldSkip (FromServerMess SWindowShowMessageRequest _) = True shouldSkip _ = False -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification' -- (textDocument/publishDiagnostics) notification. publishDiagnosticsNotification :: Session PublishDiagnosticsNotification -publishDiagnosticsNotification = satisfyMaybe $ - \msg -> case msg of - NotPublishDiagnostics diags -> Just diags +publishDiagnosticsNotification = named "Publish diagnostics notification" $ + satisfyMaybe $ \msg -> case msg of + FromServerMess STextDocumentPublishDiagnostics diags -> Just diags _ -> Nothing