From a058943aab9063c3eb354d9ed955ae52076c3c44 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Fri, 25 Dec 2020 13:49:53 -0600 Subject: [PATCH 1/4] 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. --- test/functional/Progress.hs | 170 +++++++++++++++--------------------- 1 file changed, 72 insertions(+), 98 deletions(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index a3a766893e..5957f75580 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -1,118 +1,92 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Progress (tests) where import Control.Applicative.Combinators -import Control.Lens +import Control.Lens hiding ((.=)) import Control.Monad.IO.Class -import Data.Aeson -import Data.Default -import Ide.Plugin.Config import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Messages -- TODO: Move this into haskell-lsp-types import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types.Lens as L import Language.Haskell.LSP.Types.Capabilities import Test.Hls.Util import Test.Tasty -import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit +import Data.Text (Text) +import Data.Aeson (encode, decode, object, Value, (.=)) +import Data.Maybe (fromJust) +import Data.List (delete) tests :: TestTree tests = testGroup "window/workDoneProgress" [ - ignoreTestBecause "Broken" $ testCase "sends indefinite progress notifications" $ - -- Testing that ghc-mod sends progress notifications + testCase "sends indefinite progress notifications" $ runSession hlsCommand progressCaps "test/testdata" $ do - doc <- openDoc "ApplyRefact2.hs" "haskell" - - skipMany loggingNotification - - createRequest <- message :: Session WorkDoneProgressCreateRequest - liftIO $ do - createRequest ^. L.params @?= WorkDoneProgressCreateParams (ProgressNumericToken 0) - - startNotification <- message :: Session WorkDoneProgressBeginNotification - liftIO $ do - -- Expect a stack cradle, since the given `hie.yaml` is expected - -- to contain a multi-stack cradle. - startNotification ^. L.params . L.value . L.title @?= "Initializing Stack project" - startNotification ^. L.params . L.token @?= (ProgressNumericToken 0) - - reportNotification <- message :: Session WorkDoneProgressReportNotification - liftIO $ do - reportNotification ^. L.params . L.value . L.message @?= Just "Main" - reportNotification ^. L.params . L.token @?= (ProgressNumericToken 0) - - -- may produce diagnostics - skipMany publishDiagnosticsNotification - - doneNotification <- message :: Session WorkDoneProgressEndNotification - liftIO $ doneNotification ^. L.params . L.token @?= (ProgressNumericToken 0) - - -- Initial hlint notifications - _ <- publishDiagnosticsNotification - - -- Test incrementing ids - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) - - createRequest' <- skipManyTill loggingNotification (message :: Session WorkDoneProgressCreateRequest) - liftIO $ do - createRequest' ^. L.params @?= WorkDoneProgressCreateParams (ProgressNumericToken 1) - - startNotification' <- message :: Session WorkDoneProgressBeginNotification - liftIO $ do - startNotification' ^. L.params . L.value . L.title @?= "loading" - startNotification' ^. L.params . L.token @?= (ProgressNumericToken 1) - - reportNotification' <- message :: Session WorkDoneProgressReportNotification - liftIO $ do - reportNotification' ^. L.params . L.value . L.message @?= Just "Main" - reportNotification' ^. L.params . L.token @?= (ProgressNumericToken 1) - - doneNotification' <- message :: Session WorkDoneProgressEndNotification - liftIO $ doneNotification' ^. L.params . L.token @?= (ProgressNumericToken 1) - - -- Initial hlint notifications - _ <- publishDiagnosticsNotification - return () - - , ignoreTestBecause "Broken" $ testCase "sends indefinite progress notifications with liquid" $ - -- Testing that Liquid Haskell sends progress notifications - runSession hlsCommand progressCaps "test/testdata" $ do - doc <- openDoc "liquid/Evens.hs" "haskell" - - skipMany loggingNotification - - _ <- message :: Session WorkDoneProgressCreateRequest - _ <- message :: Session WorkDoneProgressBeginNotification - _ <- message :: Session WorkDoneProgressReportNotification - _ <- message :: Session WorkDoneProgressEndNotification - - -- the hie-bios diagnostics - _ <- skipManyTill loggingNotification publishDiagnosticsNotification - - -- Enable liquid haskell plugin - let config = def { liquidOn = True, hlintOn = False } - sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) - - -- Test liquid - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) - - -- hlint notifications - -- TODO: potential race between typechecking, e.g. context intialisation - -- TODO: and disabling hlint notifications - -- _ <- skipManyTill loggingNotification publishDiagnosticsNotification - - let startPred (NotWorkDoneProgressBegin m) = - m ^. L.params . L.value . L.title == "Running Liquid Haskell on Evens.hs" - startPred _ = False - - let donePred (NotWorkDoneProgressEnd _) = True - donePred _ = False - - _ <- skipManyTill anyMessage $ between (satisfy startPred) (satisfy donePred) $ - many (satisfy (\x -> not (startPred x || donePred x))) - return () + _ <- openDoc "hlint/ApplyRefact2.hs" "haskell" + expectProgressReports ["Setting up hlint (for hlint/ApplyRefact2.hs)", "Processing"] + , testCase "eval plugin sends progress reports" $ + runSession hlsCommand progressCaps "test/testdata/eval" $ do + doc <- openDoc "T1.hs" "haskell" + expectProgressReports ["Setting up eval (for T1.hs)", "Processing"] + [evalLens] <- getCodeLenses doc + let cmd = evalLens ^?! L.command . _Just + _ <- sendRequest WorkspaceExecuteCommand $ ExecuteCommandParams (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) Nothing + expectProgressReports ["Eval"] + , testCase "ormolu plugin sends progress notifications" $ do + runSession hlsCommand progressCaps "test/testdata" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + doc <- openDoc "Format.hs" "haskell" + expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] + _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing + expectProgressReports ["Formatting Format.hs"] + , testCase "fourmolu plugin sends progress notifications" $ do + runSession hlsCommand progressCaps "test/testdata" $ do + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) + doc <- openDoc "Format.hs" "haskell" + expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] + _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing + expectProgressReports ["Formatting Format.hs"] ] +formatLspConfig :: Value -> Value +formatLspConfig provider = object [ "haskell" .= object ["formattingProvider" .= (provider :: Value)] ] + progressCaps :: ClientCapabilities progressCaps = fullCaps { _window = Just (WindowClientCapabilities (Just True)) } + +data CollectedProgressNotification = + CreateM WorkDoneProgressCreateRequest + | BeginM WorkDoneProgressBeginNotification + | ProgressM WorkDoneProgressReportNotification + | EndM WorkDoneProgressEndNotification + +-- | 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 = expectProgressReports' [] + 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 $ title msg `expectElem` expectedTitles + 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.params ^. L.value ^. L.title + token msg = msg ^. L.params ^. L.token + create = CreateM <$> message + begin = BeginM <$> message + progress = ProgressM <$> message + end = EndM <$> message + expectElem a as = a `elem` as @? "Unexpected " ++ show a From 03239ee51b1bcd08ca213e46b2135046b791b6fc Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Fri, 25 Dec 2020 15:25:11 -0600 Subject: [PATCH 2/4] "Eval" |-> "Evaluating". --- test/functional/Progress.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 5957f75580..0e264ee307 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -31,7 +31,7 @@ tests = testGroup "window/workDoneProgress" [ [evalLens] <- getCodeLenses doc let cmd = evalLens ^?! L.command . _Just _ <- sendRequest WorkspaceExecuteCommand $ ExecuteCommandParams (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) Nothing - expectProgressReports ["Eval"] + expectProgressReports ["Evaluating"] , testCase "ormolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata" $ do sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) From bd460e787432e6c1202bb05dfab4e8b9eb3ac2fb Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Fri, 25 Dec 2020 15:36:34 -0600 Subject: [PATCH 3/4] Restore delete liquid Haskell related test. --- test/functional/Progress.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 0e264ee307..331bc34fbc 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -6,15 +6,18 @@ module Progress (tests) where import Control.Applicative.Combinators import Control.Lens hiding ((.=)) import Control.Monad.IO.Class +import Data.Default +import Ide.Plugin.Config import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types.Lens as L import Language.Haskell.LSP.Types.Capabilities import Test.Hls.Util import Test.Tasty +import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit import Data.Text (Text) -import Data.Aeson (encode, decode, object, Value, (.=)) +import Data.Aeson (encode, decode, object, toJSON, Value, (.=)) import Data.Maybe (fromJust) import Data.List (delete) @@ -46,6 +49,14 @@ tests = testGroup "window/workDoneProgress" [ expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] _ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing expectProgressReports ["Formatting Format.hs"] + , ignoreTestBecause "no liquid Haskell support" $ + testCase "liquid haskell plugin sends progress notifications" $ do + runSession hlsCommand progressCaps "test/testdata" $ do + doc <- openDoc "liquid/Evens.hs" "haskell" + let config = def { liquidOn = True, hlintOn = False } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) + expectProgressReports ["Running Liquid Haskell on Evens.hs"] ] formatLspConfig :: Value -> Value From ba7ee5dccf666eed22ca7e3476771f60d837aeda Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Fri, 25 Dec 2020 17:01:21 -0600 Subject: [PATCH 4/4] Fix path on Windows. --- test/functional/Progress.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 331bc34fbc..32abd30c91 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -6,27 +6,29 @@ module Progress (tests) where import Control.Applicative.Combinators import Control.Lens hiding ((.=)) import Control.Monad.IO.Class +import Data.Aeson (encode, decode, object, toJSON, Value, (.=)) import Data.Default +import Data.Maybe (fromJust) +import Data.List (delete) +import Data.Text (Text, pack) import Ide.Plugin.Config import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types.Lens as L import Language.Haskell.LSP.Types.Capabilities +import System.FilePath (()) import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Data.Text (Text) -import Data.Aeson (encode, decode, object, toJSON, Value, (.=)) -import Data.Maybe (fromJust) -import Data.List (delete) tests :: TestTree tests = testGroup "window/workDoneProgress" [ testCase "sends indefinite progress notifications" $ runSession hlsCommand progressCaps "test/testdata" $ do - _ <- openDoc "hlint/ApplyRefact2.hs" "haskell" - expectProgressReports ["Setting up hlint (for hlint/ApplyRefact2.hs)", "Processing"] + let path = "hlint" "ApplyRefact2.hs" + _ <- openDoc path "haskell" + expectProgressReports [pack ("Setting up hlint (for " ++ path ++ ")"), "Processing"] , testCase "eval plugin sends progress reports" $ runSession hlsCommand progressCaps "test/testdata/eval" $ do doc <- openDoc "T1.hs" "haskell"