Skip to content

Commit 9ac127e

Browse files
jneirajneira
authored
Merge pull request #698 from peterwicksstringfield/enable_progress_tests
Fix and enable progress message tests.
2 parents 38151a0 + ba7ee5d commit 9ac127e

File tree

1 file changed

+82
-95
lines changed

1 file changed

+82
-95
lines changed

‎test/functional/Progress.hs‎

Lines changed: 82 additions & 95 deletions
Original file line numberDiff line numberDiff line change
@@ -1,118 +1,105 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE FlexibleContexts #-}
13
{-# LANGUAGE OverloadedStrings #-}
24
module Progress (tests) where
35

46
import Control.Applicative.Combinators
5-
import Control.Lens
7+
import Control.Lens hiding ((.=))
68
import Control.Monad.IO.Class
7-
import Data.Aeson
9+
import Data.Aeson (encode, decode, object, toJSON, Value, (.=))
810
import Data.Default
11+
import Data.Maybe (fromJust)
12+
import Data.List (delete)
13+
import Data.Text (Text, pack)
914
import Ide.Plugin.Config
1015
import Language.Haskell.LSP.Test
11-
import Language.Haskell.LSP.Messages -- TODO: Move this into haskell-lsp-types
1216
import Language.Haskell.LSP.Types
1317
import qualified Language.Haskell.LSP.Types.Lens as L
1418
import Language.Haskell.LSP.Types.Capabilities
19+
import System.FilePath ((</>))
1520
import Test.Hls.Util
1621
import Test.Tasty
1722
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
1823
import Test.Tasty.HUnit
1924

2025
tests :: TestTree
2126
tests = testGroup "window/workDoneProgress" [
22-
ignoreTestBecause "Broken" $ testCase "sends indefinite progress notifications" $
23-
-- Testing that ghc-mod sends progress notifications
27+
testCase "sends indefinite progress notifications" $
2428
runSession hlsCommand progressCaps "test/testdata" $ do
25-
doc <- openDoc "ApplyRefact2.hs" "haskell"
26-
27-
skipMany loggingNotification
28-
29-
createRequest <- message :: Session WorkDoneProgressCreateRequest
30-
liftIO $ do
31-
createRequest ^. L.params @?= WorkDoneProgressCreateParams (ProgressNumericToken 0)
32-
33-
startNotification <- message :: Session WorkDoneProgressBeginNotification
34-
liftIO $ do
35-
-- Expect a stack cradle, since the given `hie.yaml` is expected
36-
-- to contain a multi-stack cradle.
37-
startNotification ^. L.params . L.value . L.title @?= "Initializing Stack project"
38-
startNotification ^. L.params . L.token @?= (ProgressNumericToken 0)
39-
40-
reportNotification <- message :: Session WorkDoneProgressReportNotification
41-
liftIO $ do
42-
reportNotification ^. L.params . L.value . L.message @?= Just "Main"
43-
reportNotification ^. L.params . L.token @?= (ProgressNumericToken 0)
44-
45-
-- may produce diagnostics
46-
skipMany publishDiagnosticsNotification
47-
48-
doneNotification <- message :: Session WorkDoneProgressEndNotification
49-
liftIO $ doneNotification ^. L.params . L.token @?= (ProgressNumericToken 0)
50-
51-
-- Initial hlint notifications
52-
_ <- publishDiagnosticsNotification
53-
54-
-- Test incrementing ids
55-
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
56-
57-
createRequest' <- skipManyTill loggingNotification (message :: Session WorkDoneProgressCreateRequest)
58-
liftIO $ do
59-
createRequest' ^. L.params @?= WorkDoneProgressCreateParams (ProgressNumericToken 1)
60-
61-
startNotification' <- message :: Session WorkDoneProgressBeginNotification
62-
liftIO $ do
63-
startNotification' ^. L.params . L.value . L.title @?= "loading"
64-
startNotification' ^. L.params . L.token @?= (ProgressNumericToken 1)
65-
66-
reportNotification' <- message :: Session WorkDoneProgressReportNotification
67-
liftIO $ do
68-
reportNotification' ^. L.params . L.value . L.message @?= Just "Main"
69-
reportNotification' ^. L.params . L.token @?= (ProgressNumericToken 1)
70-
71-
doneNotification' <- message :: Session WorkDoneProgressEndNotification
72-
liftIO $ doneNotification' ^. L.params . L.token @?= (ProgressNumericToken 1)
73-
74-
-- Initial hlint notifications
75-
_ <- publishDiagnosticsNotification
76-
return ()
77-
78-
, ignoreTestBecause "Broken" $ testCase "sends indefinite progress notifications with liquid" $
79-
-- Testing that Liquid Haskell sends progress notifications
80-
runSession hlsCommand progressCaps "test/testdata" $ do
81-
doc <- openDoc "liquid/Evens.hs" "haskell"
82-
83-
skipMany loggingNotification
84-
85-
_ <- message :: Session WorkDoneProgressCreateRequest
86-
_ <- message :: Session WorkDoneProgressBeginNotification
87-
_ <- message :: Session WorkDoneProgressReportNotification
88-
_ <- message :: Session WorkDoneProgressEndNotification
89-
90-
-- the hie-bios diagnostics
91-
_ <- skipManyTill loggingNotification publishDiagnosticsNotification
92-
93-
-- Enable liquid haskell plugin
94-
let config = def { liquidOn = True, hlintOn = False }
95-
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
96-
97-
-- Test liquid
98-
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
99-
100-
-- hlint notifications
101-
-- TODO: potential race between typechecking, e.g. context intialisation
102-
-- TODO: and disabling hlint notifications
103-
-- _ <- skipManyTill loggingNotification publishDiagnosticsNotification
104-
105-
let startPred (NotWorkDoneProgressBegin m) =
106-
m ^. L.params . L.value . L.title == "Running Liquid Haskell on Evens.hs"
107-
startPred _ = False
108-
109-
let donePred (NotWorkDoneProgressEnd _) = True
110-
donePred _ = False
111-
112-
_ <- skipManyTill anyMessage $ between (satisfy startPred) (satisfy donePred) $
113-
many (satisfy (\x -> not (startPred x || donePred x)))
114-
return ()
29+
let path = "hlint" </> "ApplyRefact2.hs"
30+
_ <- openDoc path "haskell"
31+
expectProgressReports [pack ("Setting up hlint (for " ++ path ++ ")"), "Processing"]
32+
, testCase "eval plugin sends progress reports" $
33+
runSession hlsCommand progressCaps "test/testdata/eval" $ do
34+
doc <- openDoc "T1.hs" "haskell"
35+
expectProgressReports ["Setting up eval (for T1.hs)", "Processing"]
36+
[evalLens] <- getCodeLenses doc
37+
let cmd = evalLens ^?! L.command . _Just
38+
_ <- sendRequest WorkspaceExecuteCommand $ ExecuteCommandParams (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) Nothing
39+
expectProgressReports ["Evaluating"]
40+
, testCase "ormolu plugin sends progress notifications" $ do
41+
runSession hlsCommand progressCaps "test/testdata" $ do
42+
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu"))
43+
doc <- openDoc "Format.hs" "haskell"
44+
expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
45+
_ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing
46+
expectProgressReports ["Formatting Format.hs"]
47+
, testCase "fourmolu plugin sends progress notifications" $ do
48+
runSession hlsCommand progressCaps "test/testdata" $ do
49+
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu"))
50+
doc <- openDoc "Format.hs" "haskell"
51+
expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
52+
_ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing
53+
expectProgressReports ["Formatting Format.hs"]
54+
, ignoreTestBecause "no liquid Haskell support" $
55+
testCase "liquid haskell plugin sends progress notifications" $ do
56+
runSession hlsCommand progressCaps "test/testdata" $ do
57+
doc <- openDoc "liquid/Evens.hs" "haskell"
58+
let config = def { liquidOn = True, hlintOn = False }
59+
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
60+
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
61+
expectProgressReports ["Running Liquid Haskell on Evens.hs"]
11562
]
11663

64+
formatLspConfig :: Value -> Value
65+
formatLspConfig provider = object [ "haskell" .= object ["formattingProvider" .= (provider :: Value)] ]
66+
11767
progressCaps :: ClientCapabilities
11868
progressCaps = fullCaps { _window = Just (WindowClientCapabilities (Just True)) }
69+
70+
data CollectedProgressNotification =
71+
CreateM WorkDoneProgressCreateRequest
72+
| BeginM WorkDoneProgressBeginNotification
73+
| ProgressM WorkDoneProgressReportNotification
74+
| EndM WorkDoneProgressEndNotification
75+
76+
-- | Test that the server is correctly producing a sequence of progress related
77+
-- messages. Each create must be pair with a corresponding begin and end,
78+
-- optionally with some progress in between. Tokens must match. The begin
79+
-- messages have titles describing the work that is in-progress, we check that
80+
-- the titles we see are those we expect.
81+
expectProgressReports :: [Text] -> Session ()
82+
expectProgressReports = expectProgressReports' []
83+
where expectProgressReports' [] [] = return ()
84+
expectProgressReports' tokens expectedTitles = do
85+
skipManyTill anyMessage (create <|> begin <|> progress <|> end)
86+
>>= \case
87+
CreateM msg ->
88+
expectProgressReports' (token msg : tokens) expectedTitles
89+
BeginM msg -> do
90+
liftIO $ title msg `expectElem` expectedTitles
91+
liftIO $ token msg `expectElem` tokens
92+
expectProgressReports' tokens (delete (title msg) expectedTitles)
93+
ProgressM msg -> do
94+
liftIO $ token msg `expectElem` tokens
95+
expectProgressReports' tokens expectedTitles
96+
EndM msg -> do
97+
liftIO $ token msg `expectElem` tokens
98+
expectProgressReports' (delete (token msg) tokens) expectedTitles
99+
title msg = msg ^. L.params ^. L.value ^. L.title
100+
token msg = msg ^. L.params ^. L.token
101+
create = CreateM <$> message
102+
begin = BeginM <$> message
103+
progress = ProgressM <$> message
104+
end = EndM <$> message
105+
expectElem a as = a `elem` as @? "Unexpected " ++ show a

0 commit comments

Comments
 (0)