hls-test-utils 1.2.0.0 → 1.3.0.0
raw patch · 3 files changed
+87/−128 lines, 3 filesdep −hspecdep −hspec-coredep ~ghcidedep ~hls-plugin-apinew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies removed: hspec, hspec-core
Dependency ranges changed: ghcide, hls-plugin-api
API changes (from Hackage documentation)
- Test.Hls.Util: getHspecFormattedConfig :: String -> IO Config
+ Test.Hls: instance Prettyprinter.Internal.Pretty Test.Hls.Log
+ Test.Hls.Util: getCompletionByLabel :: MonadIO m => Text -> [CompletionItem] -> m CompletionItem
- Test.Hls: goldenWithHaskellDocFormatter :: PluginDescriptor IdeState -> String -> TestName -> FilePath -> FilePath -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
+ Test.Hls: goldenWithHaskellDocFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> TestName -> FilePath -> FilePath -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
- Test.Hls: runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> FilePath -> Session a -> IO a
+ Test.Hls: runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> PluginConfig -> FilePath -> Session a -> IO a
Files
- hls-test-utils.cabal +3/−5
- src/Test/Hls.hs +74/−34
- src/Test/Hls/Util.hs +10/−89
hls-test-utils.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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
src/Test/Hls.hs view
@@ -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
src/Test/Hls/Util.hs view
@@ -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 "<?xml version='1.0' encoding='UTF-8'?>"- writeLine "<testsuite>"- , exampleSucceeded- , exampleFailed- , examplePending- , footerFormatter = writeLine "</testsuite>"- }- 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)