Skip to content

Commit

Permalink
Fix progress eval test randomly failing (#2590)
Browse files Browse the repository at this point in the history
  • Loading branch information
@eddiemundo
eddiemundo authored Jan 15, 2022
1 parent 9c2bc32 commit acff2bd
Showing 1 changed file with 108 additions and 47 deletions.
155 changes: 108 additions & 47 deletions test/functional/Progress.hs
View file
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

0 comments on commit acff2bd

Please # to comment.