mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-20 05:07:28 +03:00
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.
This commit is contained in:
Peter Wicks Stringfield
parent
a43933a4cc
commit
a058943aab
@ -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
|
||||
_ <- 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
|
||||
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 ()
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user