hls-test-utils 1.1.0.0 → 1.1.0.1
raw patch · 3 files changed
+107/−48 lines, 3 filesdep ~ghcide
Dependency ranges changed: ghcide
Files
- hls-test-utils.cabal +2/−2
- src/Test/Hls.hs +98/−46
- src/Test/Hls/Util.hs +7/−0
hls-test-utils.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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
src/Test/Hls.hs view
@@ -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)
src/Test/Hls/Util.hs view
@@ -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 }