forked from haskell/haskell-language-server
-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request haskell#698 from peterwicksstringfield/enable_prog…
…ress_tests Fix and enable progress message tests.
- Loading branch information
Showing
1 changed file
with
82 additions
and
95 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,118 +1,105 @@ | ||
| {-# 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) | ||
| 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 |