From dfd75cc59c1448e53081e509216686889de3d776 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 14 Jan 2022 23:32:27 -0500 Subject: [PATCH 1/2] fix eval progress test randomly failing --- test/functional/Progress.hs | 151 +++++++++++++++++++++++++----------- 1 file changed, 104 insertions(+), 47 deletions(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 0f6e4fe9fb..f49efe3e64 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -4,15 +4,18 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} module Progress (tests) where +import Control.Exception (throw) import Control.Lens hiding ((.=)) import Data.Aeson (Value, decode, encode, object, (.=)) import Data.List (delete) import Data.Maybe (fromJust) import Data.Text (Text, pack) +import qualified Language.LSP.Types as LSP import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as L import System.FilePath (()) @@ -20,6 +23,7 @@ import Test.Hls import Test.Hls.Command import Test.Hls.Flags + tests :: TestTree tests = testGroup @@ -28,29 +32,42 @@ tests = runSession hlsCommand progressCaps "test/testdata" $ do let path = "diagnostics" "Foo.hs" _ <- openDoc path "haskell" - expectProgressReports [pack ("Setting up testdata (for " ++ path ++ ")"), "Processing", "Indexing"] + expectProgressMessages [pack ("Setting up testdata (for " ++ path ++ ")"), "Processing", "Indexing"] [] , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do - doc <- openDoc "T1.hs" "haskell" - expectProgressReports ["Setting up testdata (for T1.hs)", "Processing", "Indexing"] - [evalLens] <- getCodeLenses doc - let cmd = evalLens ^?! L.command . _Just - _ <- sendRequest SWorkspaceExecuteCommand $ ExecuteCommandParams Nothing (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) - expectProgressReports ["Evaluating"] + doc <- openDoc "T1.hs" "haskell" + lspId <- sendRequest STextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + + (codeLensResponse, activeProgressTokens) <- expectProgressMessagesTill + (responseForId STextDocumentCodeLens lspId) + ["Setting up testdata (for T1.hs)", "Processing", "Indexing"] + [] + + -- this is a test so exceptions result in fails + let LSP.List [evalLens] = getResponseResult codeLensResponse + let command = evalLens ^?! L.command . _Just + + _ <- sendRequest SWorkspaceExecuteCommand $ + ExecuteCommandParams + Nothing + (command ^. L.command) + (decode $ encode $ fromJust $ command ^. L.arguments) + + expectProgressMessages ["Evaluating"] activeProgressTokens , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendConfigurationChanged (formatLspConfig "ormolu") doc <- openDoc "Format.hs" "haskell" - expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] + expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] [] _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - expectProgressReports ["Formatting Format.hs"] + expectProgressMessages ["Formatting Format.hs"] [] , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendConfigurationChanged (formatLspConfig "fourmolu") doc <- openDoc "Format.hs" "haskell" - expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] + expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] [] _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - expectProgressReports ["Formatting Format.hs"] + expectProgressMessages ["Formatting Format.hs"] [] ] formatLspConfig :: Value -> Value @@ -59,47 +76,87 @@ formatLspConfig provider = object ["haskell" .= object ["formattingProvider" .= progressCaps :: ClientCapabilities progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)} -data CollectedProgressNotification - = CreateM WorkDoneProgressCreateParams - | BeginM (ProgressParams WorkDoneProgressBeginParams) - | ProgressM (ProgressParams WorkDoneProgressReportParams) - | EndM (ProgressParams WorkDoneProgressEndParams) +data ProgressMessage + = ProgressCreate WorkDoneProgressCreateParams + | ProgressBegin (ProgressParams WorkDoneProgressBeginParams) + | ProgressReport (ProgressParams WorkDoneProgressReportParams) + | ProgressEnd (ProgressParams WorkDoneProgressEndParams) -{- | Test that the server is correctly producing a sequence of progress related - messages. Each create must be pair with a corresponding begin and end, - optionally with some progress in between. Tokens must match. The begin - messages have titles describing the work that is in-progress, we check that - the titles we see are those we expect. --} -expectProgressReports :: [Text] -> Session () -expectProgressReports xs = expectProgressReports' [] xs +data InterestingMessage a + = InterestingMessage a + | ProgressMessage ProgressMessage + +progressMessage :: Session ProgressMessage +progressMessage = + progressCreate <|> progressBegin <|> progressReport <|> progressEnd where - expectProgressReports' [] [] = return () - expectProgressReports' tokens expectedTitles = - do - skipManyTill anyMessage (create <|> begin <|> progress <|> end) - >>= \case - CreateM msg -> - expectProgressReports' (token msg : tokens) expectedTitles - BeginM msg -> do - liftIO $ token msg `expectElem` tokens - expectProgressReports' tokens (delete (title msg) expectedTitles) - ProgressM msg -> do - liftIO $ token msg `expectElem` tokens - expectProgressReports' tokens expectedTitles - EndM msg -> do - liftIO $ token msg `expectElem` tokens - expectProgressReports' (delete (token msg) tokens) expectedTitles - title msg = msg ^. L.value . L.title - token msg = msg ^. L.token - create = CreateM . view L.params <$> message SWindowWorkDoneProgressCreate - begin = BeginM <$> satisfyMaybe (\case + progressCreate = ProgressCreate . view L.params <$> message SWindowWorkDoneProgressCreate + progressBegin = ProgressBegin <$> satisfyMaybe (\case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Begin x))) -> Just (ProgressParams t x) _ -> Nothing) - progress = ProgressM <$> satisfyMaybe (\case + progressReport = ProgressReport <$> satisfyMaybe (\case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Report x))) -> Just (ProgressParams t x) _ -> Nothing) - end = EndM <$> satisfyMaybe (\case + progressEnd = ProgressEnd <$> satisfyMaybe (\case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (End x))) -> Just (ProgressParams t x) _ -> Nothing) - expectElem a as = a `elem` as @? "Unexpected " ++ show a + +interestingMessage :: Session a -> Session (InterestingMessage a) +interestingMessage interestingMessage = + fmap InterestingMessage interestingMessage <|> fmap ProgressMessage progressMessage + +expectProgressMessagesTill :: Show a => Session a -> [Text] -> [ProgressToken] -> Session (a, [ProgressToken]) +expectProgressMessagesTill stopMessage expectedTitles activeProgressTokens = do + message <- skipManyTill anyMessage (interestingMessage stopMessage) + case message of + InterestingMessage a -> do + pure (a, activeProgressTokens) + ProgressMessage (ProgressCreate params) -> do + expectProgressMessagesTill stopMessage expectedTitles (getToken params : activeProgressTokens) + ProgressMessage (ProgressBegin params) -> do + liftIO $ getToken params `expectedIn` activeProgressTokens + expectProgressMessagesTill stopMessage (delete (getTitle params) expectedTitles) activeProgressTokens + ProgressMessage (ProgressReport params) -> do + liftIO $ getToken params `expectedIn` activeProgressTokens + expectProgressMessagesTill stopMessage expectedTitles activeProgressTokens + ProgressMessage (ProgressEnd params) -> do + liftIO $ getToken params `expectedIn` activeProgressTokens + expectProgressMessagesTill stopMessage expectedTitles (delete (getToken params) activeProgressTokens) + +{- | Test that the server is correctly producing a sequence of progress related + messages. Each create must be pair with a corresponding begin and end, + optionally with some progress in between. Tokens must match. The begin + messages have titles describing the work that is in-progress, we check that + the titles we see are those we expect. +-} +expectProgressMessages :: [Text] -> [ProgressToken] -> Session () +expectProgressMessages [] [] = pure () +expectProgressMessages expectedTitles activeProgressTokens = do + message <- skipManyTill anyMessage progressMessage + case message of + ProgressCreate params -> do + expectProgressMessages expectedTitles (getToken params : activeProgressTokens) + ProgressBegin params -> do + liftIO $ getToken params `expectedIn` activeProgressTokens + expectProgressMessages (delete (getTitle params) expectedTitles) activeProgressTokens + ProgressReport params -> do + liftIO $ getToken params `expectedIn` activeProgressTokens + expectProgressMessages expectedTitles activeProgressTokens + ProgressEnd params -> do + liftIO $ getToken params `expectedIn` activeProgressTokens + expectProgressMessages expectedTitles (delete (getToken params) activeProgressTokens) + +getTitle :: (L.HasValue s a1, L.HasTitle a1 a2) => s -> a2 +getTitle msg = msg ^. L.value . L.title + +getToken :: L.HasToken s a => s -> a +getToken msg = msg ^. L.token + +expectedIn :: (Foldable t, Eq a, Show a) => a -> t a -> Assertion +expectedIn a as = a `elem` as @? "Unexpected " ++ show a + +getResponseResult :: ResponseMessage m -> ResponseResult m +getResponseResult rsp = + case rsp ^. L.result of + Right x -> x + Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err From 850f3712359ea95404ef2d32560ebb4ad4029a0b Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 15 Jan 2022 15:20:22 -0500 Subject: [PATCH 2/2] factor out common logic into separate function --- test/functional/Progress.hs | 42 ++++++++++++++++++++----------------- 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index f49efe3e64..d131fc6175 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -102,26 +102,22 @@ progressMessage = _ -> Nothing) interestingMessage :: Session a -> Session (InterestingMessage a) -interestingMessage interestingMessage = - fmap InterestingMessage interestingMessage <|> fmap ProgressMessage progressMessage +interestingMessage theMessage = + fmap InterestingMessage theMessage <|> fmap ProgressMessage progressMessage -expectProgressMessagesTill :: Show a => Session a -> [Text] -> [ProgressToken] -> Session (a, [ProgressToken]) +expectProgressMessagesTill :: Session a -> [Text] -> [ProgressToken] -> Session (a, [ProgressToken]) expectProgressMessagesTill stopMessage expectedTitles activeProgressTokens = do message <- skipManyTill anyMessage (interestingMessage stopMessage) case message of InterestingMessage a -> do + liftIO $ null expectedTitles @? "Expected titles not empty " <> show expectedTitles pure (a, activeProgressTokens) - ProgressMessage (ProgressCreate params) -> do - expectProgressMessagesTill stopMessage expectedTitles (getToken params : activeProgressTokens) - ProgressMessage (ProgressBegin params) -> do - liftIO $ getToken params `expectedIn` activeProgressTokens - expectProgressMessagesTill stopMessage (delete (getTitle params) expectedTitles) activeProgressTokens - ProgressMessage (ProgressReport params) -> do - liftIO $ getToken params `expectedIn` activeProgressTokens - expectProgressMessagesTill stopMessage expectedTitles activeProgressTokens - ProgressMessage (ProgressEnd params) -> do - liftIO $ getToken params `expectedIn` activeProgressTokens - expectProgressMessagesTill stopMessage expectedTitles (delete (getToken params) activeProgressTokens) + ProgressMessage progressMessage -> + updateExpectProgressStateAndRecurseWith + (expectProgressMessagesTill stopMessage) + progressMessage + expectedTitles + activeProgressTokens {- | Test that the server is correctly producing a sequence of progress related messages. Each create must be pair with a corresponding begin and end, @@ -133,18 +129,26 @@ expectProgressMessages :: [Text] -> [ProgressToken] -> Session () expectProgressMessages [] [] = pure () expectProgressMessages expectedTitles activeProgressTokens = do message <- skipManyTill anyMessage progressMessage - case message of + updateExpectProgressStateAndRecurseWith expectProgressMessages message expectedTitles activeProgressTokens + +updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> Session a) + -> ProgressMessage + -> [Text] + -> [ProgressToken] + -> Session a +updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles activeProgressTokens = do + case progressMessage of ProgressCreate params -> do - expectProgressMessages expectedTitles (getToken params : activeProgressTokens) + f expectedTitles (getToken params : activeProgressTokens) ProgressBegin params -> do liftIO $ getToken params `expectedIn` activeProgressTokens - expectProgressMessages (delete (getTitle params) expectedTitles) activeProgressTokens + f (delete (getTitle params) expectedTitles) activeProgressTokens ProgressReport params -> do liftIO $ getToken params `expectedIn` activeProgressTokens - expectProgressMessages expectedTitles activeProgressTokens + f expectedTitles activeProgressTokens ProgressEnd params -> do liftIO $ getToken params `expectedIn` activeProgressTokens - expectProgressMessages expectedTitles (delete (getToken params) activeProgressTokens) + f expectedTitles (delete (getToken params) activeProgressTokens) getTitle :: (L.HasValue s a1, L.HasTitle a1 a2) => s -> a2 getTitle msg = msg ^. L.value . L.title