Skip to content

Commit 9a4c9ac

Browse files
peterwicksstringfieldpeterwicksstringfield
committed
Fix and enable progress message tests.
Liquid Haskell is gone, delete the related code. Test the progress messages from some of our other plugins. Help HLS load the testfiles for the warnings are warnings test.
1 parent a43933a commit 9a4c9ac

File tree

1 file changed

+72
-97
lines changed

1 file changed

+72
-97
lines changed

‎test/functional/Progress.hs

Lines changed: 72 additions & 97 deletions
Original file line numberDiff line numberDiff line change
@@ -1,118 +1,93 @@
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
8-
import Data.Default
9-
import Ide.Plugin.Config
109
import Language.Haskell.LSP.Test
11-
import Language.Haskell.LSP.Messages -- TODO: Move this into haskell-lsp-types
1210
import Language.Haskell.LSP.Types
1311
import qualified Language.Haskell.LSP.Types.Lens as L
1412
import Language.Haskell.LSP.Types.Capabilities
1513
import Test.Hls.Util
1614
import Test.Tasty
17-
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
1815
import Test.Tasty.HUnit
16+
import Data.Text (Text)
17+
import Data.Aeson (encode, decode, object, Value, (.=))
18+
import Data.Maybe (fromJust)
19+
import Data.List (delete)
1920

2021
tests :: TestTree
2122
tests = testGroup "window/workDoneProgress" [
22-
ignoreTestBecause "Broken" $ testCase "sends indefinite progress notifications" $
23-
-- Testing that ghc-mod sends progress notifications
23+
testCase "sends indefinite progress notifications" $
2424
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
25+
doc <- openDoc "hlint/ApplyRefact2.hs" "haskell"
26+
expectProgressReports ["Setting up hlint (for hlint/ApplyRefact2.hs)", "Processing"]
5527
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 ()
28+
, testCase "eval plugin sends progress reports" $
29+
runSession hlsCommand progressCaps "test/testdata/eval" $ do
30+
doc <- openDoc "T1.hs" "haskell"
31+
expectProgressReports ["Setting up eval (for T1.hs)", "Processing"]
32+
[evalLens] <- getCodeLenses doc
33+
let cmd = evalLens ^?! L.command . _Just
34+
_ <- sendRequest WorkspaceExecuteCommand $ ExecuteCommandParams (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) Nothing
35+
expectProgressReports ["Eval"]
36+
, testCase "ormolu plugin sends progress notifications" $ do
37+
runSession hlsCommand progressCaps "test/testdata" $ do
38+
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu"))
39+
doc <- openDoc "Format.hs" "haskell"
40+
expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
41+
_ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing
42+
expectProgressReports ["Formatting Format.hs"]
43+
, testCase "fourmolu plugin sends progress notifications" $ do
44+
runSession hlsCommand progressCaps "test/testdata" $ do
45+
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu"))
46+
doc <- openDoc "Format.hs" "haskell"
47+
expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
48+
_ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing
49+
expectProgressReports ["Formatting Format.hs"]
11550
]
11651

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

0 commit comments

Comments
 (0)