diff --git a/hls-test-utils.cabal b/hls-test-utils.cabal --- a/hls-test-utils.cabal +++ b/hls-test-utils.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-test-utils -version: 1.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 @@ -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 diff --git a/src/Development/IDE/Test.hs b/src/Development/IDE/Test.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Test.hs @@ -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 + diff --git a/src/Development/IDE/Test/Diagnostic.hs b/src/Development/IDE/Test/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Test/Diagnostic.hs @@ -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 diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -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 -- @ -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 + -- @ + -- + -- 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 diff --git a/src/Test/Hls/FileSystem.hs b/src/Test/Hls/FileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hls/FileSystem.hs @@ -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) diff --git a/src/Test/Hls/TestEnv.hs b/src/Test/Hls/TestEnv.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hls/TestEnv.hs @@ -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 diff --git a/src/Test/Hls/Util.hs b/src/Test/Hls/Util.hs --- a/src/Test/Hls/Util.hs +++ b/src/Test/Hls/Util.hs @@ -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 + }