hls-test-utils 2.6.0.0 → 2.14.0.0
raw patch · 7 files changed
Files
- hls-test-utils.cabal +21/−13
- src/Development/IDE/Test.hs +264/−0
- src/Development/IDE/Test/Diagnostic.hs +87/−0
- src/Test/Hls.hs +517/−222
- src/Test/Hls/FileSystem.hs +53/−10
- src/Test/Hls/TestEnv.hs +104/−0
- src/Test/Hls/Util.hs +164/−50
hls-test-utils.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-test-utils-version: 2.6.0.0+version: 2.14.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>@@ -27,28 +27,32 @@ library exposed-modules: Test.Hls- Test.Hls.Util Test.Hls.FileSystem+ Test.Hls.TestEnv+ Test.Hls.Util+ Development.IDE.Test+ Development.IDE.Test.Diagnostic hs-source-dirs: src build-depends: , aeson , async , base >=4.12 && <5- , blaze-markup , bytestring , containers , data-default , directory , extra , filepath- , ghcide == 2.6.0.0- , hls-graph- , hls-plugin-api == 2.6.0.0+ , ghcide == 2.14.0.0+ , hls-plugin-api == 2.14.0.0 , lens- , lsp ^>=2.3- , lsp-test ^>=0.16- , lsp-types ^>=2.1+ , lsp+ , lsp-test ^>=0.18+ , lsp-types ^>=2.4+ , primitive+ , safe-exceptions+ , string-interpolate >= 0.3.1 , tasty , tasty-expected-failure , tasty-golden@@ -56,11 +60,15 @@ , tasty-rerun , temporary , text- , unordered-containers- , row-types- ghc-options: -Wall+ , text-rope + ghc-options:+ -Wall+ -Wunused-packages+ -Wno-name-shadowing+ -Wno-unticked-promoted-constructors+ if flag(pedantic) ghc-options: -Werror - default-language: Haskell2010+ default-language: GHC2021
+ src/Development/IDE/Test.hs view
@@ -0,0 +1,264 @@+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Development.IDE.Test+ ( Cursor+ , cursorPosition+ , requireDiagnostic+ , diagnostic+ , expectDiagnostics+ , expectDiagnosticsWithTags+ , ExpectedDiagnostic+ , ExpectedDiagnosticWithTag+ , expectNoMoreDiagnostics+ , expectMessages+ , expectCurrentDiagnostics+ , checkDiagnosticsForDoc+ , canonicalizeUri+ , standardizeQuotes+ , flushMessages+ , waitForAction+ , getInterfaceFilesDir+ , garbageCollectDirtyKeys+ , getFilesOfInterest+ , waitForTypecheck+ , waitForBuildQueue+ , getStoredKeys+ , waitForCustomMessage+ , waitForGC+ , configureCheckProject+ , isReferenceReady+ , referenceReady) where++import Control.Applicative.Combinators+import Control.Lens hiding (List)+import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson (toJSON)+import qualified Data.Aeson as A+import Data.Bifunctor (second)+import Data.Default+import qualified Data.Map.Strict as Map+import Data.Maybe (fromJust)+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text as T+import Development.IDE.Plugin.Test (TestRequest (..),+ WaitForIdeRuleResult,+ ideResultSuccess)+import Development.IDE.Test.Diagnostic+import GHC.TypeLits (symbolVal)+import Ide.Plugin.Config (CheckParents, checkProject)+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import Language.LSP.Test hiding (message)+import qualified Language.LSP.Test as LspTest+import System.Directory (canonicalizePath)+import System.FilePath (equalFilePath)+import System.Time.Extra+import Test.Tasty.HUnit++expectedDiagnosticWithNothing :: ExpectedDiagnostic -> ExpectedDiagnosticWithTag+expectedDiagnosticWithNothing (ds, c, t, code) = (ds, c, t, code, Nothing)++requireDiagnosticM+ :: (Foldable f, Show (f Diagnostic), HasCallStack)+ => f Diagnostic+ -> ExpectedDiagnosticWithTag+ -> Assertion+requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of+ Nothing -> pure ()+ Just err -> assertFailure err++-- |wait for @timeout@ seconds and report an assertion failure+-- if any diagnostic messages arrive in that period+expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session ()+expectNoMoreDiagnostics timeout =+ expectMessages SMethod_TextDocumentPublishDiagnostics timeout $ \diagsNot -> do+ let fileUri = diagsNot ^. L.params . L.uri+ actual = diagsNot ^. L.params . L.diagnostics+ unless (null actual) $ liftIO $+ assertFailure $+ "Got unexpected diagnostics for " <> show fileUri+ <> " got "+ <> show actual++expectMessages :: SMethod m -> Seconds -> (TServerMessage m -> Session ()) -> Session ()+expectMessages m timeout handle = do+ -- Give any further diagnostic messages time to arrive.+ liftIO $ sleep timeout+ -- Send a dummy message to provoke a response from the server.+ -- This guarantees that we have at least one message to+ -- process, so message won't block or timeout.+ let cm = SMethod_CustomMethod (Proxy @"test")+ i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount+ go cm i+ where+ go cm i = handleMessages+ where+ handleMessages = (LspTest.message m >>= handle) <|> (void $ responseForId cm i) <|> ignoreOthers+ ignoreOthers = void anyMessage >> handleMessages++flushMessages :: Session ()+flushMessages = do+ let cm = SMethod_CustomMethod (Proxy @"non-existent-method")+ i <- sendRequest cm A.Null+ void (responseForId cm i) <|> ignoreOthers cm i+ where+ ignoreOthers cm i = skipManyTill anyMessage (responseForId cm i) >> flushMessages++-- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics,+-- only that existing diagnostics have been cleared.+--+-- Rather than trying to assert the absence of diagnostics, introduce an+-- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic.+expectDiagnostics :: HasCallStack => [(FilePath, [ExpectedDiagnostic])] -> Session ()+expectDiagnostics+ = expectDiagnosticsWithTags+ . map (second (map expectedDiagnosticWithNothing))++unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic])+unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics)++expectDiagnosticsWithTags :: HasCallStack => [(String, [ExpectedDiagnosticWithTag])] -> Session ()+expectDiagnosticsWithTags expected = do+ let toSessionPath = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri+ next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic+ expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) toSessionPath expected+ expectDiagnosticsWithTags' next expected'++expectDiagnosticsWithTags' ::+ (HasCallStack, MonadIO m) =>+ m (Uri, [Diagnostic]) ->+ Map.Map NormalizedUri [ExpectedDiagnosticWithTag] ->+ m ()+expectDiagnosticsWithTags' next m | null m = do+ (_,actual) <- next+ case actual of+ [] ->+ return ()+ _ ->+ liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual++expectDiagnosticsWithTags' next expected = go expected+ where+ go m+ | Map.null m = pure ()+ | otherwise = do+ (fileUri, actual) <- next+ canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri+ case Map.lookup canonUri m of+ Nothing -> do+ liftIO $+ assertFailure $+ "Got diagnostics for " <> show fileUri+ <> " but only expected diagnostics for "+ <> show (Map.keys m)+ <> " got "+ <> show actual+ Just expected -> do+ liftIO $ mapM_ (requireDiagnosticM actual) expected+ liftIO $+ unless (length expected == length actual) $+ assertFailure $+ "Incorrect number of diagnostics for " <> show fileUri+ <> ", expected "+ <> show expected+ <> " but got "+ <> show actual+ go $ Map.delete canonUri m++expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [ExpectedDiagnostic] -> Session ()+expectCurrentDiagnostics doc expected = do+ diags <- getCurrentDiagnostics doc+ checkDiagnosticsForDoc doc expected diags++checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [ExpectedDiagnostic] -> [Diagnostic] -> Session ()+checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do+ let expected' = Map.singleton nuri (map expectedDiagnosticWithNothing expected)+ nuri = toNormalizedUri _uri+ expectDiagnosticsWithTags' (return (_uri, obtained)) expected'++canonicalizeUri :: Uri -> IO Uri+canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri))++diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics)+diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics++tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) b)+tryCallTestPlugin cmd = do+ let cm = SMethod_CustomMethod (Proxy @"test")+ waitId <- sendRequest cm (A.toJSON cmd)+ TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId+ return $ case _result of+ Left e -> Left e+ Right json -> case A.fromJSON json of+ A.Success a -> Right a+ A.Error e -> error e++callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b+callTestPlugin cmd = do+ res <- tryCallTestPlugin cmd+ case res of+ Left (TResponseError t err _) -> error $ show t <> ": " <> T.unpack err+ Right a -> pure a+++waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult+waitForAction key TextDocumentIdentifier{_uri} =+ callTestPlugin (WaitForIdeRule key _uri)++getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath+getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)++garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String]+garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age)++getStoredKeys :: Session [Text]+getStoredKeys = callTestPlugin GetStoredKeys++waitForTypecheck :: TextDocumentIdentifier -> Session Bool+waitForTypecheck tid = ideResultSuccess <$> waitForAction "typecheck" tid++waitForBuildQueue :: Session ()+waitForBuildQueue = callTestPlugin WaitForShakeQueue++getFilesOfInterest :: Session [FilePath]+getFilesOfInterest = callTestPlugin GetFilesOfInterest++waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res+waitForCustomMessage msg pred =+ skipManyTill anyMessage $ satisfyMaybe $ \case+ FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params = value})+ | symbolVal p == T.unpack msg -> pred value+ _ -> Nothing++waitForGC :: Session [T.Text]+waitForGC = waitForCustomMessage "ghcide/GC" $ \v ->+ case A.fromJSON v of+ A.Success x -> Just x+ _ -> Nothing++configureCheckProject :: Bool -> Session ()+configureCheckProject overrideCheckProject = setConfigSection "haskell" (toJSON $ def{checkProject = overrideCheckProject})++-- | Pattern match a message from ghcide indicating that a file has been indexed+isReferenceReady :: FilePath -> Session ()+isReferenceReady p = void $ referenceReady (equalFilePath p)++referenceReady :: (FilePath -> Bool) -> Session FilePath+referenceReady pred = satisfyMaybe $ \case+ FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params})+ | A.Success fp <- A.fromJSON _params+ , pred fp+ , symbolVal p == "ghcide/reference/ready"+ -> Just fp+ _ -> Nothing+
+ src/Development/IDE/Test/Diagnostic.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+module Development.IDE.Test.Diagnostic where++import Control.Lens ((^.))+import qualified Data.Text as T+import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion)+import GHC.Stack (HasCallStack)+import Language.LSP.Protocol.Lens+import Language.LSP.Protocol.Types++-- | (0-based line number, 0-based column number)+type Cursor = (UInt, UInt)++cursorPosition :: Cursor -> Position+cursorPosition (line, col) = Position line col++type ErrorMsg = String+++-- | Expected diagnostics have the following components:+--+-- 1. severity+-- 2. cursor (line and column numbers)+-- 3. infix of the message+-- 4. code (e.g. GHC-87543)+type ExpectedDiagnostic =+ ( DiagnosticSeverity+ , Cursor+ , T.Text+ , Maybe T.Text+ )++-- | Expected diagnostics with a tag have the following components:+--+-- 1. severity+-- 2. cursor (line and column numbers)+-- 3. infix of the message+-- 4. code (e.g. GHC-87543)+-- 5. tag (unnecessary or deprecated)+type ExpectedDiagnosticWithTag =+ ( DiagnosticSeverity+ , Cursor+ , T.Text+ , Maybe T.Text+ , Maybe DiagnosticTag+ )++requireDiagnostic+ :: (Foldable f, Show (f Diagnostic), HasCallStack)+ => f Diagnostic+ -> ExpectedDiagnosticWithTag+ -> Maybe ErrorMsg+requireDiagnostic actuals expected@(severity, cursor, expectedMsg, mbExpectedCode, expectedTag)+ | any match actuals = Nothing+ | otherwise = Just $+ "Could not find " <> show expected <>+ " in " <> show actuals+ where+ match :: Diagnostic -> Bool+ match d =+ Just severity == _severity d+ && cursorPosition cursor == d ^. range . start+ && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf`+ standardizeQuotes (T.toLower $ d ^. message)+ && hasTag expectedTag (d ^. tags)+ && codeMatches d++ codeMatches d+ | ghcVersion >= GHC96 =+ case (mbExpectedCode, _code d) of+ (Nothing, _) -> True+ (Just _, Nothing) -> False+ (Just expectedCode, Just actualCode) -> InR expectedCode == actualCode+ | otherwise = True++ hasTag :: Maybe DiagnosticTag -> Maybe [DiagnosticTag] -> Bool+ hasTag Nothing _ = True+ hasTag (Just _) Nothing = False+ hasTag (Just actualTag) (Just tags) = actualTag `elem` tags++standardizeQuotes :: T.Text -> T.Text+standardizeQuotes msg = let+ repl '‘' = '\''+ repl '’' = '\''+ repl '`' = '\''+ repl c = c+ in T.map repl msg
src/Test/Hls.hs view
@@ -1,14 +1,12 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty,@@ -30,21 +28,28 @@ goldenWithHaskellDocFormatterInTmpDir, goldenWithCabalDocFormatter, goldenWithCabalDocFormatterInTmpDir,+ goldenWithTestConfig,+ hlsHelperTestRecorder, def, -- * Running HLS for integration tests runSessionWithServer,- runSessionWithServerAndCaps, runSessionWithServerInTmpDir,- runSessionWithServerAndCapsInTmpDir,- runSessionWithServer',- runSessionWithServerInTmpDir',+ runSessionWithTestConfig,+ -- * Running parameterised tests for a set of test configurations+ parameterisedCursorTest,+ parameterisedCursorTestM, -- * Helpful re-exports PluginDescriptor, IdeState,+ -- * Helpers for expected test case failuers+ BrokenBehavior(..),+ ExpectBroken(..),+ unCurrent, -- * Assertion helper functions waitForProgressDone, waitForAllProgressDone, waitForBuildQueue,+ waitForProgressBegin, waitForTypecheck, waitForAction, hlsConfigToClientConfig,@@ -54,7 +59,7 @@ waitForKickStart, -- * Plugin descriptor helper functions for tests PluginTestDescriptor,- pluginTestRecorder,+ hlsPluginTestRecorder, mkPluginTestDescriptor, mkPluginTestDescriptor', -- * Re-export logger types@@ -62,77 +67,108 @@ WithPriority(..), Recorder, Priority(..),+ captureKickDiagnostics,+ kick,+ TestConfig(..) ) 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.Lens.Extras (is)-import Control.Monad (guard, unless, void)-import Control.Monad.Extra (forM)+import Control.Exception.Safe+import Control.Lens ((^.))+import Control.Lens.Extras (is)+import Control.Monad (guard, unless, void)+import Control.Monad.Extra (forM) import Control.Monad.IO.Class-import Data.Aeson (Result (Success),- Value (Null), fromJSON,- toJSON)-import qualified Data.Aeson as A-import Data.ByteString.Lazy (ByteString)-import Data.Default (def)-import qualified Data.Map as M-import Data.Maybe (fromMaybe)-import Data.Proxy (Proxy (Proxy))-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)-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 Control.Monad.Primitive (keepAlive)+import Data.Aeson (Result (Success),+ Value (Null),+ fromJSON, toJSON)+import qualified Data.Aeson as A+import Data.ByteString.Lazy (ByteString)+import Data.Default (Default, def)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Proxy (Proxy (Proxy))+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,+ LoggingColumn (ThreadIdColumn),+ defaultLayoutOptions,+ layoutPretty,+ renderStrict)+import Development.IDE.Main hiding (Log)+import qualified Development.IDE.Main as IDEMain+import Development.IDE.Plugin.Completions.Types (PosPrefixInfo)+import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),+ WaitForIdeRuleResult (ideResultSuccess))+import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import GHC.IO.Handle-import GHC.Stack (emptyCallStack) import GHC.TypeLits-import Ide.Logger (Doc, Logger (Logger),- Pretty (pretty),- Priority (..),- Recorder (Recorder, logger_),- WithPriority (WithPriority, priority),- cfilter, cmapWithPrio,- logWith,- makeDefaultStderrRecorder,- (<+>))+import Ide.Logger (Pretty (pretty),+ Priority (..),+ Recorder,+ WithPriority (WithPriority, priority),+ cfilter,+ cmapWithPrio,+ defaultLoggingColumns,+ logWith,+ makeDefaultStderrRecorder,+ (<+>))+import qualified Ide.Logger as Logger+import Ide.PluginUtils (idePluginsToPluginDesc,+ pluginDescToIdePlugins) import Ide.Types import Language.LSP.Protocol.Capabilities+import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message-import Language.LSP.Protocol.Types hiding (Null)+import qualified Language.LSP.Protocol.Message as LSP+import Language.LSP.Protocol.Types hiding (Null)+import qualified Language.LSP.Server as LSP import Language.LSP.Test-import Prelude hiding (log)-import System.Directory (getCurrentDirectory,- setCurrentDirectory)-import System.Environment (lookupEnv)+import Prelude hiding (log)+import System.Directory (canonicalizePath,+ createDirectoryIfMissing,+ getCurrentDirectory,+ getTemporaryDirectory,+ makeAbsolute,+ setCurrentDirectory)+import System.Environment (lookupEnv, setEnv) import System.FilePath-import System.IO.Extra (newTempDir, withTempDir)-import System.IO.Unsafe (unsafePerformIO)-import System.Process.Extra (createPipe)+import System.IO.Extra (newTempDirWithin)+import System.IO.Unsafe (unsafePerformIO)+import System.Process.Extra (createPipe) import System.Time.Extra-import qualified Test.Hls.FileSystem as FS+import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem+import Test.Hls.TestEnv (hlsTestOptions,+ wrapCliTestOptions) 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 import Test.Tasty.Ingredients.Rerun-import Test.Tasty.Runners (NumThreads (..)) data Log = LogIDEMain IDEMain.Log | LogTestHarness LogTestHarness +data TestRunLog+ = TestRunFinished+ | TestServerExitTimeoutSeconds Int+ | TestServerCancelFinished String++instance Pretty TestRunLog where+ pretty :: TestRunLog -> Logger.Doc ann+ pretty TestRunFinished = "Test run finished"+ pretty (TestServerExitTimeoutSeconds secs) = "Server does not exit in " <> pretty secs <> "s, canceling the async task..."+ pretty (TestServerCancelFinished took) = "Finishing canceling (took " <> pretty took <> "s)"+ instance Pretty Log where pretty = \case LogIDEMain log -> pretty log@@ -150,9 +186,21 @@ LogCleanup -> "Cleaned up temporary directory" LogNoCleanup -> "No cleanup of temporary directory" --- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes+data BrokenBehavior = Current | Ideal++data ExpectBroken (k :: BrokenBehavior) a where+ BrokenCurrent :: a -> ExpectBroken 'Current a+ BrokenIdeal :: a -> ExpectBroken 'Ideal a++unCurrent :: ExpectBroken 'Current a -> a+unCurrent (BrokenCurrent a) = a++-- | Run main with rerun, limiting each single test case running at most 10 minutes defaultTestRunner :: TestTree -> IO ()-defaultTestRunner = defaultMainWithRerun . adjustOption (const $ NumThreads 1) . adjustOption (const $ mkTimeout 600000000)+defaultTestRunner = defaultMainWithIngredients ingredientsWithRerun . wrapCliTestOptions . adjustOption (const $ mkTimeout 600000000)+ where+ ingredients = includingOptions hlsTestOptions : defaultIngredients+ ingredientsWithRerun = [rerunningTests ingredients] gitDiff :: FilePath -> FilePath -> [String] gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "--no-index", "--text", "--exit-code", fRef, fNew]@@ -171,7 +219,7 @@ -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithHaskellDoc = goldenWithDoc "haskell"+goldenWithHaskellDoc = goldenWithDoc LanguageKind_Haskell goldenWithHaskellDocInTmpDir :: Pretty b@@ -184,7 +232,7 @@ -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithHaskellDocInTmpDir = goldenWithDocInTmpDir "haskell"+goldenWithHaskellDocInTmpDir = goldenWithDocInTmpDir LanguageKind_Haskell goldenWithHaskellAndCaps :: Pretty b@@ -200,7 +248,14 @@ -> TestTree goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir </> path <.> desc <.> ext)- $ runSessionWithServerAndCaps config plugin clientCaps testDataDir+ $ runSessionWithTestConfig def {+ testDirLocation = Left testDataDir,+ testConfigCaps = clientCaps,+ testLspConfig = config,+ testPluginDescriptor = plugin+ }+ $ const+-- runSessionWithServerAndCaps config plugin clientCaps testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell"@@ -208,6 +263,26 @@ act doc documentContents doc +goldenWithTestConfig+ :: Pretty b+ => TestConfig b+ -> TestName+ -> VirtualFileTree+ -> FilePath+ -> FilePath+ -> FilePath+ -> (TextDocumentIdentifier -> Session ())+ -> TestTree+goldenWithTestConfig config title tree path desc ext act =+ goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)+ $ runSessionWithTestConfig config $ const+ $ TL.encodeUtf8 . TL.fromStrict+ <$> do+ doc <- openDoc (path <.> ext) "haskell"+ void waitForBuildQueue+ act doc+ documentContents doc+ goldenWithHaskellAndCapsInTmpDir :: Pretty b => Config@@ -222,7 +297,13 @@ -> TestTree goldenWithHaskellAndCapsInTmpDir config clientCaps plugin title tree path desc ext act = goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)- $ runSessionWithServerAndCapsInTmpDir config plugin clientCaps tree+ $+ runSessionWithTestConfig def {+ testDirLocation = Right tree,+ testConfigCaps = clientCaps,+ testLspConfig = config,+ testPluginDescriptor = plugin+ } $ const $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell"@@ -241,11 +322,11 @@ -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithCabalDoc = goldenWithDoc "cabal"+goldenWithCabalDoc = goldenWithDoc (LanguageKind_Custom "cabal") goldenWithDoc :: Pretty b- => T.Text+ => LanguageKind -> Config -> PluginTestDescriptor b -> TestName@@ -255,19 +336,19 @@ -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithDoc fileType config plugin title testDataDir path desc ext act =+goldenWithDoc languageKind config plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir </> path <.> desc <.> ext) $ runSessionWithServer config plugin testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do- doc <- openDoc (path <.> ext) fileType+ doc <- openDoc (path <.> ext) languageKind void waitForBuildQueue act doc documentContents doc goldenWithDocInTmpDir :: Pretty b- => T.Text+ => LanguageKind -> Config -> PluginTestDescriptor b -> TestName@@ -277,16 +358,73 @@ -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithDocInTmpDir fileType config plugin title tree path desc ext act =+goldenWithDocInTmpDir languageKind config plugin title tree path desc ext act = goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext) $ runSessionWithServerInTmpDir config plugin tree $ TL.encodeUtf8 . TL.fromStrict <$> do- doc <- openDoc (path <.> ext) fileType+ doc <- openDoc (path <.> ext) languageKind void waitForBuildQueue act doc documentContents doc +-- | A parameterised test is similar to a normal test case but allows to run+-- the same test case multiple times with different inputs.+-- A 'parameterisedCursorTest' allows to define a test case based on an input file+-- that specifies one or many cursor positions via the identification value '^'.+--+-- For example:+--+-- @+-- parameterisedCursorTest "Cursor Test" [__i|+-- foo = 2+-- ^+-- bar = 3+-- baz = foo + bar+-- ^+-- |]+-- ["foo", "baz"]+-- (\input cursor -> findFunctionNameUnderCursor input cursor)+-- @+--+-- Assuming a fitting implementation for 'findFunctionNameUnderCursor'.+--+-- This test definition will run the test case 'findFunctionNameUnderCursor' for+-- each cursor position, each in its own isolated 'testCase'.+-- Cursor positions are identified via the character '^', which points to the+-- above line as the actual cursor position.+-- Lines containing '^' characters, are removed from the final text, that is+-- passed to the testing function.+--+-- TODO: Many Haskell and Cabal source may contain '^' characters for good reasons.+-- We likely need a way to change the character for certain test cases in the future.+--+-- The quasi quoter '__i' is very helpful to define such tests, as it additionally+-- allows to interpolate haskell values and functions. We reexport this quasi quoter+-- for easier usage.+parameterisedCursorTest :: forall a . (Show a, Eq a) => String -> T.Text -> [a] -> (T.Text -> PosPrefixInfo -> IO a) -> TestTree+parameterisedCursorTest title content expectations act = parameterisedCursorTestM title content assertions act+ where+ assertions = map testCaseAssertion expectations+ testCaseAssertion :: a -> PosPrefixInfo -> a -> Assertion+ testCaseAssertion expected info actual = assertEqual (mkParameterisedLabel info) expected actual++parameterisedCursorTestM :: String -> T.Text -> [(PosPrefixInfo -> a -> Assertion)] -> (T.Text -> PosPrefixInfo -> IO a) -> TestTree+parameterisedCursorTestM title content expectations act+ | lenPrefs /= lenExpected = error $ "parameterisedCursorTest: Expected " <> show lenExpected <> " cursors but found: " <> show lenPrefs+ | otherwise = testGroup title $+ map singleTest testCaseSpec+ where+ lenPrefs = length prefInfos+ lenExpected = length expectations+ (cleanText, prefInfos) = extractCursorPositions content++ testCaseSpec = zip [1 ::Int ..] (zip expectations prefInfos)++ singleTest (n, (assert, info)) = testCase (title <> " " <> show n) $ do+ actual <- act cleanText info+ assert info actual+ -- ------------------------------------------------------------ -- Helper function for initialising plugins under test -- ------------------------------------------------------------@@ -325,10 +463,29 @@ -> PluginTestDescriptor b mkPluginTestDescriptor' pluginDesc plId _recorder = IdePlugins [pluginDesc plId] --- | Initialise a recorder that can be instructed to write to stderr by--- setting the environment variable "HLS_TEST_PLUGIN_LOG_STDERR=1" before--- running the tests.+-- | Initialize a recorder that can be instructed to write to stderr by+-- setting one of the environment variables: --+-- * HLS_TEST_HARNESS_STDERR=1+-- * HLS_TEST_LOG_STDERR=1+--+-- "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins+-- under test.+hlsHelperTestRecorder :: Pretty a => IO (Recorder (WithPriority a))+hlsHelperTestRecorder = initializeTestRecorder ["HLS_TEST_HARNESS_STDERR", "HLS_TEST_LOG_STDERR"]+++-- | Initialize a recorder that can be instructed to write to stderr by+-- setting one of the environment variables:+--+-- * HLS_TEST_PLUGIN_LOG_STDERR=1+-- * HLS_TEST_LOG_STDERR=1+--+-- before running the tests.+--+-- "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins+-- under test.+-- -- On the cli, use for example: -- -- @@@ -340,12 +497,10 @@ -- @ -- HLS_TEST_LOG_STDERR=1 cabal test <test-suite-of-plugin> -- @-pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a))-pluginTestRecorder = do- (recorder, _) <- initialiseTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "HLS_TEST_LOG_STDERR"]- pure recorder+hlsPluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a))+hlsPluginTestRecorder = initializeTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "HLS_TEST_LOG_STDERR"] --- | Generic recorder initialisation for plugins and the HLS server for test-cases.+-- | Generic recorder initialization for plugins and the HLS server for test-cases. -- -- The created recorder writes to stderr if any of the given environment variables -- have been set to a value different to @0@.@@ -354,105 +509,142 @@ -- -- We have to return the base logger function for HLS server logging initialisation. -- See 'runSessionWithServer'' for details.-initialiseTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ())-initialiseTestRecorder envVars = do- docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing+initializeTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a))+initializeTestRecorder envVars = do+ docWithPriorityRecorder <- makeDefaultStderrRecorder (Just $ ThreadIdColumn : defaultLoggingColumns)+ -- lspClientLogRecorder -- There are potentially multiple environment variables that enable this logger- definedEnvVars <- forM envVars (\var -> fromMaybe "0" <$> lookupEnv var)+ definedEnvVars <- forM envVars (fmap (fromMaybe "0") . lookupEnv) let logStdErr = any (/= "0") definedEnvVars docWithFilteredPriorityRecorder = if logStdErr then cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder else mempty - Recorder {logger_} = docWithFilteredPriorityRecorder-- pure (cmapWithPrio pretty docWithFilteredPriorityRecorder, logger_)+ pure (cmapWithPrio pretty docWithFilteredPriorityRecorder) -- ------------------------------------------------------------ -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ -runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a-runSessionWithServer config plugin fp act = do- recorder <- pluginTestRecorder- runSessionWithServer' (plugin recorder) config def fullCaps fp act--runSessionWithServerAndCaps :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a-runSessionWithServerAndCaps config plugin caps fp act = do- recorder <- pluginTestRecorder- runSessionWithServer' (plugin recorder) config def caps fp act- runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a-runSessionWithServerInTmpDir config plugin tree act = do- recorder <- pluginTestRecorder- runSessionWithServerInTmpDir' (plugin recorder) config def fullCaps tree act+runSessionWithServerInTmpDir config plugin tree act =+ runSessionWithTestConfig def+ {testLspConfig=config, testPluginDescriptor = plugin, testDirLocation=Right tree}+ (const act) -runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a-runSessionWithServerAndCapsInTmpDir config plugin caps tree act = do- recorder <- pluginTestRecorder- runSessionWithServerInTmpDir' (plugin recorder) config def caps tree act+-- | Same as 'withTemporaryDataAndCacheDirectory', but materialises the given+-- 'VirtualFileTree' in the temporary directory.+withVfsTestDataDirectory :: VirtualFileTree -> (FileSystem -> IO a) -> IO a+withVfsTestDataDirectory tree act = do+ withTemporaryDataAndCacheDirectory $ \tmpRoot -> do+ fs <- FS.materialiseVFT tmpRoot tree+ act fs --- | Host a server, and run a test session on it.------ Creates a temporary directory, and materializes the VirtualFileTree--- in the temporary directory.------ To debug test cases and verify the file system is correctly set up,--- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'.--- Further, we log the temporary directory location on startup. To view--- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'.------ Example invocation to debug test cases:------ @--- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test <plugin-name>--- @------ Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests.+-- | Run an action in a temporary directory.+-- Sets the 'XDG_CACHE_HOME' environment variable to a temporary directory as well. ----- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'.+-- This sets up a temporary directory for HLS tests to run.+-- Typically, HLS tests copy their test data into the directory and then launch+-- the HLS session in that directory.+-- This makes sure that the tests are run in isolation, which is good for correctness+-- but also important to have fast tests. ----- Note: cwd will be shifted into a temporary directory in @Session a@-runSessionWithServerInTmpDir' ::- -- | Plugins to load on the server.- --- -- For improved logging, make sure these plugins have been initalised with- -- the recorder produced by @pluginTestRecorder@.- IdePlugins IdeState ->- -- | lsp config for the server- Config ->- -- | config for the test session- SessionConfig ->- ClientCapabilities ->- VirtualFileTree ->- Session a ->- IO a-runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = withLock lockForTempDirs $ do- (recorder, _) <- initialiseTestRecorder- ["LSP_TEST_LOG_STDERR", "HLS_TEST_HARNESS_STDERR", "HLS_TEST_LOG_STDERR"]+-- For improved isolation, we also make sure the 'XDG_CACHE_HOME' environment+-- variable points to a temporary directory. So, we never share interface files+-- or the 'hiedb' across tests.+withTemporaryDataAndCacheDirectory :: (FilePath -> IO a) -> IO a+withTemporaryDataAndCacheDirectory act = withLock lockForTempDirs $ do+ testRoot <- setupTestEnvironment+ helperRecorder <- hlsHelperTestRecorder+ -- Do not clean up the temporary directory if this variable is set to anything but '0'.+ -- Aids debugging.+ cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP"+ let runTestInDir action = case cleanupTempDir of+ Just val | val /= "0" -> do+ (tempDir, cacheHome, _) <- setupTemporaryTestDirectories testRoot+ a <- withTempCacheHome cacheHome (action tempDir)+ logWith helperRecorder Debug LogNoCleanup+ pure a - -- Do not clean up the temporary directory if this variable is set to anything but '0'.- -- Aids debugging.- cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP"- let runTestInDir = case cleanupTempDir of- Just val- | val /= "0" -> \action -> do- (tempDir, _) <- newTempDir- a <- action tempDir- logWith recorder Debug $ LogNoCleanup- pure a+ _ -> do+ (tempDir, cacheHome, cleanup) <- setupTemporaryTestDirectories testRoot+ a <- withTempCacheHome cacheHome (action tempDir) `finally` cleanup+ logWith helperRecorder Debug LogCleanup+ pure a+ runTestInDir $ \tmpDir' -> do+ -- we canonicalize the path, so that we do not need to do+ -- canonicalization during the test when we compare two paths+ tmpDir <- canonicalizePath tmpDir'+ logWith helperRecorder Info $ LogTestDir tmpDir+ act tmpDir+ where+ cache_home_var = "XDG_CACHE_HOME"+ -- Set the dir for "XDG_CACHE_HOME".+ -- When the operation finished, make sure the old value is restored.+ withTempCacheHome tempCacheHomeDir act =+ bracket+ (do+ old_cache_home <- lookupEnv cache_home_var+ setEnv cache_home_var tempCacheHomeDir+ pure old_cache_home)+ (\old_cache_home ->+ maybe (pure ()) (setEnv cache_home_var) old_cache_home+ )+ (\_ -> act) - _ -> \action -> do- a <- withTempDir action- logWith recorder Debug $ LogCleanup- pure a+ -- Set up a temporary directory for the test files and one for the 'XDG_CACHE_HOME'.+ -- The 'XDG_CACHE_HOME' is important for independent test runs, i.e. completely empty+ -- caches.+ setupTemporaryTestDirectories testRoot = do+ (tempTestCaseDir, cleanup1) <- newTempDirWithin testRoot+ (tempCacheHomeDir, cleanup2) <- newTempDirWithin testRoot+ pure (tempTestCaseDir, tempCacheHomeDir, cleanup1 >> cleanup2) - runTestInDir $ \tmpDir -> do- logWith recorder Info $ LogTestDir tmpDir- _fs <- FS.materialiseVFT tmpDir tree- runSessionWithServer' plugins conf sessConf caps tmpDir act+runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a+runSessionWithServer config plugin fp act =+ runSessionWithTestConfig def {+ testLspConfig=config+ , testPluginDescriptor=plugin+ , testDirLocation = Left fp+ } (const act) ++instance Default (TestConfig b) where+ def = TestConfig {+ testDirLocation = Right $ VirtualFileTree [] "",+ testClientRoot = Nothing,+ testServerRoot = Nothing,+ testShiftRoot = False,+ testDisableKick = False,+ testDisableDefaultPlugin = False,+ testPluginDescriptor = mempty,+ testLspConfig = def,+ testConfigSession = def,+ testConfigCaps = fullLatestClientCaps,+ testCheckProject = False+ }++-- | Setup the test environment for isolated tests.+--+-- This creates a directory in the temporary directory that will be+-- reused for running isolated tests.+-- It returns the root to the testing directory that tests should use.+-- This directory is not fully cleaned between reruns.+-- However, it is totally safe to delete the directory between runs.+setupTestEnvironment :: IO FilePath+setupTestEnvironment = do+ mRootDir <- lookupEnv "HLS_TEST_ROOTDIR"+ case mRootDir of+ Nothing -> do+ tmpDirRoot <- getTemporaryDirectory+ let testRoot = tmpDirRoot </> "hls-test-root"+ createDirectoryIfMissing True testRoot+ pure testRoot+ Just rootDir -> do+ createDirectoryIfMissing True rootDir+ pure rootDir+ goldenWithHaskellDocFormatter :: Pretty b => Config@@ -564,72 +756,163 @@ lockForTempDirs :: Lock lockForTempDirs = unsafePerformIO newLock --- | Host a server, and run a test session on it--- Note: cwd will be shifted into @root@ in @Session a@-runSessionWithServer' ::- -- | Plugins to load on the server.- --- -- For improved logging, make sure these plugins have been initalised with- -- the recorder produced by @pluginTestRecorder@.- IdePlugins IdeState ->- -- | lsp config for the server- Config ->- -- | config for the test session- SessionConfig ->- ClientCapabilities ->- FilePath ->- Session a ->- IO a-runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do- (inR, inW) <- createPipe- (outR, outW) <- createPipe+data TestConfig b = TestConfig+ {+ testDirLocation :: Either FilePath VirtualFileTree+ -- ^ The file tree to use for the test, either a directory or a virtual file tree+ -- if using a virtual file tree,+ -- Creates a temporary directory, and materializes the VirtualFileTree+ -- in the temporary directory.+ --+ -- To debug test cases and verify the file system is correctly set up,+ -- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'.+ -- Further, we log the temporary directory location on startup. To view+ -- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'.+ -- Example invocation to debug test cases:+ --+ -- @+ -- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test <plugin-name>+ -- @+ --+ -- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests.+ --+ -- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'.+ , testShiftRoot :: Bool+ -- ^ Whether to shift the current directory to the root of the project+ , testClientRoot :: Maybe FilePath+ -- ^ Specify the root of (the client or LSP context),+ -- if Nothing it is the same as the testDirLocation+ -- if Just, it is subdirectory of the testDirLocation+ , testServerRoot :: Maybe FilePath+ -- ^ Specify root of the server, in exe, it can be specify in command line --cwd,+ -- or just the server start directory+ -- if Nothing it is the same as the testDirLocation+ -- if Just, it is subdirectory of the testDirLocation+ , testDisableKick :: Bool+ -- ^ Whether to disable the kick action+ , testDisableDefaultPlugin :: Bool+ -- ^ Whether to disable the default plugin comes with ghcide+ , testCheckProject :: Bool+ -- ^ Whether to typecheck check the project after the session is loaded+ , testPluginDescriptor :: PluginTestDescriptor b+ -- ^ Plugin to load on the server.+ , testLspConfig :: Config+ -- ^ lsp config for the server+ , testConfigSession :: SessionConfig+ -- ^ config for the test session+ , testConfigCaps :: ClientCapabilities+ -- ^ Client capabilities+ } - -- Allow three environment variables, because "LSP_TEST_LOG_STDERR" has been used before,- -- (thus, backwards compatibility) and "HLS_TEST_SERVER_LOG_STDERR" because it- -- uses a more descriptive name.- -- It is also in better accordance with 'pluginTestRecorder' which uses "HLS_TEST_PLUGIN_LOG_STDERR".- -- At last, "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins- -- under test.- (recorder, logger_) <- initialiseTestRecorder- ["LSP_TEST_LOG_STDERR", "HLS_TEST_SERVER_LOG_STDERR", "HLS_TEST_LOG_STDERR"] - let- sconf' = sconf { lspConfig = hlsConfigToClientConfig conf }- -- exists until old logging style is phased out- logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m))+wrapClientLogger :: Pretty a => Recorder (WithPriority a) ->+ IO (Recorder (WithPriority a), LSP.LanguageContextEnv Config -> IO ())+wrapClientLogger logger = do+ (lspLogRecorder', cb1) <- Logger.withBacklog Logger.lspClientLogRecorder+ let lspLogRecorder = cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions. pretty) lspLogRecorder'+ return (lspLogRecorder <> logger, cb1) - hlsPlugins = IdePlugins [Test.blockCommandDescriptor "block-command"] <> plugins+-- | Host a server, and run a test session on it.+--+-- Environment variables are used to influence logging verbosity, test cleanup and test execution:+--+-- * @LSP_TIMEOUT@: Set a specific test timeout in seconds.+-- * @LSP_TEST_LOG_MESSAGES@: Log the LSP messages between the client and server.+-- * @LSP_TEST_LOG_STDERR@: Log the stderr of the server to the stderr of this process.+-- * @HLS_TEST_HARNESS_STDERR@: Log test setup messages.+--+-- Test specific environment variables:+--+-- * @HLS_TEST_PLUGIN_LOG_STDERR@: Log all messages of the hls plugin under test to stderr.+-- * @HLS_TEST_LOG_STDERR@: Log all HLS messages to stderr.+-- * @HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP@: Don't remove the test directories after test execution.+--+-- For more detail of the test configuration, see 'TestConfig'+runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a+runSessionWithTestConfig TestConfig{..} session =+ runSessionInVFS testDirLocation $ \root -> shiftRoot root $ do+ pipeIn@(inR, inW) <- createPipe+ pipeOut@(outR, outW) <- createPipe+ let serverRoot = fromMaybe root testServerRoot+ let clientRoot = fromMaybe root testClientRoot - arguments@Arguments{ argsIdeOptions, argsLogger } =- testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins+ (recorder, cb1) <- wrapClientLogger =<< hlsPluginTestRecorder+ (recorderIde, cb2) <- wrapClientLogger =<< hlsHelperTestRecorder+ testRecorder <- hlsHelperTestRecorder+ -- This plugin just installs a handler for the `initialized` notification, which then+ -- picks up the LSP environment and feeds it to our recorders+ let lspRecorderPlugin = pluginDescToIdePlugins [(defaultPluginDescriptor "LSPRecorderCallback" "Internal plugin")+ { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do+ env <- LSP.getLspEnv+ liftIO $ (cb1 <> cb2) env+ }] - ideOptions config ghcSession =- let defIdeOptions = argsIdeOptions config ghcSession- in defIdeOptions- { optTesting = IdeTesting True- , optCheckProject = pure False- }+ let plugins = testPluginDescriptor recorder <> lspRecorderPlugin+ timeoutOverride <- fmap read <$> lookupEnv "LSP_TIMEOUT"+ let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig, messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride}+ arguments = testingArgs serverRoot recorderIde plugins - server <- async $- Ghcide.defaultMain (cmapWithPrio LogIDEMain recorder)- arguments- { argsHandleIn = pure inR- , argsHandleOut = pure outW- , argsDefaultHlsConfig = conf- , argsLogger = argsLogger+ -- Make an explicit call to keepAlive to protect both pipes from being GC'd.+ --+ -- If not done, a race condition forms from the handles of either pipe+ -- being closed during the LSP shutdown process. For example, consider+ -- lsp-test initiates the shutdown process, whereafter ghcide shuts down.+ -- If it's write handle is closed due to GC, lsp-test, which has been+ -- asynchronously reading from that handle's read end, will encounter a EOF+ -- and crash.+ keepAlive (pipeIn, pipeOut) $ do+ server <- async $+ IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde)+ arguments { argsHandleIn = pure inR , argsHandleOut = pure outW }+ result <- runSessionWithHandles inW outR sconf' testConfigCaps clientRoot (session root)+ hClose inW+ timeout 3 (wait server) >>= \case+ Just () -> pure ()+ Nothing -> do+ logWith testRecorder Info (TestServerExitTimeoutSeconds 3)+ (t, _) <- duration $ cancel server+ logWith testRecorder Info (TestServerCancelFinished (showDuration t))+ logWith testRecorder Info TestRunFinished+ pure result++ where+ shiftRoot shiftTarget f =+ if testShiftRoot+ then withLock lock $ keepCurrentDirectory $ setCurrentDirectory shiftTarget >> f+ else f+ runSessionInVFS (Left testConfigRoot) act = do+ root <- makeAbsolute testConfigRoot+ withTemporaryDataAndCacheDirectory (const $ act root)+ runSessionInVFS (Right vfs) act =+ withVfsTestDataDirectory vfs $ \fs -> do+ act (fsRoot fs)+ testingArgs prjRoot recorderIde plugins =+ let+ arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = defaultArguments (cmapWithPrio LogIDEMain recorderIde) prjRoot plugins+ argsHlsPlugins' = if testDisableDefaultPlugin+ then plugins+ else argsHlsPlugins+ hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins'+ ++ [Test.blockCommandDescriptor "block-command", Test.plugin]+ ideOptions config sessionLoader = (argsIdeOptions config sessionLoader){+ optTesting = IdeTesting True+ , optCheckProject = pure testCheckProject+ }+ in+ arguments+ { argsHlsPlugins = hlsPlugins , argsIdeOptions = ideOptions- , argsProjectRoot = Just root+ , argsLspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 }+ , argsDefaultHlsConfig = testLspConfig+ , argsProjectRoot = prjRoot+ , argsDisableKick = testDisableKick } - x <- runSessionWithHandles inW outR sconf' caps root s- hClose inW- timeout 3 (wait server) >>= \case- Just () -> pure ()- Nothing -> do- putStrLn "Server does not exit in 3s, canceling the async task..."- (t, _) <- duration $ cancel server- putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)"- pure x+-- | Wait for the next progress begin step+waitForProgressBegin :: Session ()+waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case+ FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressBegin v-> Just ()+ _ -> Nothing -- | Wait for the next progress end step waitForProgressDone :: Session ()@@ -660,7 +943,7 @@ -- assume a ghcide binary lacking the WaitForShakeQueue method _ -> return 0 -callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)+callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) b) callTestPlugin cmd = do let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd)@@ -668,17 +951,17 @@ return $ do e <- _result case A.fromJSON e of- A.Error err -> Left $ ResponseError (InR ErrorCodes_InternalError) (T.pack err) Nothing+ A.Error err -> Left $ TResponseError (InR ErrorCodes_InternalError) (T.pack err) Nothing A.Success a -> pure a -waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)+waitForAction :: String -> TextDocumentIdentifier -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) WaitForIdeRuleResult) waitForAction key TextDocumentIdentifier{_uri} = callTestPlugin (WaitForIdeRule key _uri) -waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)+waitForTypecheck :: TextDocumentIdentifier -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) Bool) waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid -getLastBuildKeys :: Session (Either ResponseError [T.Text])+getLastBuildKeys :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text]) getLastBuildKeys = callTestPlugin GetBuildKeysBuilt hlsConfigToClientConfig :: Config -> A.Object@@ -695,6 +978,17 @@ -- requests! skipManyTill anyMessage (void configurationRequest) +captureKickDiagnostics :: Session () -> Session () -> Session [Diagnostic]+captureKickDiagnostics start done = do+ _ <- skipManyTill anyMessage start+ messages <- manyTill anyMessage done+ pure $ concat $ mapMaybe diagnostics messages+ where+ diagnostics :: FromServerMessage' a -> Maybe [Diagnostic]+ diagnostics = \msg -> case msg of+ FromServerMess SMethod_TextDocumentPublishDiagnostics diags -> Just (diags ^. L.params . L.diagnostics)+ _ -> Nothing+ waitForKickDone :: Session () waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone @@ -706,6 +1000,7 @@ nonTrivialKickStart :: Session () nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null+ kick :: KnownSymbol k => Proxy k -> Session [FilePath] kick proxyMsg = do
src/Test/Hls/FileSystem.hs view
@@ -20,6 +20,7 @@ , directory , text , ref+ , copyDir -- * Cradle helpers , directCradle , simpleCabalCradle@@ -28,8 +29,12 @@ , directProjectMulti , simpleCabalProject , simpleCabalProject'+ , atomicFileWriteString+ , atomicFileWriteStringUTF8+ , atomicFileWriteText ) where +import Control.Exception (onException) import Data.Foldable (traverse_) import qualified Data.Text as T import qualified Data.Text.IO as T@@ -37,6 +42,8 @@ import Language.LSP.Protocol.Types (toNormalizedFilePath) import System.Directory import System.FilePath as FP+import System.IO.Extra (newTempFileWithin, writeFileUTF8)+import System.Process.Extra (readProcess) -- ---------------------------------------------------------------------------- -- Top Level definitions@@ -64,8 +71,9 @@ } deriving (Eq, Ord, Show) data FileTree- = File FilePath Content- | Directory FilePath [FileTree]+ = File FilePath Content -- ^ Create a file with the given content.+ | Directory FilePath [FileTree] -- ^ Create a directory with the given files.+ | CopiedDirectory FilePath -- ^ Copy a directory from the test data dir. deriving (Show, Eq, Ord) data Content@@ -99,13 +107,22 @@ rootDir = FP.normalise rootDir' persist :: FilePath -> FileTree -> IO ()- persist fp (File name cts) = case cts of- Inline txt -> T.writeFile (fp </> name) txt- Ref path -> copyFile (testDataDir </> FP.normalise path) (fp </> takeFileName name)- persist fp (Directory name nodes) = do- createDirectory (fp </> name)- mapM_ (persist (fp </> name)) nodes+ persist root (File name cts) = case cts of+ Inline txt -> T.writeFile (root </> name) txt+ Ref path -> copyFile (testDataDir </> FP.normalise path) (root </> takeFileName name)+ persist root (Directory name nodes) = do+ createDirectory (root </> name)+ mapM_ (persist (root </> name)) nodes+ persist root (CopiedDirectory name) = do+ copyDir' root name + copyDir' :: FilePath -> FilePath -> IO ()+ copyDir' root dir = do+ files <- fmap FP.normalise . lines <$> withCurrentDirectory (testDataDir </> dir) (readProcess "git" ["ls-files", "--cached", "--modified", "--others"] "")+ mapM_ (createDirectoryIfMissing True . ((root </>) . takeDirectory)) files+ mapM_ (\f -> copyFile (testDataDir </> dir </> f) (root </> f)) files+ return ()+ traverse_ (persist rootDir) fileTree pure $ FileSystem rootDir fileTree testDataDir @@ -115,8 +132,7 @@ -- -- File references in 'virtualFileTree' are resolved relative to the @vftOriginalRoot@. materialiseVFT :: FilePath -> VirtualFileTree -> IO FileSystem-materialiseVFT root fs =- materialise root (vftTree fs) (vftOriginalRoot fs)+materialiseVFT root fs = materialise root (vftTree fs) (vftOriginalRoot fs) -- ---------------------------------------------------------------------------- -- Test definition helpers@@ -154,6 +170,11 @@ copy :: FilePath -> FileTree copy fp = File fp (Ref fp) +-- | Copy a directory into a test project.+-- The filepath is always resolved to the root of the test data dir.+copyDir :: FilePath -> FileTree+copyDir dir = CopiedDirectory dir+ directory :: FilePath -> [FileTree] -> FileTree directory name nodes = Directory name nodes @@ -228,3 +249,25 @@ simpleCabalProject' fps = [ simpleCabalCradle ] <> fps+++atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO a+atomicFileWrite targetPath write = do+ let dir = takeDirectory targetPath+ createDirectoryIfMissing True dir+ (tempFilePath, cleanUp) <- newTempFileWithin dir+ (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> pure x)+ `onException` cleanUp+++atomicFileWriteString :: FilePath -> String -> IO ()+atomicFileWriteString targetPath content =+ atomicFileWrite targetPath (flip writeFile content)++atomicFileWriteStringUTF8 :: FilePath -> String -> IO ()+atomicFileWriteStringUTF8 targetPath content =+ atomicFileWrite targetPath (flip writeFileUTF8 content)++atomicFileWriteText :: FilePath -> T.Text -> IO ()+atomicFileWriteText targetPath content =+ atomicFileWrite targetPath (flip T.writeFile content)
+ src/Test/Hls/TestEnv.hs view
@@ -0,0 +1,104 @@+module Test.Hls.TestEnv+ ( HlsLogStderr(..)+ , HlsPluginLogStderr(..)+ , HlsHarnessStderr(..)+ , HlsHarnessNoTestdirCleanup(..)+ , HlsTestRootDir(..)+ , LspTimeout(..)+ , hlsTestOptions+ , wrapCliTestOptions+ ) where++import Control.Monad (guard)+import Data.Data (Proxy (..))+import Data.Foldable (traverse_)+import Data.Maybe (catMaybes)+import System.Environment (lookupEnv, setEnv, unsetEnv)+import Test.Tasty (TestTree, askOption, withResource)+import Test.Tasty.Options (IsOption (defaultValue, optionCLParser, optionHelp, optionName, parseValue),+ OptionDescription (..), flagCLParser,+ safeRead, safeReadBool)++newtype HlsLogStderr = HlsLogStderr Bool+instance IsOption HlsLogStderr where+ defaultValue = HlsLogStderr False+ parseValue s = HlsLogStderr <$> safeReadBool s+ optionName = pure "log-stderr"+ optionHelp = pure "Log all HLS messages to stderr"+ optionCLParser = flagCLParser Nothing (HlsLogStderr True)++newtype HlsPluginLogStderr = HlsPluginLogStderr Bool+instance IsOption HlsPluginLogStderr where+ defaultValue = HlsPluginLogStderr False+ parseValue s = HlsPluginLogStderr <$> safeReadBool s+ optionName = pure "plugin-log-stderr"+ optionHelp = pure "Log all messages of the hls plugin under test to stderr"+ optionCLParser = flagCLParser Nothing (HlsPluginLogStderr True)++newtype HlsHarnessStderr = HlsHarnessStderr Bool+instance IsOption HlsHarnessStderr where+ defaultValue = HlsHarnessStderr False+ parseValue s = HlsHarnessStderr <$> safeReadBool s+ optionName = pure "test-harness-log-stderr"+ optionHelp = pure "Log test setup messages to stderr"+ optionCLParser = flagCLParser Nothing (HlsHarnessStderr True)++newtype HlsHarnessNoTestdirCleanup = HlsHarnessNoTestdirCleanup Bool+instance IsOption HlsHarnessNoTestdirCleanup where+ defaultValue = HlsHarnessNoTestdirCleanup False+ parseValue s = HlsHarnessNoTestdirCleanup <$> safeReadBool s+ optionName = pure "test-harness-no-testdir-cleanup"+ optionHelp = pure "Don't remove the test directories after test execution"+ optionCLParser = flagCLParser Nothing (HlsHarnessNoTestdirCleanup True)++newtype HlsTestRootDir = HlsTestRootDir (Maybe FilePath)+instance IsOption HlsTestRootDir where+ defaultValue = HlsTestRootDir Nothing+ parseValue s = Just . HlsTestRootDir . Just $ s+ optionName = pure "test-root-dir"+ optionHelp = pure "Root directory for test file isolation"++newtype LspTimeout = LspTimeout (Maybe Int)+instance IsOption LspTimeout where+ defaultValue = LspTimeout Nothing+ parseValue s = LspTimeout . Just <$> safeRead s+ optionName = pure "lsp-timeout"+ optionHelp = pure "Set a specific test timeout in seconds"++hlsTestOptions :: [OptionDescription]+hlsTestOptions =+ [ Option (Proxy @HlsLogStderr)+ , Option (Proxy @HlsPluginLogStderr)+ , Option (Proxy @HlsHarnessStderr)+ , Option (Proxy @HlsHarnessNoTestdirCleanup)+ , Option (Proxy @HlsTestRootDir)+ , Option (Proxy @LspTimeout)+ ]++-- | Use tasty cli options to set legacy environment variables+wrapCliTestOptions :: TestTree -> TestTree+wrapCliTestOptions tree =+ askOption $ \(HlsLogStderr logStderr) ->+ askOption $ \(HlsPluginLogStderr pluginStderr) ->+ askOption $ \(HlsTestRootDir rootDir) ->+ askOption $ \(HlsHarnessStderr harnessStderr) ->+ askOption $ \(HlsHarnessNoTestdirCleanup harnessNoTestdirCleanup) ->+ askOption $ \(LspTimeout timeout) ->+ let overrides = catMaybes+ [ ("HLS_TEST_LOG_STDERR", "1") <$ guard logStderr+ , ("HLS_TEST_PLUGIN_LOG_STDERR", "1") <$ guard pluginStderr+ , ("HLS_TEST_ROOTDIR",) <$> rootDir+ , ("HLS_TEST_HARNESS_STDERR", "1") <$ guard harnessStderr+ , ("HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP", "1") <$ guard harnessNoTestdirCleanup+ , ("LSP_TIMEOUT",) . show <$> timeout+ ]+ in withResource (setOverrides overrides) restoreEnvs (const tree)++setOverrides :: [(String, String)] -> IO [(String, Maybe String)]+setOverrides = traverse $ \(k, v) -> do+ old <- lookupEnv k+ setEnv k v+ pure (k, old)++restoreEnvs :: [(String, Maybe String)] -> IO ()+restoreEnvs = traverse_ $ \(k, mv) -> maybe (unsetEnv k) (setEnv k) mv
src/Test/Hls/Util.hs view
@@ -1,17 +1,13 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE DataKinds #-} module Test.Hls.Util ( -- * Test Capabilities codeActionResolveCaps , codeActionNoResolveCaps+ , codeActionNoInlayHintsCaps , codeActionSupportCaps , expectCodeAction -- * Environment specifications@@ -34,14 +30,13 @@ , dontExpectCodeAction , expectDiagnostic , expectNoMoreDiagnostics- , expectSameLocations , failIfSessionTimeout , getCompletionByLabel , noLiteralCaps , inspectCodeAction , inspectCommand , inspectDiagnostic- , SymbolLocation+ , inspectDiagnosticAny , waitForDiagnosticsFrom , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout@@ -49,39 +44,49 @@ , withCurrentDirectoryInTmp , withCurrentDirectoryInTmp' , withCanonicalTempDir+ -- * Extract positions from input file.+ , extractCursorPositions+ , mkParameterisedLabel+ , __i ) where -import Control.Applicative.Combinators (skipManyTill, (<|>))-import Control.Exception (catch, throwIO)-import Control.Lens ((&), (?~), (^.), _Just, (.~))+import Control.Applicative.Combinators (skipManyTill, (<|>))+import Control.Exception (catch, throwIO)+import Control.Lens (_Just, (&), (.~),+ (?~), (^.)) import Control.Monad import Control.Monad.IO.Class-import qualified Data.Aeson as A-import Data.Bool (bool)+import qualified Data.Aeson as A+import Data.Bool (bool) import Data.Default-import Data.Row+import Data.List.Extra (find) import Data.Proxy-import Data.List.Extra (find)-import qualified Data.Set as Set-import qualified Data.Text as T-import Development.IDE (GhcVersion (..), ghcVersion)-import qualified Language.LSP.Test as Test-import Language.LSP.Protocol.Types+import qualified Data.Text as T+import Development.IDE (GhcVersion (..),+ ghcVersion)+import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message-import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Types+import qualified Language.LSP.Test as Test import System.Directory import System.FilePath-import System.Info.Extra (isMac, isWindows)+import System.Info.Extra (isMac, isWindows) import qualified System.IO.Extra import System.IO.Temp-import System.Time.Extra (Seconds, sleep)-import Test.Tasty (TestTree)-import Test.Tasty.ExpectedFailure (expectFailBecause,- ignoreTestBecause)-import Test.Tasty.HUnit (Assertion, assertFailure,- (@?=))+import System.Time.Extra (Seconds, sleep)+import Test.Tasty (TestTree)+import Test.Tasty.ExpectedFailure (expectFailBecause,+ ignoreTestBecause)+import Test.Tasty.HUnit (assertFailure) +import qualified Data.List as List+import Data.String.Interpolate (__i)+import qualified Data.Text.Internal.Search as T+import qualified Data.Text.Utf16.Rope.Mixed as Rope+import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope)+import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))+ noLiteralCaps :: ClientCapabilities noLiteralCaps = def & L.textDocument ?~ textDocumentCaps where@@ -93,17 +98,23 @@ where textDocumentCaps = def { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing- literalSupport = #codeActionKind .== (#valueSet .== [])+ literalSupport = ClientCodeActionLiteralOptions (ClientCodeActionKindOptions []) codeActionResolveCaps :: ClientCapabilities-codeActionResolveCaps = Test.fullCaps- & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ (#properties .== ["edit"])+codeActionResolveCaps = Test.fullLatestClientCaps+ & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ ClientCodeActionResolveOptions {_properties= ["edit"]} & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ True codeActionNoResolveCaps :: ClientCapabilities-codeActionNoResolveCaps = Test.fullCaps+codeActionNoResolveCaps = Test.fullLatestClientCaps & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False++codeActionNoInlayHintsCaps :: ClientCapabilities+codeActionNoInlayHintsCaps = Test.fullLatestClientCaps+ & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing+ & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False+ & (L.textDocument . _Just . L.inlayHint) .~ Nothing -- --------------------------------------------------------------------- -- Environment specification for ignoring tests -- ---------------------------------------------------------------------@@ -237,6 +248,10 @@ inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.message)) s) err where err = "expected diagnostic matching '" ++ show s ++ "' but did not find one" +inspectDiagnosticAny :: [Diagnostic] -> [T.Text] -> IO Diagnostic+inspectDiagnosticAny diags s = onMatch diags (\ca -> any (`T.isInfixOf` (ca ^. L.message)) s) err+ where err = "expected diagnostic matching one of'" ++ show s ++ "' but did not find one"+ expectDiagnostic :: [Diagnostic] -> [T.Text] -> IO () expectDiagnostic diags s = void $ inspectDiagnostic diags s @@ -304,7 +319,7 @@ handleDiagnostic testId = do diagsNot <- Test.message SMethod_TextDocumentPublishDiagnostics let fileUri = diagsNot ^. L.params . L.uri- ( diags) = diagsNot ^. L.params . L.diagnostics+ diags = diagsNot ^. L.params . L.diagnostics res = filter matches diags if fileUri == document ^. L.uri && not (null res) then return res else handleMessages testId@@ -320,23 +335,6 @@ errorHandler e@(Test.Timeout _) = assertFailure $ show e errorHandler e = throwIO e --- | To locate a symbol, we provide a path to the file from the HLS root--- directory, the line number, and the column number. (0 indexed.)-type SymbolLocation = (FilePath, UInt, UInt)--expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion-actual `expectSameLocations` expected = do- let actual' =- Set.map (\location -> (location ^. L.uri- , location ^. L.range . L.start . L.line- , location ^. L.range . L.start . L.character))- $ Set.fromList actual- expected' <- Set.fromList <$>- (forM expected $ \(file, l, c) -> do- fp <- canonicalizePath file- return (filePathToUri fp, l, c))- actual' @?= expected'- -- --------------------------------------------------------------------- getCompletionByLabel :: MonadIO m => T.Text -> [CompletionItem] -> m CompletionItem getCompletionByLabel desiredLabel compls =@@ -352,3 +350,119 @@ withCanonicalTempDir f = System.IO.Extra.withTempDir $ \dir -> do dir' <- canonicalizePath dir f dir'++-- ----------------------------------------------------------------------------+-- Extract Position data from the source file itself.+-- ----------------------------------------------------------------------------++-- | Pretty labelling for tests that use the parameterised test helpers.+mkParameterisedLabel :: PosPrefixInfo -> String+mkParameterisedLabel posPrefixInfo = unlines+ [ "Full Line: \"" <> T.unpack (fullLine posPrefixInfo) <> "\""+ , "Cursor Column: \"" <> replicate (fromIntegral $ cursorPos posPrefixInfo ^. L.character) ' ' ++ "^" <> "\""+ , "Prefix Text: \"" <> T.unpack (prefixText posPrefixInfo) <> "\""+ ]++-- | Given a in-memory representation of a file, where a user can specify the+-- current cursor position using a '^' in the next line.+--+-- This function allows to generate multiple tests for a single input file, without+-- the hassle of calculating by hand where there cursor is supposed to be.+--+-- Example (line number has been added for readability):+--+-- @+-- 0: foo = 2+-- 1: ^+-- 2: bar =+-- 3: ^+-- @+--+-- This example input file contains two cursor positions (y, x), at+--+-- * (1, 1), and+-- * (3, 5).+--+-- 'extractCursorPositions' will search for '^' characters, and determine there are+-- two cursor positions in the text.+-- First, it will normalise the text to:+--+-- @+-- 0: foo = 2+-- 1: bar =+-- @+--+-- stripping away the '^' characters. Then, the actual cursor positions are:+--+-- * (0, 1) and+-- * (2, 5).+--+extractCursorPositions :: T.Text -> (T.Text, [PosPrefixInfo])+extractCursorPositions t =+ let+ textLines = T.lines t+ foldState = List.foldl' go emptyFoldState textLines+ finalText = foldStateToText foldState+ reconstructCompletionPrefix pos = getCompletionPrefixFromRope pos (Rope.fromText finalText)+ cursorPositions = reverse . fmap reconstructCompletionPrefix $ foldStatePositions foldState+ in+ (finalText, cursorPositions)++ where+ go foldState l = case T.indices "^" l of+ [] -> addTextLine foldState l+ xs -> List.foldl' addTextCursor foldState xs++-- | 'FoldState' is an implementation detail used to parse some file contents,+-- extracting the cursor positions identified by '^' and producing a cleaned+-- representation of the file contents.+data FoldState = FoldState+ { foldStateRows :: !Int+ -- ^ The row index of the cleaned file contents.+ --+ -- For example, the file contents+ --+ -- @+ -- 0: foo+ -- 1: ^+ -- 2: bar+ -- @+ -- will report that 'bar' is actually occurring in line '1', as '^' is+ -- a cursor position.+ -- Lines containing cursor positions are removed.+ , foldStatePositions :: ![Position]+ -- ^ List of cursors positions found in the file contents.+ --+ -- List is stored in reverse for efficient 'cons'ing+ , foldStateFinalText :: ![T.Text]+ -- ^ Final file contents with all lines containing cursor positions removed.+ --+ -- List is stored in reverse for efficient 'cons'ing+ }++emptyFoldState :: FoldState+emptyFoldState = FoldState+ { foldStateRows = 0+ , foldStatePositions = []+ , foldStateFinalText = []+ }++-- | Produce the final file contents, without any lines containing cursor positions.+foldStateToText :: FoldState -> T.Text+foldStateToText state = T.unlines $ reverse $ foldStateFinalText state++-- | We found a '^' at some location! Add it to the list of known cursor positions.+--+-- If the row index is '0', we throw an error, as there can't be a cursor position above the first line.+addTextCursor :: FoldState -> Int -> FoldState+addTextCursor state col+ | foldStateRows state <= 0 = error $ "addTextCursor: Invalid '^' found at: " <> show (col, foldStateRows state)+ | otherwise = state+ { foldStatePositions = Position (fromIntegral (foldStateRows state) - 1) (fromIntegral col) : foldStatePositions state+ }++addTextLine :: FoldState -> T.Text -> FoldState+addTextLine state l = state+ { foldStateFinalText = l : foldStateFinalText state+ , foldStateRows = foldStateRows state + 1+ }