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 #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Progress (tests) where
|
module Progress (tests) where
|
||||||
|
|
||||||
import Control.Applicative.Combinators
|
import Control.Applicative.Combinators
|
||||||
import Control.Lens
|
import Control.Lens hiding ((.=))
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Data.Aeson
|
|
||||||
import Data.Default
|
|
||||||
import Ide.Plugin.Config
|
|
||||||
import Language.Haskell.LSP.Test
|
import Language.Haskell.LSP.Test
|
||||||
import Language.Haskell.LSP.Messages -- TODO: Move this into haskell-lsp-types
|
|
||||||
import Language.Haskell.LSP.Types
|
import Language.Haskell.LSP.Types
|
||||||
import qualified Language.Haskell.LSP.Types.Lens as L
|
import qualified Language.Haskell.LSP.Types.Lens as L
|
||||||
import Language.Haskell.LSP.Types.Capabilities
|
import Language.Haskell.LSP.Types.Capabilities
|
||||||
import Test.Hls.Util
|
import Test.Hls.Util
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
|
|
||||||
import Test.Tasty.HUnit
|
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 :: TestTree
|
||||||
tests = testGroup "window/workDoneProgress" [
|
tests = testGroup "window/workDoneProgress" [
|
||||||
ignoreTestBecause "Broken" $ testCase "sends indefinite progress notifications" $
|
testCase "sends indefinite progress notifications" $
|
||||||
-- Testing that ghc-mod sends progress notifications
|
|
||||||
runSession hlsCommand progressCaps "test/testdata" $ do
|
runSession hlsCommand progressCaps "test/testdata" $ do
|
||||||
doc <- openDoc "ApplyRefact2.hs" "haskell"
|
_ <- openDoc "hlint/ApplyRefact2.hs" "haskell"
|
||||||
|
expectProgressReports ["Setting up hlint (for hlint/ApplyRefact2.hs)", "Processing"]
|
||||||
skipMany loggingNotification
|
, testCase "eval plugin sends progress reports" $
|
||||||
|
runSession hlsCommand progressCaps "test/testdata/eval" $ do
|
||||||
createRequest <- message :: Session WorkDoneProgressCreateRequest
|
doc <- openDoc "T1.hs" "haskell"
|
||||||
liftIO $ do
|
expectProgressReports ["Setting up eval (for T1.hs)", "Processing"]
|
||||||
createRequest ^. L.params @?= WorkDoneProgressCreateParams (ProgressNumericToken 0)
|
[evalLens] <- getCodeLenses doc
|
||||||
|
let cmd = evalLens ^?! L.command . _Just
|
||||||
startNotification <- message :: Session WorkDoneProgressBeginNotification
|
_ <- sendRequest WorkspaceExecuteCommand $ ExecuteCommandParams (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) Nothing
|
||||||
liftIO $ do
|
expectProgressReports ["Eval"]
|
||||||
-- Expect a stack cradle, since the given `hie.yaml` is expected
|
, testCase "ormolu plugin sends progress notifications" $ do
|
||||||
-- to contain a multi-stack cradle.
|
runSession hlsCommand progressCaps "test/testdata" $ do
|
||||||
startNotification ^. L.params . L.value . L.title @?= "Initializing Stack project"
|
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu"))
|
||||||
startNotification ^. L.params . L.token @?= (ProgressNumericToken 0)
|
doc <- openDoc "Format.hs" "haskell"
|
||||||
|
expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
|
||||||
reportNotification <- message :: Session WorkDoneProgressReportNotification
|
_ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing
|
||||||
liftIO $ do
|
expectProgressReports ["Formatting Format.hs"]
|
||||||
reportNotification ^. L.params . L.value . L.message @?= Just "Main"
|
, testCase "fourmolu plugin sends progress notifications" $ do
|
||||||
reportNotification ^. L.params . L.token @?= (ProgressNumericToken 0)
|
runSession hlsCommand progressCaps "test/testdata" $ do
|
||||||
|
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu"))
|
||||||
-- may produce diagnostics
|
doc <- openDoc "Format.hs" "haskell"
|
||||||
skipMany publishDiagnosticsNotification
|
expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
|
||||||
|
_ <- sendRequest TextDocumentFormatting $ DocumentFormattingParams doc (FormattingOptions 2 True) Nothing
|
||||||
doneNotification <- message :: Session WorkDoneProgressEndNotification
|
expectProgressReports ["Formatting Format.hs"]
|
||||||
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 ()
|
|
||||||
]
|
]
|
||||||
|
|
||||||
|
formatLspConfig :: Value -> Value
|
||||||
|
formatLspConfig provider = object [ "haskell" .= object ["formattingProvider" .= (provider :: Value)] ]
|
||||||
|
|
||||||
progressCaps :: ClientCapabilities
|
progressCaps :: ClientCapabilities
|
||||||
progressCaps = fullCaps { _window = Just (WindowClientCapabilities (Just True)) }
|
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