{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Progress (tests) where
import Control.Lens hiding ((.=))
import Data.Aeson (Value, decode, encode, object,
toJSON, (.=))
import Data.List (delete)
import Data.Maybe (fromJust)
import Data.Text (Text, pack)
import Ide.Plugin.Config
import Language.LSP.Types.Capabilities
import qualified Language.LSP.Types.Lens as L
import System.FilePath ((</>))
import Test.Hls
import Test.Hls.Command
import Test.Hls.Flags
tests :: TestTree
tests =
testGroup
"window/workDoneProgress"
[ testCase "sends indefinite progress notifications" $
runSession hlsCommand progressCaps "test/testdata" $ do
let path = "diagnostics" </> "Foo.hs"
_ <- openDoc path "haskell"
expectProgressReports [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"]
, 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"]
_ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
expectProgressReports ["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"]
_ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing 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}
sendConfigurationChanged (toJSON config)
sendNotification STextDocumentDidSave (DidSaveTextDocumentParams doc Nothing)
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 WorkDoneProgressCreateParams
| BeginM (ProgressParams WorkDoneProgressBeginParams)
| ProgressM (ProgressParams WorkDoneProgressReportParams)
| EndM (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
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
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Begin x))) -> Just (ProgressParams t x)
_ -> Nothing)
progress = ProgressM <$> satisfyMaybe (\case
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Report x))) -> Just (ProgressParams t x)
_ -> Nothing)
end = EndM <$> satisfyMaybe (\case
FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (End x))) -> Just (ProgressParams t x)
_ -> Nothing)
expectElem a as = a `elem` as @? "Unexpected " ++ show a