Skip to content

Commit acff2bd

Browse files
eddiemundoeddiemundo
authored
Fix progress eval test randomly failing (#2590)
1 parent 9c2bc32 commit acff2bd

File tree

1 file changed

+108
-47
lines changed

1 file changed

+108
-47
lines changed

‎test/functional/Progress.hs‎

Lines changed: 108 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -4,22 +4,26 @@
44
{-# LANGUAGE GADTs #-}
55
{-# LANGUAGE LambdaCase #-}
66
{-# LANGUAGE OverloadedStrings #-}
7+
{-# LANGUAGE PolyKinds #-}
78

89
module Progress (tests) where
910

11+
import Control.Exception (throw)
1012
import Control.Lens hiding ((.=))
1113
import Data.Aeson (Value, decode, encode, object,
1214
(.=))
1315
import Data.List (delete)
1416
import Data.Maybe (fromJust)
1517
import Data.Text (Text, pack)
18+
import qualified Language.LSP.Types as LSP
1619
import Language.LSP.Types.Capabilities
1720
import qualified Language.LSP.Types.Lens as L
1821
import System.FilePath ((</>))
1922
import Test.Hls
2023
import Test.Hls.Command
2124
import Test.Hls.Flags
2225

26+
2327
tests :: TestTree
2428
tests =
2529
testGroup
@@ -28,29 +32,42 @@ tests =
2832
runSession hlsCommand progressCaps "test/testdata" $ do
2933
let path = "diagnostics" </> "Foo.hs"
3034
_ <- openDoc path "haskell"
31-
expectProgressReports [pack ("Setting up testdata (for " ++ path ++ ")"), "Processing", "Indexing"]
35+
expectProgressMessages [pack ("Setting up testdata (for " ++ path ++ ")"), "Processing", "Indexing"] []
3236
, requiresEvalPlugin $ testCase "eval plugin sends progress reports" $
3337
runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do
34-
doc <- openDoc "T1.hs" "haskell"
35-
expectProgressReports ["Setting up testdata (for T1.hs)", "Processing", "Indexing"]
36-
[evalLens] <- getCodeLenses doc
37-
let cmd = evalLens ^?! L.command . _Just
38-
_ <- sendRequest SWorkspaceExecuteCommand $ ExecuteCommandParams Nothing (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments)
39-
expectProgressReports ["Evaluating"]
38+
doc <- openDoc "T1.hs" "haskell"
39+
lspId <- sendRequest STextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
40+
41+
(codeLensResponse, activeProgressTokens) <- expectProgressMessagesTill
42+
(responseForId STextDocumentCodeLens lspId)
43+
["Setting up testdata (for T1.hs)", "Processing", "Indexing"]
44+
[]
45+
46+
-- this is a test so exceptions result in fails
47+
let LSP.List [evalLens] = getResponseResult codeLensResponse
48+
let command = evalLens ^?! L.command . _Just
49+
50+
_ <- sendRequest SWorkspaceExecuteCommand $
51+
ExecuteCommandParams
52+
Nothing
53+
(command ^. L.command)
54+
(decode $ encode $ fromJust $ command ^. L.arguments)
55+
56+
expectProgressMessages ["Evaluating"] activeProgressTokens
4057
, requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do
4158
runSession hlsCommand progressCaps "test/testdata/format" $ do
4259
sendConfigurationChanged (formatLspConfig "ormolu")
4360
doc <- openDoc "Format.hs" "haskell"
44-
expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"]
61+
expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] []
4562
_ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
46-
expectProgressReports ["Formatting Format.hs"]
63+
expectProgressMessages ["Formatting Format.hs"] []
4764
, requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do
4865
runSession hlsCommand progressCaps "test/testdata/format" $ do
4966
sendConfigurationChanged (formatLspConfig "fourmolu")
5067
doc <- openDoc "Format.hs" "haskell"
51-
expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"]
68+
expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] []
5269
_ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
53-
expectProgressReports ["Formatting Format.hs"]
70+
expectProgressMessages ["Formatting Format.hs"] []
5471
]
5572

5673
formatLspConfig :: Value -> Value
@@ -59,47 +76,91 @@ formatLspConfig provider = object ["haskell" .= object ["formattingProvider" .=
5976
progressCaps :: ClientCapabilities
6077
progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)}
6178

62-
data CollectedProgressNotification
63-
= CreateM WorkDoneProgressCreateParams
64-
| BeginM (ProgressParams WorkDoneProgressBeginParams)
65-
| ProgressM (ProgressParams WorkDoneProgressReportParams)
66-
| EndM (ProgressParams WorkDoneProgressEndParams)
79+
data ProgressMessage
80+
= ProgressCreate WorkDoneProgressCreateParams
81+
| ProgressBegin (ProgressParams WorkDoneProgressBeginParams)
82+
| ProgressReport (ProgressParams WorkDoneProgressReportParams)
83+
| ProgressEnd (ProgressParams WorkDoneProgressEndParams)
6784

68-
{- | Test that the server is correctly producing a sequence of progress related
69-
messages. Each create must be pair with a corresponding begin and end,
70-
optionally with some progress in between. Tokens must match. The begin
71-
messages have titles describing the work that is in-progress, we check that
72-
the titles we see are those we expect.
73-
-}
74-
expectProgressReports :: [Text] -> Session ()
75-
expectProgressReports xs = expectProgressReports' [] xs
85+
data InterestingMessage a
86+
= InterestingMessage a
87+
| ProgressMessage ProgressMessage
88+
89+
progressMessage :: Session ProgressMessage
90+
progressMessage =
91+
progressCreate <|> progressBegin <|> progressReport <|> progressEnd
7692
where
77-
expectProgressReports' [] [] = return ()
78-
expectProgressReports' tokens expectedTitles =
79-
do
80-
skipManyTill anyMessage (create <|> begin <|> progress <|> end)
81-
>>= \case
82-
CreateM msg ->
83-
expectProgressReports' (token msg : tokens) expectedTitles
84-
BeginM msg -> do
85-
liftIO $ token msg `expectElem` tokens
86-
expectProgressReports' tokens (delete (title msg) expectedTitles)
87-
ProgressM msg -> do
88-
liftIO $ token msg `expectElem` tokens
89-
expectProgressReports' tokens expectedTitles
90-
EndM msg -> do
91-
liftIO $ token msg `expectElem` tokens
92-
expectProgressReports' (delete (token msg) tokens) expectedTitles
93-
title msg = msg ^. L.value . L.title
94-
token msg = msg ^. L.token
95-
create = CreateM . view L.params <$> message SWindowWorkDoneProgressCreate
96-
begin = BeginM <$> satisfyMaybe (\case
93+
progressCreate = ProgressCreate . view L.params <$> message SWindowWorkDoneProgressCreate
94+
progressBegin = ProgressBegin <$> satisfyMaybe (\case
9795
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Begin x))) -> Just (ProgressParams t x)
9896
_ -> Nothing)
99-
progress = ProgressM <$> satisfyMaybe (\case
97+
progressReport = ProgressReport <$> satisfyMaybe (\case
10098
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Report x))) -> Just (ProgressParams t x)
10199
_ -> Nothing)
102-
end = EndM <$> satisfyMaybe (\case
100+
progressEnd = ProgressEnd <$> satisfyMaybe (\case
103101
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (End x))) -> Just (ProgressParams t x)
104102
_ -> Nothing)
105-
expectElem a as = a `elem` as @? "Unexpected " ++ show a
103+
104+
interestingMessage :: Session a -> Session (InterestingMessage a)
105+
interestingMessage theMessage =
106+
fmap InterestingMessage theMessage <|> fmap ProgressMessage progressMessage
107+
108+
expectProgressMessagesTill :: Session a -> [Text] -> [ProgressToken] -> Session (a, [ProgressToken])
109+
expectProgressMessagesTill stopMessage expectedTitles activeProgressTokens = do
110+
message <- skipManyTill anyMessage (interestingMessage stopMessage)
111+
case message of
112+
InterestingMessage a -> do
113+
liftIO $ null expectedTitles @? "Expected titles not empty " <> show expectedTitles
114+
pure (a, activeProgressTokens)
115+
ProgressMessage progressMessage ->
116+
updateExpectProgressStateAndRecurseWith
117+
(expectProgressMessagesTill stopMessage)
118+
progressMessage
119+
expectedTitles
120+
activeProgressTokens
121+
122+
{- | Test that the server is correctly producing a sequence of progress related
123+
messages. Each create must be pair with a corresponding begin and end,
124+
optionally with some progress in between. Tokens must match. The begin
125+
messages have titles describing the work that is in-progress, we check that
126+
the titles we see are those we expect.
127+
-}
128+
expectProgressMessages :: [Text] -> [ProgressToken] -> Session ()
129+
expectProgressMessages [] [] = pure ()
130+
expectProgressMessages expectedTitles activeProgressTokens = do
131+
message <- skipManyTill anyMessage progressMessage
132+
updateExpectProgressStateAndRecurseWith expectProgressMessages message expectedTitles activeProgressTokens
133+
134+
updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> Session a)
135+
-> ProgressMessage
136+
-> [Text]
137+
-> [ProgressToken]
138+
-> Session a
139+
updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles activeProgressTokens = do
140+
case progressMessage of
141+
ProgressCreate params -> do
142+
f expectedTitles (getToken params : activeProgressTokens)
143+
ProgressBegin params -> do
144+
liftIO $ getToken params `expectedIn` activeProgressTokens
145+
f (delete (getTitle params) expectedTitles) activeProgressTokens
146+
ProgressReport params -> do
147+
liftIO $ getToken params `expectedIn` activeProgressTokens
148+
f expectedTitles activeProgressTokens
149+
ProgressEnd params -> do
150+
liftIO $ getToken params `expectedIn` activeProgressTokens
151+
f expectedTitles (delete (getToken params) activeProgressTokens)
152+
153+
getTitle :: (L.HasValue s a1, L.HasTitle a1 a2) => s -> a2
154+
getTitle msg = msg ^. L.value . L.title
155+
156+
getToken :: L.HasToken s a => s -> a
157+
getToken msg = msg ^. L.token
158+
159+
expectedIn :: (Foldable t, Eq a, Show a) => a -> t a -> Assertion
160+
expectedIn a as = a `elem` as @? "Unexpected " ++ show a
161+
162+
getResponseResult :: ResponseMessage m -> ResponseResult m
163+
getResponseResult rsp =
164+
case rsp ^. L.result of
165+
Right x -> x
166+
Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err

0 commit comments

Comments
 (0)