Skip to content

Commit a058943

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 a058943

File tree

1 file changed

+72
-98
lines changed

1 file changed

+72
-98
lines changed

‎test/functional/Progress.hs

Lines changed: 72 additions & 98 deletions
Original file line numberDiff line numberDiff line change
@@ -1,118 +1,92 @@
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
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 ()
25+
_ <- openDoc "hlint/ApplyRefact2.hs" "haskell"
26+
expectProgressReports ["Setting up hlint (for hlint/ApplyRefact2.hs)", "Processing"]
27+
, testCase "eval plugin sends progress reports" $
28+
runSession hlsCommand progressCaps "test/testdata/eval" $ do
29+
doc <- openDoc "T1.hs" "haskell"
30+
expectProgressReports ["Setting up eval (for T1.hs)", "Processing"]
31+
[evalLens] <- getCodeLenses doc
32+
let cmd = evalLens ^?! L.command . _Just
33+
_ <- sendRequest WorkspaceExecuteCommand $ ExecuteCommandParams (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) Nothing
34+
expectProgressReports ["Eval"]
35+
, testCase "ormolu plugin sends progress notifications" $ do
36+
runSession hlsCommand progressCaps "test/testdata" $ do
37+
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu"))
38+
doc <- openDoc "Format.hs" "haskell"
39+
expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
40+
_ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing
41+
expectProgressReports ["Formatting Format.hs"]
42+
, testCase "fourmolu plugin sends progress notifications" $ do
43+
runSession hlsCommand progressCaps "test/testdata" $ do
44+
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu"))
45+
doc <- openDoc "Format.hs" "haskell"
46+
expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
47+
_ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing
48+
expectProgressReports ["Formatting Format.hs"]
11549
]
11650

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

0 commit comments

Comments
 (0)