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.2.0.0 +version: 1.3.0.0 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -41,11 +41,9 @@ , directory , extra , filepath - , ghcide ^>=1.6 + , ghcide ^>=1.6 || ^>=1.7 , hls-graph - , hls-plugin-api ^>=1.3 - , hspec <2.8 - , hspec-core + , hls-plugin-api ^>=1.3 || ^>=1.4 , lens , lsp ^>=1.4 , lsp-test ^>=0.14 diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -48,18 +48,28 @@ import Data.ByteString.Lazy (ByteString) import Data.Default (def) import Data.Maybe (fromMaybe) +import qualified Data.Map as M 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 Development.IDE (IdeState) +import Development.IDE.Main hiding (Log) import qualified Development.IDE.Main as Ghcide +import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) +import qualified Development.IDE.Plugin.Test as Test +import Development.IDE.Types.Logger (Logger (Logger), + Pretty (pretty), + Priority (Debug), + Recorder (Recorder, logger_), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + makeDefaultStderrRecorder) import Development.IDE.Types.Options import GHC.IO.Handle -import Ide.Plugin.Config (Config, formattingProvider) +import GHC.Stack (emptyCallStack) +import Ide.Plugin.Config (Config, formattingProvider, PluginConfig, plugins) import Ide.PluginUtils (idePluginsToPluginDesc, pluginDescToIdePlugins) import Ide.Types @@ -69,6 +79,7 @@ SemanticTokenRelative (length), SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities (ClientCapabilities) +import Prelude hiding (log) import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Environment (lookupEnv) @@ -83,6 +94,12 @@ import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun +newtype Log = LogIDEMain IDEMain.Log + +instance Pretty Log where + pretty = \case + LogIDEMain log -> pretty log + -- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes defaultTestRunner :: TestTree -> IO () defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000) @@ -115,6 +132,7 @@ goldenWithHaskellDocFormatter :: PluginDescriptor IdeState -> String + -> PluginConfig -> TestName -> FilePath -> FilePath @@ -122,9 +140,9 @@ -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithHaskellDocFormatter plugin formatter title testDataDir path desc ext act = +goldenWithHaskellDocFormatter plugin formatter conf title testDataDir path desc ext act = goldenGitDiff title (testDataDir path <.> desc <.> ext) - $ runSessionWithServerFormatter plugin formatter testDataDir + $ runSessionWithServerFormatter plugin formatter conf testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" @@ -135,12 +153,15 @@ runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps -runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> FilePath -> Session a -> IO a -runSessionWithServerFormatter plugin formatter = +runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a +runSessionWithServerFormatter plugin formatter conf = runSessionWithServer' [plugin] - def {formattingProvider = T.pack formatter} def + { formattingProvider = T.pack formatter + , plugins = M.singleton (T.pack formatter) conf + } + def fullCaps -- | Restore cwd after running an action @@ -152,6 +173,7 @@ lock :: Lock lock = unsafePerformIO newLock + -- | Host a server, and run a test session on it -- Note: cwd will be shifted into @root@ in @Session a@ runSessionWithServer' :: @@ -165,31 +187,49 @@ FilePath -> Session a -> IO a -runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do +runSessionWithServer' plugins 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 + docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug + + logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" + + let + docWithFilteredPriorityRecorder@Recorder{ logger_ } = + if logStdErr == "0" then mempty + else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder + + -- exists until old logging style is phased out + logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) + + recorder = cmapWithPrio pretty docWithFilteredPriorityRecorder + + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger + + hlsPlugins = + idePluginsToPluginDesc argsHlsPlugins + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ++ plugins + ideOptions = \config ghcSession -> + let defIdeOptions = argsIdeOptions config ghcSession + in defIdeOptions + { optTesting = IdeTesting True + , optCheckProject = pure False + } + server <- async $ Ghcide.defaultMain - testing - { argsHandleIn = pure inR, - argsHandleOut = pure outW, - argsDefaultHlsConfig = conf, - argsLogger = logger, - argsIdeOptions = \config sessionLoader -> - let ideOptions = (argsIdeOptions def config sessionLoader) - {optTesting = IdeTesting True - ,optCheckProject = pure False - } - in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}}, - argsHlsPlugins = pluginDescToIdePlugins $ plugin ++ idePluginsToPluginDesc (argsHlsPlugins testing) - } + (cmapWithPrio LogIDEMain recorder) + arguments + { argsHandleIn = pure inR + , argsHandleOut = pure outW + , argsDefaultHlsConfig = conf + , argsLogger = argsLogger + , argsIdeOptions = ideOptions + , argsHlsPlugins = pluginDescToIdePlugins hlsPlugins } + x <- runSessionWithHandles inW outR sconf caps root s hClose inW timeout 3 (wait server) >>= \case 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 @@ -18,7 +18,7 @@ , flushStackEnvironment , fromAction , fromCommand - , getHspecFormattedConfig + , getCompletionByLabel , ghcVersion, GhcVersion(..) , hostOS, OS(..) , matchesCurrentEnv, EnvSpec(..) @@ -49,9 +49,7 @@ import qualified Data.Aeson as A import Data.Bool (bool) import Data.Default -import Data.List (intercalate) import Data.List.Extra (find) -import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE (GhcVersion(..), ghcVersion) @@ -65,15 +63,11 @@ import System.IO.Temp import System.Info.Extra (isMac, isWindows) import System.Time.Extra (Seconds, sleep) -import Test.Hspec.Core.Formatters hiding (Seconds) -import Test.Hspec.Runner import Test.Tasty (TestTree) import Test.Tasty.ExpectedFailure (expectFailBecause, ignoreTestBecause) import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) -import Text.Blaze.Internal hiding (null) -import Text.Blaze.Renderer.String (renderMarkup) noLiteralCaps :: C.ClientCapabilities noLiteralCaps = def { C._textDocument = Just textDocumentCaps } @@ -168,88 +162,6 @@ -- --------------------------------------------------------------------- -getHspecFormattedConfig :: String -> IO Config -getHspecFormattedConfig name = do - -- https://circleci.com/docs/2.0/env-vars/#built-in-environment-variables - isCI <- isJust <$> lookupEnv "CI" - - -- Only use the xml formatter on CI since it hides console output - if isCI - then do - let subdir = "test-results" name - createDirectoryIfMissing True subdir - - return $ defaultConfig { configFormatter = Just xmlFormatter - , configOutputFile = Right $ subdir "results.xml" - } - else return defaultConfig - --- | A Hspec formatter for CircleCI. --- Originally from https://github.com/LeastAuthority/hspec-jenkins -xmlFormatter :: Formatter -xmlFormatter = silent { - headerFormatter = do - writeLine "" - writeLine "" - , exampleSucceeded - , exampleFailed - , examplePending - , footerFormatter = writeLine "" - } - where - -#if MIN_VERSION_hspec(2,5,0) - exampleSucceeded path _ = -#else - exampleSucceeded path = -#endif - writeLine $ renderMarkup $ testcase path "" - -#if MIN_VERSION_hspec(2,5,0) - exampleFailed path _ err = -#else - exampleFailed path (Left err) = - writeLine $ renderMarkup $ testcase path $ - failure ! message (show err) $ "" - exampleFailed path (Right err) = -#endif - writeLine $ renderMarkup $ testcase path $ - failure ! message (reasonAsString err) $ "" - -#if MIN_VERSION_hspec(2,5,0) - examplePending path _ reason = -#else - examplePending path reason = -#endif - writeLine $ renderMarkup $ testcase path $ - case reason of - Just desc -> skipped ! message desc $ "" - Nothing -> skipped "" - - failure, skipped :: Markup -> Markup - failure = customParent "failure" - skipped = customParent "skipped" - - name, className, message :: String -> Attribute - name = customAttribute "name" . stringValue - className = customAttribute "classname" . stringValue - message = customAttribute "message" . stringValue - - testcase :: Path -> Markup -> Markup - testcase (xs,x) = customParent "testcase" ! name x ! className (intercalate "." xs) - - reasonAsString :: FailureReason -> String - reasonAsString NoReason = "no reason given" - reasonAsString (Reason x) = x - reasonAsString (ExpectedButGot Nothing expected got) = "Expected " ++ expected ++ " but got " ++ got - reasonAsString (ExpectedButGot (Just src) expected got) = src ++ " expected " ++ expected ++ " but got " ++ got -#if MIN_VERSION_hspec(2,5,0) - reasonAsString (Error Nothing err ) = show err - reasonAsString (Error (Just s) err) = s ++ show err -#endif - --- --------------------------------------------------------------------- - flushStackEnvironment :: IO () flushStackEnvironment = do -- We need to clear these environment variables to prevent @@ -447,3 +359,12 @@ fp <- canonicalizePath file return (filePathToUri fp, l, c)) actual' @?= expected' + +-- --------------------------------------------------------------------- +getCompletionByLabel :: MonadIO m => T.Text -> [CompletionItem] -> m CompletionItem +getCompletionByLabel desiredLabel compls = + case find (\c -> c ^. L.label == desiredLabel) compls of + Just c -> pure c + Nothing -> liftIO . assertFailure $ + "Completion with label " <> show desiredLabel + <> " not found in " <> show (fmap (^. L.label) compls)