diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index a3a766893e..32abd30c91 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -1,17 +1,22 @@ +{-# 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.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.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 System.FilePath (()) import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) @@ -19,100 +24,82 @@ import Test.Tasty.HUnit 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 () + 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" + 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 ["Evaluating"] + , 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"] + , 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 +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