hls-test-utils 1.5.0.0 → 2.14.0.0
raw patch · 7 files changed
Files
- hls-test-utils.cabal +20/−11
- src/Development/IDE/Test.hs +264/−0
- src/Development/IDE/Test/Diagnostic.hs +87/−0
- src/Test/Hls.hs +726/−202
- src/Test/Hls/FileSystem.hs +273/−0
- src/Test/Hls/TestEnv.hs +104/−0
- src/Test/Hls/Util.hs +196/−60
hls-test-utils.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-test-utils-version: 1.5.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,27 +27,32 @@ library exposed-modules: Test.Hls+ 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 ^>=1.9- , hls-graph- , hls-plugin-api ^>=1.6+ , ghcide == 2.14.0.0+ , hls-plugin-api == 2.14.0.0 , lens- , lsp ^>=1.6.0.0- , lsp-test ^>=0.14- , lsp-types ^>=1.6.0.0+ , lsp+ , lsp-test ^>=0.18+ , lsp-types ^>=2.4+ , primitive+ , safe-exceptions+ , string-interpolate >= 0.3.1 , tasty , tasty-expected-failure , tasty-golden@@ -55,11 +60,15 @@ , tasty-rerun , temporary , text- , unordered-containers+ , text-rope - ghc-options: -Wall+ 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,47 +1,65 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}+{-# 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, module Test.Tasty.ExpectedFailure, module Test.Hls.Util,- module Language.LSP.Types,+ module Language.LSP.Protocol.Types,+ module Language.LSP.Protocol.Message, module Language.LSP.Test, module Control.Monad.IO.Class, module Control.Applicative.Combinators, defaultTestRunner, goldenGitDiff, goldenWithHaskellDoc,+ goldenWithHaskellDocInTmpDir,+ goldenWithHaskellAndCaps,+ goldenWithHaskellAndCapsInTmpDir, goldenWithCabalDoc, goldenWithHaskellDocFormatter,+ goldenWithHaskellDocFormatterInTmpDir, goldenWithCabalDocFormatter,+ goldenWithCabalDocFormatterInTmpDir,+ goldenWithTestConfig,+ hlsHelperTestRecorder, def, -- * Running HLS for integration tests runSessionWithServer,- runSessionWithServerAndCaps,- runSessionWithServerFormatter,- runSessionWithCabalServerFormatter,- 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,- sendConfigurationChanged,+ hlsConfigToClientConfig,+ setHlsConfig, getLastBuildKeys, waitForKickDone, waitForKickStart, -- * Plugin descriptor helper functions for tests PluginTestDescriptor,- pluginTestRecorder,+ hlsPluginTestRecorder, mkPluginTestDescriptor, mkPluginTestDescriptor', -- * Re-export logger types@@ -49,76 +67,140 @@ 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.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 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 Development.IDE.Types.Logger (Doc, Logger (Logger),- Pretty (pretty),- Priority (Debug),- Recorder (Recorder, logger_),- WithPriority (WithPriority, priority),- cfilter, cmapWithPrio,- makeDefaultStderrRecorder)+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 (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 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 Language.LSP.Types hiding- (SemanticTokenAbsolute (length, line),- SemanticTokenRelative (length),- SemanticTokensEdit (_start))-import Language.LSP.Types.Capabilities (ClientCapabilities)-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.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 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 (..)) -newtype Log = LogIDEMain IDEMain.Log+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+ LogIDEMain log -> pretty log+ LogTestHarness log -> pretty log --- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes+data LogTestHarness+ = LogTestDir FilePath+ | LogCleanup+ | LogNoCleanup+++instance Pretty LogTestHarness where+ pretty = \case+ LogTestDir dir -> "Test Project located in directory:" <+> pretty dir+ LogCleanup -> "Cleaned up temporary directory"+ LogNoCleanup -> "No cleanup of temporary directory"++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]@@ -128,7 +210,8 @@ goldenWithHaskellDoc :: Pretty b- => PluginTestDescriptor b+ => Config+ -> PluginTestDescriptor b -> TestName -> FilePath -> FilePath@@ -136,11 +219,102 @@ -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithHaskellDoc = goldenWithDoc "haskell"+goldenWithHaskellDoc = goldenWithDoc LanguageKind_Haskell +goldenWithHaskellDocInTmpDir+ :: Pretty b+ => Config+ -> PluginTestDescriptor b+ -> TestName+ -> VirtualFileTree+ -> FilePath+ -> FilePath+ -> FilePath+ -> (TextDocumentIdentifier -> Session ())+ -> TestTree+goldenWithHaskellDocInTmpDir = goldenWithDocInTmpDir LanguageKind_Haskell++goldenWithHaskellAndCaps+ :: Pretty b+ => Config+ -> ClientCapabilities+ -> PluginTestDescriptor b+ -> TestName+ -> FilePath+ -> FilePath+ -> FilePath+ -> FilePath+ -> (TextDocumentIdentifier -> Session ())+ -> TestTree+goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ext act =+ goldenGitDiff title (testDataDir </> path <.> desc <.> ext)+ $ 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"+ void waitForBuildQueue+ 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+ -> ClientCapabilities+ -> PluginTestDescriptor b+ -> TestName+ -> VirtualFileTree+ -> FilePath+ -> FilePath+ -> FilePath+ -> (TextDocumentIdentifier -> Session ())+ -> TestTree+goldenWithHaskellAndCapsInTmpDir config clientCaps plugin title tree path desc ext act =+ goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)+ $+ runSessionWithTestConfig def {+ testDirLocation = Right tree,+ testConfigCaps = clientCaps,+ testLspConfig = config,+ testPluginDescriptor = plugin+ } $ const+ $ TL.encodeUtf8 . TL.fromStrict+ <$> do+ doc <- openDoc (path <.> ext) "haskell"+ void waitForBuildQueue+ act doc+ documentContents doc+ goldenWithCabalDoc :: Pretty b- => PluginTestDescriptor b+ => Config+ -> PluginTestDescriptor b -> TestName -> FilePath -> FilePath@@ -148,11 +322,12 @@ -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithCabalDoc = goldenWithDoc "cabal"+goldenWithCabalDoc = goldenWithDoc (LanguageKind_Custom "cabal") goldenWithDoc :: Pretty b- => T.Text+ => LanguageKind+ -> Config -> PluginTestDescriptor b -> TestName -> FilePath@@ -161,22 +336,101 @@ -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithDoc fileType plugin title testDataDir path desc ext act =+goldenWithDoc languageKind config plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir </> path <.> desc <.> ext)- $ runSessionWithServer plugin testDataDir+ $ 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+ => LanguageKind+ -> Config+ -> PluginTestDescriptor b+ -> TestName+ -> VirtualFileTree+ -> FilePath+ -> FilePath+ -> FilePath+ -> (TextDocumentIdentifier -> Session ())+ -> TestTree+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) 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 -- ------------------------------------------------------------ -- | Plugin under test where a fitting recorder is injected.-type PluginTestDescriptor b = Recorder (WithPriority b) -> PluginDescriptor IdeState+type PluginTestDescriptor b = Recorder (WithPriority b) -> IdePlugins IdeState -- | Wrap a plugin you want to test, and inject a fitting recorder as required. --@@ -197,7 +451,7 @@ :: (Recorder (WithPriority b) -> PluginId -> PluginDescriptor IdeState) -> PluginId -> PluginTestDescriptor b-mkPluginTestDescriptor pluginDesc plId recorder = pluginDesc recorder plId+mkPluginTestDescriptor pluginDesc plId recorder = IdePlugins [pluginDesc recorder plId] -- | Wrap a plugin you want to test. --@@ -207,12 +461,31 @@ :: (PluginId -> PluginDescriptor IdeState) -> PluginId -> PluginTestDescriptor b-mkPluginTestDescriptor' pluginDesc plId _recorder = pluginDesc plId+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: -- -- @@@ -224,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@.@@ -238,52 +509,146 @@ -- -- 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 Debug+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 => PluginTestDescriptor b -> FilePath -> Session a -> IO a-runSessionWithServer plugin fp act = do- recorder <- pluginTestRecorder- runSessionWithServer' [plugin recorder] def def fullCaps fp act+runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a+runSessionWithServerInTmpDir config plugin tree act =+ runSessionWithTestConfig def+ {testLspConfig=config, testPluginDescriptor = plugin, testDirLocation=Right tree}+ (const act) -runSessionWithServerAndCaps :: Pretty b => PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a-runSessionWithServerAndCaps plugin caps fp act = do- recorder <- pluginTestRecorder- runSessionWithServer' [plugin recorder] def def caps fp 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 -runSessionWithServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a-runSessionWithServerFormatter plugin formatter conf fp act = do- recorder <- pluginTestRecorder- runSessionWithServer'- [plugin recorder]- def- { formattingProvider = T.pack formatter- , plugins = M.singleton (PluginId $ T.pack formatter) conf- }- def- fullCaps- fp- act+-- | Run an action in a temporary directory.+-- Sets the 'XDG_CACHE_HOME' environment variable to a temporary directory as well.+--+-- 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.+--+-- 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+ (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)++ -- 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)++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- => PluginTestDescriptor b -- ^ Formatter plugin to be used+ => Config+ -> PluginTestDescriptor b -- ^ Formatter plugin to be used -> String -- ^ Name of the formatter to be used -> PluginConfig -> TestName -- ^ Title of the test@@ -293,9 +658,10 @@ -> FilePath -- ^ Extension of the output file -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithHaskellDocFormatter plugin formatter conf title testDataDir path desc ext act =- goldenGitDiff title (testDataDir </> path <.> desc <.> ext)- $ runSessionWithServerFormatter plugin formatter conf testDataDir+goldenWithHaskellDocFormatter config plugin formatter conf title testDataDir path desc ext act =+ let config' = config { formattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf }+ in goldenGitDiff title (testDataDir </> path <.> desc <.> ext)+ $ runSessionWithServer config' plugin testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell"@@ -305,7 +671,8 @@ goldenWithCabalDocFormatter :: Pretty b- => PluginTestDescriptor b -- ^ Formatter plugin to be used+ => Config+ -> PluginTestDescriptor b -- ^ Formatter plugin to be used -> String -- ^ Name of the formatter to be used -> PluginConfig -> TestName -- ^ Title of the test@@ -315,9 +682,10 @@ -> FilePath -- ^ Extension of the output file -> (TextDocumentIdentifier -> Session ()) -> TestTree-goldenWithCabalDocFormatter plugin formatter conf title testDataDir path desc ext act =- goldenGitDiff title (testDataDir </> path <.> desc <.> ext)- $ runSessionWithCabalServerFormatter plugin formatter conf testDataDir+goldenWithCabalDocFormatter config plugin formatter conf title testDataDir path desc ext act =+ let config' = config { cabalFormattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf }+ in goldenGitDiff title (testDataDir </> path <.> desc <.> ext)+ $ runSessionWithServer config' plugin testDataDir $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "cabal"@@ -325,19 +693,54 @@ act doc documentContents doc -runSessionWithCabalServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a-runSessionWithCabalServerFormatter plugin formatter conf fp act = do- recorder <- pluginTestRecorder- runSessionWithServer'- [plugin recorder]- def- { cabalFormattingProvider = T.pack formatter- , plugins = M.singleton (PluginId $ T.pack formatter) conf- }- def- fullCaps- fp act+goldenWithHaskellDocFormatterInTmpDir+ :: Pretty b+ => Config+ -> PluginTestDescriptor b -- ^ Formatter plugin to be used+ -> String -- ^ Name of the formatter to be used+ -> PluginConfig+ -> TestName -- ^ Title of the test+ -> VirtualFileTree -- ^ Virtual representation of the test project+ -> FilePath -- ^ Path to the testdata to be used within the directory+ -> FilePath -- ^ Additional suffix to be appended to the output file+ -> FilePath -- ^ Extension of the output file+ -> (TextDocumentIdentifier -> Session ())+ -> TestTree+goldenWithHaskellDocFormatterInTmpDir config plugin formatter conf title tree path desc ext act =+ let config' = config { formattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf }+ in goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)+ $ runSessionWithServerInTmpDir config' plugin tree+ $ TL.encodeUtf8 . TL.fromStrict+ <$> do+ doc <- openDoc (path <.> ext) "haskell"+ void waitForBuildQueue+ act doc+ documentContents doc +goldenWithCabalDocFormatterInTmpDir+ :: Pretty b+ => Config+ -> PluginTestDescriptor b -- ^ Formatter plugin to be used+ -> String -- ^ Name of the formatter to be used+ -> PluginConfig+ -> TestName -- ^ Title of the test+ -> VirtualFileTree -- ^ Virtual representation of the test project+ -> FilePath -- ^ Path to the testdata to be used within the directory+ -> FilePath -- ^ Additional suffix to be appended to the output file+ -> FilePath -- ^ Extension of the output file+ -> (TextDocumentIdentifier -> Session ())+ -> TestTree+goldenWithCabalDocFormatterInTmpDir config plugin formatter conf title tree path desc ext act =+ let config' = config { cabalFormattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf }+ in goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)+ $ runSessionWithServerInTmpDir config' plugin tree+ $ TL.encodeUtf8 . TL.fromStrict+ <$> do+ doc <- openDoc (path <.> ext) "cabal"+ void waitForBuildQueue+ act doc+ documentContents doc+ -- | Restore cwd after running an action keepCurrentDirectory :: IO a -> IO a keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const@@ -347,75 +750,174 @@ 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' ::- -- | Plugins to load on the server.- --- -- For improved logging, make sure these plugins have been initalised with- -- the recorder produced by @pluginTestRecorder@.- [PluginDescriptor 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 - -- 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"]+{-# NOINLINE lockForTempDirs #-}+-- | Never run in parallel+lockForTempDirs :: Lock+lockForTempDirs = unsafePerformIO newLock - let- -- exists until old logging style is phased out- logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m))+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+ } - hlsPlugins = IdePlugins $ Test.blockCommandDescriptor "block-command" : plugins - arguments@Arguments{ argsIdeOptions, argsLogger } =- testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins+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) - ideOptions config ghcSession =- let defIdeOptions = argsIdeOptions config ghcSession- in defIdeOptions- { optTesting = IdeTesting True- , optCheckProject = pure False- }+-- | 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 - server <- async $- Ghcide.defaultMain (cmapWithPrio LogIDEMain recorder)- arguments- { argsHandleIn = pure inR- , argsHandleOut = pure outW- , argsDefaultHlsConfig = conf- , argsLogger = argsLogger+ (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+ }]++ 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++ -- 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+ , 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 () waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case- FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()+ FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v-> Just () _ -> Nothing -- | Wait for all progress to be done@@ -425,7 +927,7 @@ where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case- FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()+ FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop@@ -433,39 +935,60 @@ -- | Wait for the build queue to be empty waitForBuildQueue :: Session Seconds waitForBuildQueue = do- let m = SCustomMethod "test"+ let m = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest m (toJSON WaitForShakeQueue) (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId case resp of- ResponseMessage{_result=Right Null} -> return td+ TResponseMessage{_result=Right Null} -> return td -- assume a ghcide binary lacking the WaitForShakeQueue method- _ -> return 0+ _ -> 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 = SCustomMethod "test"+ let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd)- ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId+ TResponseMessage{_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.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 -sendConfigurationChanged :: Value -> Session ()-sendConfigurationChanged config =- sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config)+hlsConfigToClientConfig :: Config -> A.Object+hlsConfigToClientConfig config = [("haskell", toJSON config)] +-- | Set the HLS client configuration, and wait for the server to update to use it.+-- Note that this will only work if we are not ignoring configuration requests, you+-- may need to call @setIgnoringConfigurationRequests False@ first.+setHlsConfig :: Config -> Session ()+setHlsConfig config = do+ setConfig $ hlsConfigToClientConfig config+ -- wait until we get the workspace/configuration request from the server, so+ -- we know things are settling. This only works if we're not skipping config+ -- 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 @@ -473,14 +996,15 @@ waitForKickStart = void $ skipManyTill anyMessage nonTrivialKickStart nonTrivialKickDone :: Session ()-nonTrivialKickDone = kick "done" >>= guard . not . null+nonTrivialKickDone = kick (Proxy @"kick/done") >>= guard . not . null nonTrivialKickStart :: Session ()-nonTrivialKickStart = kick "start" >>= guard . not . null+nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null -kick :: T.Text -> Session [FilePath]-kick msg = do- NotMess NotificationMessage{_params} <- customNotification $ "kick/" <> msg++kick :: KnownSymbol k => Proxy k -> Session [FilePath]+kick proxyMsg = do+ NotMess TNotificationMessage{_params} <- customNotification proxyMsg case fromJSON _params of Success x -> return x other -> error $ "Failed to parse kick/done details: " <> show other
+ src/Test/Hls/FileSystem.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE OverloadedStrings #-}+module Test.Hls.FileSystem+ ( FileSystem(..)+ , VirtualFileTree(..)+ , FileTree+ , Content+ -- * init+ , materialise+ , materialiseVFT+ -- * Interaction+ , readFileFS+ , writeFileFS+ -- * Test helpers+ , mkVirtualFileTree+ , toNfp+ , toAbsFp+ -- * Builders+ , file+ , copy+ , directory+ , text+ , ref+ , copyDir+ -- * Cradle helpers+ , directCradle+ , simpleCabalCradle+ -- * Full project setups+ , directProject+ , 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+import Development.IDE (NormalizedFilePath)+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+-- ----------------------------------------------------------------------------++-- | Representation of a 'VirtualFileTree' that has been 'materialise'd to disk.+--+data FileSystem =+ FileSystem+ { fsRoot :: FilePath+ , fsTree :: [FileTree]+ , fsOriginalRoot :: FilePath+ } deriving (Eq, Ord, Show)++-- | Virtual representation of a filesystem tree.+--+-- Operations of 'vftTree' are relative to 'vftOriginalRoot'.+-- In particular, any 'copy' etc. operation looks for the sources in 'vftOriginalRoot'.+--+-- To persist a 'VirtualFileTree', look at 'materialise' and 'materialiseVFT'.+data VirtualFileTree =+ VirtualFileTree+ { vftTree :: [FileTree]+ , vftOriginalRoot :: FilePath+ } deriving (Eq, Ord, Show)++data 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+ = Inline T.Text+ | Ref FilePath+ deriving (Show, Eq, Ord)++-- ----------------------------------------------------------------------------+-- API with side effects+-- ----------------------------------------------------------------------------++readFileFS :: FileSystem -> FilePath -> IO T.Text+readFileFS fs fp = do+ T.readFile (fsRoot fs </> FP.normalise fp)++writeFileFS :: FileSystem -> FilePath -> Content -> IO ()+writeFileFS fs fp content = do+ contents <- case content of+ Inline txt -> pure txt+ Ref path -> T.readFile (fsOriginalRoot fs </> FP.normalise path)+ T.writeFile (fsRoot fs </> FP.normalise fp) contents++-- | Materialise a virtual file tree in the 'rootDir' directory.+--+-- Synopsis: @'materialise' rootDir fileTree testDataDir@+--+-- File references in '[FileTree]' are resolved relative to the @testDataDir@.+materialise :: FilePath -> [FileTree] -> FilePath -> IO FileSystem+materialise rootDir' fileTree testDataDir' = do+ let testDataDir = FP.normalise testDataDir'+ rootDir = FP.normalise rootDir'++ persist :: FilePath -> FileTree -> IO ()+ 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++-- | Materialise a virtual file tree in the 'rootDir' directory.+--+-- Synopsis: @'materialiseVFT' rootDir virtualFileTree@+--+-- File references in 'virtualFileTree' are resolved relative to the @vftOriginalRoot@.+materialiseVFT :: FilePath -> VirtualFileTree -> IO FileSystem+materialiseVFT root fs = materialise root (vftTree fs) (vftOriginalRoot fs)++-- ----------------------------------------------------------------------------+-- Test definition helpers+-- ----------------------------------------------------------------------------++mkVirtualFileTree :: FilePath -> [FileTree] -> VirtualFileTree+mkVirtualFileTree testDataDir tree =+ VirtualFileTree+ { vftTree = tree+ , vftOriginalRoot = testDataDir+ }++toAbsFp :: FileSystem -> FilePath -> FilePath+toAbsFp fs fp = fsRoot fs </> FP.normalise fp++toNfp :: FileSystem -> FilePath -> NormalizedFilePath+toNfp fs fp =+ toNormalizedFilePath $ toAbsFp fs fp++-- ----------------------------------------------------------------------------+-- Builders+-- ----------------------------------------------------------------------------++-- | Create a file in the test project with some content.+--+-- Only the filename will be used, and any directory components are *not*+-- reflected in the test project.+file :: FilePath -> Content -> FileTree+file fp cts = File fp cts++-- | Copy a filepath into a test project. The name of the file is also used+-- in the test project.+--+-- The filepath is always resolved to the root of the test data dir.+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++-- | Write the given test directly into a file.+text :: T.Text -> Content+text = Inline++-- | Read the contents of the given file+-- The filepath is always resolved to the root of the test data dir.+ref :: FilePath -> Content+ref = Ref++-- ----------------------------------------------------------------------------+-- Cradle Helpers+-- ----------------------------------------------------------------------------++-- | Set up a simple direct cradle.+--+-- All arguments are added to the direct cradle file.+-- Arguments will not be escaped.+directCradle :: [T.Text] -> FileTree+directCradle args =+ file "hie.yaml"+ ( Inline $ T.unlines $+ [ "cradle:"+ , " direct:"+ , " arguments:"+ ] <>+ [ " - " <> arg | arg <- args]+ )++-- | Set up a simple cabal cradle.+--+-- Prefer simple cabal cradle, over custom multi cabal cradles if possible.+simpleCabalCradle :: FileTree+simpleCabalCradle =+ file "hie.yaml"+ (Inline $ T.unlines+ [ "cradle:"+ , " cabal:"+ ]+ )+++-- ----------------------------------------------------------------------------+-- Project setup builders+-- ----------------------------------------------------------------------------++-- | Set up a test project with a single haskell file.+directProject :: FilePath -> [FileTree]+directProject fp =+ [ directCradle [T.pack fp]+ , file fp (Ref fp)+ ]++-- | Set up a test project with multiple haskell files.+--+directProjectMulti :: [FilePath] -> [FileTree]+directProjectMulti fps =+ [ directCradle $ fmap T.pack fps+ ] <> fmap copy fps++-- | Set up a simple cabal cradle project and copy all the given filepaths+-- into the test directory.+simpleCabalProject :: [FilePath] -> [FileTree]+simpleCabalProject fps =+ [ simpleCabalCradle+ ] <> fmap copy fps++-- | Set up a simple cabal cradle project.+simpleCabalProject' :: [FileTree] -> [FileTree]+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,13 +1,14 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-} module Test.Hls.Util ( -- * Test Capabilities- codeActionSupportCaps+ codeActionResolveCaps+ , codeActionNoResolveCaps+ , codeActionNoInlayHintsCaps+ , codeActionSupportCaps , expectCodeAction -- * Environment specifications -- for ignoring tests@@ -20,6 +21,7 @@ , knownBrokenOnWindows , knownBrokenForGhcVersions , knownBrokenInEnv+ , knownBrokenInSpecificEnv , onlyWorkForGhcVersions -- * Extract code actions , fromAction@@ -28,14 +30,13 @@ , dontExpectCodeAction , expectDiagnostic , expectNoMoreDiagnostics- , expectSameLocations , failIfSessionTimeout , getCompletionByLabel , noLiteralCaps , inspectCodeAction , inspectCommand , inspectDiagnostic- , SymbolLocation+ , inspectDiagnosticAny , waitForDiagnosticsFrom , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout@@ -43,51 +44,77 @@ , 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 ((&), (?~), (^.))+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.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.Types hiding (Reason (..))-import qualified Language.LSP.Types.Capabilities as C-import Language.LSP.Types.Lens (textDocument)-import qualified Language.LSP.Types.Lens as L+import Data.List.Extra (find)+import Data.Proxy+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 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) -noLiteralCaps :: C.ClientCapabilities-noLiteralCaps = def & textDocument ?~ textDocumentCaps+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- textDocumentCaps = def { C._codeAction = Just codeActionCaps }+ textDocumentCaps = def { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing -codeActionSupportCaps :: C.ClientCapabilities-codeActionSupportCaps = def & textDocument ?~ textDocumentCaps+codeActionSupportCaps :: ClientCapabilities+codeActionSupportCaps = def & L.textDocument ?~ textDocumentCaps where- textDocumentCaps = def { C._codeAction = Just codeActionCaps }+ textDocumentCaps = def { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing- literalSupport = CodeActionLiteralSupport def+ literalSupport = ClientCodeActionLiteralOptions (ClientCodeActionKindOptions []) +codeActionResolveCaps :: ClientCapabilities+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.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 -- ---------------------------------------------------------------------@@ -108,12 +135,18 @@ | isMac = MacOS | otherwise = Linux --- | Mark as broken if /any/ of environmental spec mathces the current environment.+-- | Mark as broken if /any/ of the environmental specs matches the current environment. knownBrokenInEnv :: [EnvSpec] -> String -> TestTree -> TestTree knownBrokenInEnv envSpecs reason | any matchesCurrentEnv envSpecs = expectFailBecause reason | otherwise = id +-- | Mark as broken if /all/ environmental specs match the current environment.+knownBrokenInSpecificEnv :: [EnvSpec] -> String -> TestTree -> TestTree+knownBrokenInSpecificEnv envSpecs reason+ | all matchesCurrentEnv envSpecs = expectFailBecause reason+ | otherwise = id+ knownBrokenOnWindows :: String -> TestTree -> TestTree knownBrokenOnWindows = knownBrokenInEnv [HostOS Windows] @@ -215,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 @@ -243,8 +280,8 @@ waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic] waitForDiagnosticsFrom doc = do- diagsNot <- skipManyTill Test.anyMessage (Test.message STextDocumentPublishDiagnostics)- let (List diags) = diagsNot ^. L.params . L.diagnostics+ diagsNot <- skipManyTill Test.anyMessage (Test.message SMethod_TextDocumentPublishDiagnostics)+ let diags = diagsNot ^. L.params . L.diagnostics if doc ^. L.uri /= diagsNot ^. L.params . L.uri then waitForDiagnosticsFrom doc else return diags@@ -272,22 +309,22 @@ -- 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.- testId <- Test.sendRequest (SCustomMethod "test") A.Null+ testId <- Test.sendRequest (SMethod_CustomMethod (Proxy @"test")) A.Null handleMessages testId where matches :: Diagnostic -> Bool matches d = d ^. L.source == Just (T.pack source) - handleMessages testId = handleDiagnostic testId <|> handleCustomMethodResponse testId <|> ignoreOthers testId+ handleMessages testId = handleDiagnostic testId <|> handleMethod_CustomMethodResponse testId <|> ignoreOthers testId handleDiagnostic testId = do- diagsNot <- Test.message STextDocumentPublishDiagnostics+ diagsNot <- Test.message SMethod_TextDocumentPublishDiagnostics let fileUri = diagsNot ^. L.params . L.uri- (List 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- handleCustomMethodResponse testId = do- _ <- Test.responseForId (SCustomMethod "test") testId+ handleMethod_CustomMethodResponse testId = do+ _ <- Test.responseForId (SMethod_CustomMethod (Proxy @"test")) testId pure [] ignoreOthers testId = void Test.anyMessage >> handleMessages testId@@ -298,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 =@@ -330,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+ }