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
merged 2 commits into from
Jan 15, 2022
Merged

Fix progress eval test randomly failing #2590

Changes from all commits
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
155 changes: 108 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,91 @@ 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 theMessage =
fmap InterestingMessage theMessage <|> fmap ProgressMessage progressMessage

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 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,
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
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
f expectedTitles (getToken params : activeProgressTokens)
ProgressBegin params -> do
liftIO $ getToken params `expectedIn` activeProgressTokens
f (delete (getTitle params) expectedTitles) activeProgressTokens
ProgressReport params -> do
liftIO $ getToken params `expectedIn` activeProgressTokens
f expectedTitles activeProgressTokens
ProgressEnd params -> do
liftIO $ getToken params `expectedIn` 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

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