diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 0f6e4fe9fb..d131fc6175 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -4,15 +4,18 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} module Progress (tests) where +import Control.Exception (throw) import Control.Lens hiding ((.=)) import Data.Aeson (Value, decode, encode, object, (.=)) import Data.List (delete) import Data.Maybe (fromJust) import Data.Text (Text, pack) +import qualified Language.LSP.Types as LSP import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as L import System.FilePath (()) @@ -20,6 +23,7 @@ import Test.Hls import Test.Hls.Command import Test.Hls.Flags + tests :: TestTree tests = testGroup @@ -28,29 +32,42 @@ tests = runSession hlsCommand progressCaps "test/testdata" $ do let path = "diagnostics" "Foo.hs" _ <- openDoc path "haskell" - expectProgressReports [pack ("Setting up testdata (for " ++ path ++ ")"), "Processing", "Indexing"] + expectProgressMessages [pack ("Setting up testdata (for " ++ path ++ ")"), "Processing", "Indexing"] [] , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do - doc <- openDoc "T1.hs" "haskell" - expectProgressReports ["Setting up testdata (for T1.hs)", "Processing", "Indexing"] - [evalLens] <- getCodeLenses doc - let cmd = evalLens ^?! L.command . _Just - _ <- sendRequest SWorkspaceExecuteCommand $ ExecuteCommandParams Nothing (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) - expectProgressReports ["Evaluating"] + doc <- openDoc "T1.hs" "haskell" + lspId <- sendRequest STextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + + (codeLensResponse, activeProgressTokens) <- expectProgressMessagesTill + (responseForId STextDocumentCodeLens lspId) + ["Setting up testdata (for T1.hs)", "Processing", "Indexing"] + [] + + -- this is a test so exceptions result in fails + let LSP.List [evalLens] = getResponseResult codeLensResponse + let command = evalLens ^?! L.command . _Just + + _ <- sendRequest SWorkspaceExecuteCommand $ + ExecuteCommandParams + Nothing + (command ^. L.command) + (decode $ encode $ fromJust $ command ^. L.arguments) + + expectProgressMessages ["Evaluating"] activeProgressTokens , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendConfigurationChanged (formatLspConfig "ormolu") doc <- openDoc "Format.hs" "haskell" - expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] + expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] [] _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - expectProgressReports ["Formatting Format.hs"] + expectProgressMessages ["Formatting Format.hs"] [] , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendConfigurationChanged (formatLspConfig "fourmolu") doc <- openDoc "Format.hs" "haskell" - expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] + expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] [] _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - expectProgressReports ["Formatting Format.hs"] + expectProgressMessages ["Formatting Format.hs"] [] ] formatLspConfig :: Value -> Value @@ -59,47 +76,91 @@ formatLspConfig provider = object ["haskell" .= object ["formattingProvider" .= progressCaps :: ClientCapabilities progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Nothing Nothing)} -data CollectedProgressNotification - = CreateM WorkDoneProgressCreateParams - | BeginM (ProgressParams WorkDoneProgressBeginParams) - | ProgressM (ProgressParams WorkDoneProgressReportParams) - | EndM (ProgressParams WorkDoneProgressEndParams) +data ProgressMessage + = ProgressCreate WorkDoneProgressCreateParams + | ProgressBegin (ProgressParams WorkDoneProgressBeginParams) + | ProgressReport (ProgressParams WorkDoneProgressReportParams) + | ProgressEnd (ProgressParams WorkDoneProgressEndParams) -{- | 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 xs = expectProgressReports' [] xs +data InterestingMessage a + = InterestingMessage a + | ProgressMessage ProgressMessage + +progressMessage :: Session ProgressMessage +progressMessage = + progressCreate <|> progressBegin <|> progressReport <|> progressEnd 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 $ 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.value . L.title - token msg = msg ^. L.token - create = CreateM . view L.params <$> message SWindowWorkDoneProgressCreate - begin = BeginM <$> satisfyMaybe (\case + progressCreate = ProgressCreate . view L.params <$> message SWindowWorkDoneProgressCreate + progressBegin = ProgressBegin <$> satisfyMaybe (\case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Begin x))) -> Just (ProgressParams t x) _ -> Nothing) - progress = ProgressM <$> satisfyMaybe (\case + progressReport = ProgressReport <$> satisfyMaybe (\case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Report x))) -> Just (ProgressParams t x) _ -> Nothing) - end = EndM <$> satisfyMaybe (\case + progressEnd = ProgressEnd <$> satisfyMaybe (\case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (End x))) -> Just (ProgressParams t x) _ -> Nothing) - expectElem a as = a `elem` as @? "Unexpected " ++ show a + +interestingMessage :: Session a -> Session (InterestingMessage a) +interestingMessage theMessage = + fmap InterestingMessage theMessage <|> fmap ProgressMessage progressMessage + +expectProgressMessagesTill :: Session a -> [Text] -> [ProgressToken] -> Session (a, [ProgressToken]) +expectProgressMessagesTill stopMessage expectedTitles activeProgressTokens = do + message <- skipManyTill anyMessage (interestingMessage stopMessage) + case message of + InterestingMessage a -> do + liftIO $ null expectedTitles @? "Expected titles not empty " <> show expectedTitles + pure (a, activeProgressTokens) + ProgressMessage progressMessage -> + updateExpectProgressStateAndRecurseWith + (expectProgressMessagesTill stopMessage) + progressMessage + expectedTitles + activeProgressTokens + +{- | 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. +-} +expectProgressMessages :: [Text] -> [ProgressToken] -> Session () +expectProgressMessages [] [] = pure () +expectProgressMessages expectedTitles activeProgressTokens = do + message <- skipManyTill anyMessage progressMessage + updateExpectProgressStateAndRecurseWith expectProgressMessages message expectedTitles activeProgressTokens + +updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> Session a) + -> ProgressMessage + -> [Text] + -> [ProgressToken] + -> Session a +updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles activeProgressTokens = do + case progressMessage of + ProgressCreate params -> do + f expectedTitles (getToken params : activeProgressTokens) + ProgressBegin params -> do + liftIO $ getToken params `expectedIn` activeProgressTokens + f (delete (getTitle params) expectedTitles) activeProgressTokens + ProgressReport params -> do + liftIO $ getToken params `expectedIn` activeProgressTokens + f expectedTitles activeProgressTokens + ProgressEnd params -> do + liftIO $ getToken params `expectedIn` activeProgressTokens + f expectedTitles (delete (getToken params) activeProgressTokens) + +getTitle :: (L.HasValue s a1, L.HasTitle a1 a2) => s -> a2 +getTitle msg = msg ^. L.value . L.title + +getToken :: L.HasToken s a => s -> a +getToken msg = msg ^. L.token + +expectedIn :: (Foldable t, Eq a, Show a) => a -> t a -> Assertion +expectedIn a as = a `elem` as @? "Unexpected " ++ show a + +getResponseResult :: ResponseMessage m -> ResponseResult m +getResponseResult rsp = + case rsp ^. L.result of + Right x -> x + Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err