diff --git a/hls-test-utils.cabal b/hls-test-utils.cabal --- a/hls-test-utils.cabal +++ b/hls-test-utils.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-test-utils -version: 1.1.0.0 +version: 1.1.0.1 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -41,7 +41,7 @@ , directory , extra , filepath - , ghcide ^>=1.4 + , ghcide ^>=1.4 || ^>=1.5 , hls-graph , hls-plugin-api ^>=1.2 , hspec <2.8 diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -19,48 +21,57 @@ runSessionWithServerFormatter, runSessionWithServer', waitForProgressDone, + waitForAllProgressDone, PluginDescriptor, IdeState, - ) + waitForBuildQueue, + waitForTypecheck, + waitForAction, + sendConfigurationChanged, + getLastBuildKeys) where import Control.Applicative.Combinators -import Control.Concurrent.Async (async, cancel, wait) +import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Base -import Control.Monad (unless) +import Control.Monad (unless, void) import Control.Monad.IO.Class -import Data.ByteString.Lazy (ByteString) -import Data.Default (def) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import Development.IDE (IdeState, hDuplicateTo', - noLogging) -import Development.IDE.Graph (ShakeOptions (shakeThreads)) +import Data.Aeson (Value (Null), toJSON) +import qualified Data.Aeson as A +import Data.ByteString.Lazy (ByteString) +import Data.Default (def) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Development.IDE (IdeState, noLogging) +import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main -import qualified Development.IDE.Main as Ghcide -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import qualified Development.IDE.Main as Ghcide +import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), + WaitForIdeRuleResult (ideResultSuccess)) import Development.IDE.Types.Options import GHC.IO.Handle -import Ide.Plugin.Config (Config, formattingProvider) -import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Plugin.Config (Config, formattingProvider) +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) import Ide.Types import Language.LSP.Test -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Capabilities (ClientCapabilities) -import System.Directory (getCurrentDirectory, - setCurrentDirectory) +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start)) +import Language.LSP.Types.Capabilities (ClientCapabilities) +import System.Directory (getCurrentDirectory, + setCurrentDirectory) +import System.Environment (lookupEnv) import System.FilePath -import System.IO.Extra -import System.IO.Unsafe (unsafePerformIO) -import System.Process.Extra (createPipe) +import System.IO.Unsafe (unsafePerformIO) +import System.Process.Extra (createPipe) import System.Time.Extra import Test.Hls.Util -import Test.Tasty hiding (Timeout) +import Test.Tasty hiding (Timeout) import Test.Tasty.ExpectedFailure import Test.Tasty.Golden import Test.Tasty.HUnit @@ -91,6 +102,7 @@ $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue act doc documentContents doc @@ -110,6 +122,7 @@ $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue act doc documentContents doc @@ -124,18 +137,6 @@ def fullCaps --- | Run an action, with stderr silenced -silenceStderr :: IO a -> IO a -silenceStderr action = withTempFile $ \temp -> - bracket (openFile temp ReadWriteMode) hClose $ \h -> do - old <- hDuplicate stderr - buf <- hGetBuffering stderr - h `hDuplicateTo'` stderr - action `finally` do - old `hDuplicateTo'` stderr - hSetBuffering stderr buf - hClose old - -- | Restore cwd after running an action keepCurrentDirectory :: IO a -> IO a keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const @@ -158,21 +159,30 @@ FilePath -> Session a -> IO a -runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ silenceStderr $ do +runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do (inR, inW) <- createPipe (outR, outW) <- createPipe + let logger = do + logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" + if logStdErr == "0" + then return noLogging + else argsLogger testing + server <- async $ Ghcide.defaultMain - def + testing { argsHandleIn = pure inR, argsHandleOut = pure outW, argsDefaultHlsConfig = conf, - argsLogger = pure noLogging, + argsLogger = logger, argsIdeOptions = \config sessionLoader -> - let ideOptions = (argsIdeOptions def config sessionLoader) {optTesting = IdeTesting True} + let ideOptions = (argsIdeOptions def config sessionLoader) + {optTesting = IdeTesting True + ,optCheckProject = pure False + } in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}}, - argsHlsPlugins = pluginDescToIdePlugins $ plugin ++ Ghcide.descriptors + argsHlsPlugins = pluginDescToIdePlugins $ plugin ++ idePluginsToPluginDesc (argsHlsPlugins testing) } x <- runSessionWithHandles inW outR sconf caps root s hClose inW @@ -184,14 +194,56 @@ putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" pure x +-- | Wait for the next progress end step +waitForProgressDone :: Session () +waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + _ -> Nothing + -- | Wait for all progress to be done -- Needs at least one progress done notification to return -waitForProgressDone :: Session () -waitForProgressDone = loop +waitForAllProgressDone :: Session () +waitForAllProgressDone = loop where loop = do - () <- skipManyTill anyMessage $ satisfyMaybe $ \case + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop + +-- | Wait for the build queue to be empty +waitForBuildQueue :: Session Seconds +waitForBuildQueue = do + let m = SCustomMethod "test" + waitId <- sendRequest m (toJSON WaitForShakeQueue) + (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId + case resp of + ResponseMessage{_result=Right Null} -> return td + -- assume a ghcide binary lacking the WaitForShakeQueue method + _ -> return 0 + +callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) +callTestPlugin cmd = do + let cm = SCustomMethod "test" + waitId <- sendRequest cm (A.toJSON cmd) + ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + return $ do + e <- _result + case A.fromJSON e of + A.Error err -> Left $ ResponseError InternalError (T.pack err) Nothing + A.Success a -> pure a + +waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) +waitForAction key TextDocumentIdentifier{_uri} = + callTestPlugin (WaitForIdeRule key _uri) + +waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool) +waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid + +getLastBuildKeys :: Session (Either ResponseError [T.Text]) +getLastBuildKeys = callTestPlugin GetBuildKeysBuilt + +sendConfigurationChanged :: Value -> Session () +sendConfigurationChanged config = + sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config) diff --git a/src/Test/Hls/Util.hs b/src/Test/Hls/Util.hs --- a/src/Test/Hls/Util.hs +++ b/src/Test/Hls/Util.hs @@ -22,6 +22,7 @@ , ghcVersion, GhcVersion(..) , hostOS, OS(..) , matchesCurrentEnv, EnvSpec(..) + , noLiteralCaps , ignoreForGhcVersions , ignoreInEnv , inspectCodeAction @@ -73,6 +74,12 @@ (@?=)) import Text.Blaze.Internal hiding (null) import Text.Blaze.Renderer.String (renderMarkup) + +noLiteralCaps :: C.ClientCapabilities +noLiteralCaps = def { C._textDocument = Just textDocumentCaps } + where + textDocumentCaps = def { C._codeAction = Just codeActionCaps } + codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing codeActionSupportCaps :: C.ClientCapabilities codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps }