Skip to content

Fix progress eval test randomly failing #2590

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
pepeiborra merged 2 commits into from
Jan 15, 2022
Merged

Fix progress eval test randomly failing #2590

Changes from 1 commit
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
dfd75cc
fix eval progress test randomly failing
eddiemundo Jan 15, 2022
850f371
factor out common logic into separate function
eddiemundo Jan 15, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
151 changes: 104 additions & 47 deletions test/functional/Progress.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,22 +4,26 @@
{-# 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 ((</>))
import Test.Hls
import Test.Hls.Command
import Test.Hls.Flags


tests :: TestTree
tests =
testGroup
Expand All @@ -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
Expand All @@ -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