hls-test-utils 2.8.0.0 → 2.9.0.0

raw patch · 6 files changed

+859/−258 lines, 6 filesdep +lspdep +neat-interpolationdep +text-ropedep −row-typesdep ~ghcidedep ~hls-plugin-apidep ~lsp-typesPVP ok

version bump matches the API change (PVP)

Dependencies added: lsp, neat-interpolation, text-rope

Dependencies removed: row-types

Dependency ranges changed: ghcide, hls-plugin-api, lsp-types

API changes (from Hackage documentation)

Files

• hls-test-utils.cabal +15/−6
• src/Development/IDE/Test.hs +259/−0
• src/Development/IDE/Test/Diagnostic.hs +47/−0
• src/Test/Hls.hs +363/−199
• src/Test/Hls/FileSystem.hs +26/−10
• src/Test/Hls/Util.hs +149/−43

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          hls-test-utils-version:       2.8.0.0+version:       2.9.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>@@ -29,6 +29,8 @@     Test.Hls     Test.Hls.Util     Test.Hls.FileSystem+    Development.IDE.Test+    Development.IDE.Test.Diagnostic    hs-source-dirs:   src   build-depends:@@ -41,11 +43,13 @@     , directory     , extra     , filepath-    , ghcide                  == 2.8.0.0-    , hls-plugin-api          == 2.8.0.0+    , ghcide                  == 2.9.0.0+    , hls-plugin-api          == 2.9.0.0     , lens+    , lsp     , lsp-test                ^>=0.17-    , lsp-types               ^>=2.1+    , lsp-types               ^>=2.3+    , neat-interpolation     , safe-exceptions     , tasty     , tasty-expected-failure@@ -54,8 +58,13 @@     , tasty-rerun     , temporary     , text-    , row-types-  ghc-options:      -Wall -Wunused-packages+    , text-rope++  ghc-options:+    -Wall+    -Wunused-packages+    -Wno-name-shadowing+    -Wno-unticked-promoted-constructors    if flag(pedantic)     ghc-options: -Werror

@@ -0,0 +1,259 @@+-- 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+  , 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++requireDiagnosticM+    :: (Foldable f, Show (f Diagnostic), HasCallStack)+    => f Diagnostic+    -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)+    -> 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, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()+expectDiagnostics+  = expectDiagnosticsWithTags+  . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing))))++unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics  -> (Uri, [Diagnostic])+unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics)++expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session ()+expectDiagnosticsWithTags expected = do+    let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri+        next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic+    expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected+    expectDiagnosticsWithTags' next expected'++expectDiagnosticsWithTags' ::+  (HasCallStack, MonadIO m) =>+  m (Uri, [Diagnostic]) ->+  Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] ->+  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 -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session ()+expectCurrentDiagnostics doc expected = do+    diags <- getCurrentDiagnostics doc+    checkDiagnosticsForDoc doc expected diags++checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session ()+checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do+    let expected' = Map.singleton nuri (map (\(ds, c, t) -> (ds, c, t, Nothing)) 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+

@@ -0,0 +1,47 @@+module Development.IDE.Test.Diagnostic where++import           Control.Lens                ((^.))+import qualified Data.Text                   as T+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++requireDiagnostic+    :: (Foldable f, Show (f Diagnostic), HasCallStack)+    => f Diagnostic+    -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)+    -> Maybe ErrorMsg+requireDiagnostic actuals expected@(severity, cursor, expectedMsg, 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)++    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

@@ -4,6 +4,9 @@ {-# LANGUAGE LambdaCase            #-} {-# LANGUAGE OverloadedLists       #-} {-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-} module Test.Hls   ( module Test.Tasty.HUnit,     module Test.Tasty,@@ -25,14 +28,14 @@     goldenWithHaskellDocFormatterInTmpDir,     goldenWithCabalDocFormatter,     goldenWithCabalDocFormatterInTmpDir,+    goldenWithTestConfig,     def,     -- * Running HLS for integration tests     runSessionWithServer,-    runSessionWithServerAndCaps,     runSessionWithServerInTmpDir,-    runSessionWithServerAndCapsInTmpDir,-    runSessionWithServer',-    runSessionWithServerInTmpDir',+    runSessionWithTestConfig,+    -- * Running parameterised tests for a set of test configurations+    parameterisedCursorTest,     -- * Helpful re-exports     PluginDescriptor,     IdeState,@@ -40,6 +43,7 @@     waitForProgressDone,     waitForAllProgressDone,     waitForBuildQueue,+    waitForProgressBegin,     waitForTypecheck,     waitForAction,     hlsConfigToClientConfig,@@ -49,7 +53,7 @@     waitForKickStart,     -- * Plugin descriptor helper functions for tests     PluginTestDescriptor,-    pluginTestRecorder,+    hlsPluginTestRecorder,     mkPluginTestDescriptor,     mkPluginTestDescriptor',     -- * Re-export logger types@@ -57,67 +61,81 @@     WithPriority(..),     Recorder,     Priority(..),+    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.Safe-import           Control.Lens.Extras                (is)-import           Control.Monad                      (guard, unless, void)-import           Control.Monad.Extra                (forM)+import           Control.Lens.Extras                      (is)+import           Control.Monad                            (guard, unless, void)+import           Control.Monad.Extra                      (forM) import           Control.Monad.IO.Class-import           Data.Aeson                         (Result (Success),-                                                     Value (Null), fromJSON,-                                                     toJSON)-import qualified Data.Aeson                         as A-import           Data.ByteString.Lazy               (ByteString)-import           Data.Default                       (def)-import qualified Data.Map                           as M-import           Data.Maybe                         (fromMaybe)-import           Data.Proxy                         (Proxy (Proxy))-import qualified Data.Text                          as T-import qualified Data.Text.Lazy                     as TL-import qualified Data.Text.Lazy.Encoding            as TL-import           Development.IDE                    (IdeState,-                                                     LoggingColumn (ThreadIdColumn))-import           Development.IDE.Main               hiding (Log)-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           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)+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.TypeLits-import           Ide.Logger                         (Pretty (pretty),-                                                     Priority (..), Recorder,-                                                     WithPriority (WithPriority, priority),-                                                     cfilter, cmapWithPrio,-                                                     defaultLoggingColumns,-                                                     logWith,-                                                     makeDefaultStderrRecorder,-                                                     (<+>))+import           Ide.Logger                               (Pretty (pretty),+                                                           Priority (..),+                                                           Recorder,+                                                           WithPriority (WithPriority, priority),+                                                           cfilter,+                                                           cmapWithPrio,+                                                           defaultLoggingColumns,+                                                           logWith,+                                                           makeDefaultStderrRecorder,+                                                           (<+>))+import qualified Ide.Logger                               as Logger+import           Ide.PluginUtils                          (idePluginsToPluginDesc,+                                                           pluginDescToIdePlugins) import           Ide.Types import           Language.LSP.Protocol.Capabilities import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types        hiding (Null)+import qualified Language.LSP.Protocol.Message            as LSP+import           Language.LSP.Protocol.Types              hiding (Null)+import qualified Language.LSP.Server                      as LSP import           Language.LSP.Test-import           Prelude                            hiding (log)-import           System.Directory                   (createDirectoryIfMissing,-                                                     getCurrentDirectory,-                                                     getTemporaryDirectory,-                                                     setCurrentDirectory)-import           System.Environment                 (lookupEnv, setEnv)+import           Prelude                                  hiding (log)+import           System.Directory                         (canonicalizePath,+                                                           createDirectoryIfMissing,+                                                           getCurrentDirectory,+                                                           getTemporaryDirectory,+                                                           makeAbsolute,+                                                           setCurrentDirectory)+import           System.Environment                       (lookupEnv, setEnv) import           System.FilePath-import           System.IO.Extra                    (newTempDirWithin)-import           System.IO.Unsafe                   (unsafePerformIO)-import           System.Process.Extra               (createPipe)+import           System.IO.Extra                          (newTempDirWithin)+import           System.IO.Unsafe                         (unsafePerformIO)+import           System.Process.Extra                     (createPipe) import           System.Time.Extra-import qualified Test.Hls.FileSystem                as FS+import qualified Test.Hls.FileSystem                      as FS import           Test.Hls.FileSystem import           Test.Hls.Util-import           Test.Tasty                         hiding (Timeout)+import           Test.Tasty                               hiding (Timeout) import           Test.Tasty.ExpectedFailure import           Test.Tasty.Golden import           Test.Tasty.HUnit@@ -165,7 +183,7 @@   -> FilePath   -> (TextDocumentIdentifier -> Session ())   -> TestTree-goldenWithHaskellDoc = goldenWithDoc "haskell"+goldenWithHaskellDoc = goldenWithDoc LanguageKind_Haskell  goldenWithHaskellDocInTmpDir   :: Pretty b@@ -178,7 +196,7 @@   -> FilePath   -> (TextDocumentIdentifier -> Session ())   -> TestTree-goldenWithHaskellDocInTmpDir = goldenWithDocInTmpDir "haskell"+goldenWithHaskellDocInTmpDir = goldenWithDocInTmpDir LanguageKind_Haskell  goldenWithHaskellAndCaps   :: Pretty b@@ -194,7 +212,14 @@   -> TestTree goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ext act =   goldenGitDiff title (testDataDir </> path <.> desc <.> ext)-  $ runSessionWithServerAndCaps config plugin clientCaps testDataDir+  $ runSessionWithTestConfig def {+    testDirLocation = Left testDataDir,+    testConfigCaps = clientCaps,+    testLspConfig = config,+    testPluginDescriptor = plugin+  }+  $ const+--   runSessionWithServerAndCaps config plugin clientCaps testDataDir   $ TL.encodeUtf8 . TL.fromStrict   <$> do     doc <- openDoc (path <.> ext) "haskell"@@ -202,6 +227,26 @@     act doc     documentContents doc +goldenWithTestConfig+  :: Pretty b+  => TestConfig b+  -> TestName+  -> FilePath+  -> FilePath+  -> FilePath+  -> FilePath+  -> (TextDocumentIdentifier -> Session ())+  -> TestTree+goldenWithTestConfig config title testDataDir path desc ext act =+  goldenGitDiff title (testDataDir </> 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@@ -216,7 +261,13 @@   -> TestTree goldenWithHaskellAndCapsInTmpDir config clientCaps plugin title tree path desc ext act =   goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)-  $ runSessionWithServerAndCapsInTmpDir config plugin clientCaps tree+  $+  runSessionWithTestConfig def {+    testDirLocation = Right tree,+    testConfigCaps = clientCaps,+    testLspConfig = config,+    testPluginDescriptor = plugin+  } $ const   $ TL.encodeUtf8 . TL.fromStrict   <$> do     doc <- openDoc (path <.> ext) "haskell"@@ -235,11 +286,11 @@   -> FilePath   -> (TextDocumentIdentifier -> Session ())   -> TestTree-goldenWithCabalDoc = goldenWithDoc "cabal"+goldenWithCabalDoc = goldenWithDoc (LanguageKind_Custom "cabal")  goldenWithDoc   :: Pretty b-  => T.Text+  => LanguageKind   -> Config   -> PluginTestDescriptor b   -> TestName@@ -249,19 +300,19 @@   -> FilePath   -> (TextDocumentIdentifier -> Session ())   -> TestTree-goldenWithDoc fileType config plugin title testDataDir path desc ext act =+goldenWithDoc languageKind config plugin title testDataDir path desc ext act =   goldenGitDiff title (testDataDir </> path <.> desc <.> ext)   $ runSessionWithServer config plugin testDataDir   $ TL.encodeUtf8 . TL.fromStrict   <$> do-    doc <- openDoc (path <.> ext) fileType+    doc <- openDoc (path <.> ext) languageKind     void waitForBuildQueue     act doc     documentContents doc  goldenWithDocInTmpDir   :: Pretty b-  => T.Text+  => LanguageKind   -> Config   -> PluginTestDescriptor b   -> TestName@@ -271,16 +322,66 @@   -> FilePath   -> (TextDocumentIdentifier -> Session ())   -> TestTree-goldenWithDocInTmpDir fileType config plugin title tree path desc ext act =+goldenWithDocInTmpDir languageKind config plugin title tree path desc ext act =   goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)   $ runSessionWithServerInTmpDir config plugin tree   $ TL.encodeUtf8 . TL.fromStrict   <$> do-    doc <- openDoc (path <.> ext) fileType+    doc <- openDoc (path <.> ext) languageKind     void waitForBuildQueue     act doc     documentContents doc +-- | A parameterised test is similar to a normal test case but allows to run+-- the same test case multiple times with different inputs.+-- A 'parameterisedCursorTest' allows to define a test case based on an input file+-- that specifies one or many cursor positions via the identification value '^'.+--+-- For example:+--+-- @+--  parameterisedCursorTest "Cursor Test" [trimming|+--       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 'trimming' 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 :: (Show a, Eq a) => String -> T.Text -> [a] -> (T.Text -> PosPrefixInfo -> IO a) -> TestTree+parameterisedCursorTest 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, (expected, info)) = testCase (title <> " " <> show n) $ do+      actual <- act cleanText info+      assertEqual (mkParameterisedLabel info) expected actual+ -- ------------------------------------------------------------ -- Helper function for initialising plugins under test -- ------------------------------------------------------------@@ -319,10 +420,29 @@   -> PluginTestDescriptor b mkPluginTestDescriptor' pluginDesc plId _recorder = IdePlugins [pluginDesc plId] --- | Initialise a recorder that can be instructed to write to stderr by--- setting the environment variable "HLS_TEST_PLUGIN_LOG_STDERR=1" before--- running the tests.+-- | Initialize a recorder that can be instructed to write to stderr by+-- setting one of the environment variables: --+-- * HLS_TEST_HARNESS_STDERR=1+-- * HLS_TEST_LOG_STDERR=1+--+-- "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins+-- under test.+hlsHelperTestRecorder :: Pretty a => IO (Recorder (WithPriority a))+hlsHelperTestRecorder = initializeTestRecorder ["HLS_TEST_HARNESS_STDERR", "HLS_TEST_LOG_STDERR"]+++-- | Initialize a recorder that can be instructed to write to stderr by+-- setting one of the environment variables:+--+-- * HLS_TEST_PLUGIN_LOG_STDERR=1+-- * HLS_TEST_LOG_STDERR=1+--+-- before running the tests.+--+-- "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins+-- under test.+-- -- On the cli, use for example: -- -- @@@ -334,11 +454,10 @@ -- @ --   HLS_TEST_LOG_STDERR=1 cabal test <test-suite-of-plugin> -- @-pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a))-pluginTestRecorder = do-  initialiseTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "HLS_TEST_LOG_STDERR"]+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@.@@ -347,11 +466,12 @@ -- -- 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))-initialiseTestRecorder envVars = do+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 =@@ -364,87 +484,62 @@ -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ -runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a-runSessionWithServer config plugin fp act = do-  recorder <- pluginTestRecorder-  runSessionWithServer' (plugin recorder) config def fullCaps fp act--runSessionWithServerAndCaps :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a-runSessionWithServerAndCaps config plugin caps fp act = do-  recorder <- pluginTestRecorder-  runSessionWithServer' (plugin recorder) config def caps fp act- runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a-runSessionWithServerInTmpDir config plugin tree act = do-  recorder <- pluginTestRecorder-  runSessionWithServerInTmpDir' (plugin recorder) config def fullCaps tree act+runSessionWithServerInTmpDir config plugin tree act =+    runSessionWithTestConfig def+    {testLspConfig=config, testPluginDescriptor = plugin,  testDirLocation=Right tree}+    (const act) -runSessionWithServerAndCapsInTmpDir :: Pretty b => Config ->  PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a-runSessionWithServerAndCapsInTmpDir config plugin caps tree act = do-  recorder <- pluginTestRecorder-  runSessionWithServerInTmpDir' (plugin recorder) config def caps tree act+runWithLockInTempDir :: VirtualFileTree -> (FileSystem -> IO a) ->  IO a+runWithLockInTempDir tree 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, _) <- newTempDirWithin testRoot+                a <- action tempDir+                logWith helperRecorder Debug LogNoCleanup+                pure a --- | Host a server, and run a test session on it.------ Creates a temporary directory, and materializes the VirtualFileTree--- in the temporary directory.------ To debug test cases and verify the file system is correctly set up,--- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'.--- Further, we log the temporary directory location on startup. To view--- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'.------ Example invocation to debug test cases:------ @---   HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test <plugin-name>--- @------ Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests.------ For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'.------ Note: cwd will be shifted into a temporary directory in @Session a@-runSessionWithServerInTmpDir' ::-  -- | Plugins to load on the server.-  ---  -- For improved logging, make sure these plugins have been initalised with-  -- the recorder produced by @pluginTestRecorder@.-  IdePlugins IdeState ->-  -- | lsp config for the server-  Config ->-  -- | config for the test session-  SessionConfig ->-  ClientCapabilities ->-  VirtualFileTree ->-  Session a ->-  IO a-runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = withLock lockForTempDirs $ do-  testRoot <- setupTestEnvironment-  recorder <- initialiseTestRecorder-    ["LSP_TEST_LOG_STDERR", "HLS_TEST_HARNESS_STDERR", "HLS_TEST_LOG_STDERR"]+            _ -> do+                (tempDir, cleanup) <- newTempDirWithin testRoot+                a <- 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+        -- cannibalization during the test when we compare two paths+        tmpDir <- canonicalizePath tmpDir'+        logWith helperRecorder Info $ LogTestDir tmpDir+        fs <- FS.materialiseVFT tmpDir tree+        act fs -  -- 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, _) <- newTempDirWithin testRoot-            a <- action tempDir-            logWith recorder Debug LogNoCleanup-            pure a+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) -        _ -> do-          (tempDir, cleanup) <- newTempDirWithin testRoot-          a <- action tempDir `finally` cleanup-          logWith recorder Debug LogCleanup-          pure a -  runTestInDir $ \tmpDir -> do-    logWith recorder Info $ LogTestDir tmpDir-    _fs <- FS.materialiseVFT tmpDir tree-    runSessionWithServer' plugins conf sessConf caps tmpDir 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. --@@ -577,61 +672,93 @@ lockForTempDirs :: Lock lockForTempDirs = unsafePerformIO newLock --- | Host a server, and run a test session on it--- Note: cwd will be shifted into @root@ in @Session a@-runSessionWithServer' ::-  -- | Plugins to load on the server.-  ---  -- For improved logging, make sure these plugins have been initalised with-  -- the recorder produced by @pluginTestRecorder@.-  IdePlugins IdeState ->-  -- | lsp config for the server-  Config ->-  -- | config for the test session-  SessionConfig ->-  ClientCapabilities ->-  FilePath ->-  Session a ->-  IO a-runSessionWithServer' plugins conf sconf caps root s =  withLock lock $ keepCurrentDirectory $ do-    (inR, inW) <- createPipe-    (outR, outW) <- createPipe+data TestConfig b = TestConfig+  {+    testDirLocation          :: Either FilePath VirtualFileTree+    -- ^ Client capabilities+    -- ^ The file tree to use for the test, either a directory or a virtual file tree+    -- if using a virtual file tree,+    -- Creates a temporary directory, and materializes the VirtualFileTree+    -- in the temporary directory.+    --+    -- To debug test cases and verify the file system is correctly set up,+    -- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'.+    -- Further, we log the temporary directory location on startup. To view+    -- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'.+    -- Example invocation to debug test cases:+    --+    -- @+    --   HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test <plugin-name>+    -- @+    --+    -- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests.+    --+    -- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'.+  , testShiftRoot            :: Bool+    -- ^ Whether to shift the current directory to the root of the project+  , testClientRoot           :: Maybe FilePath+    -- ^ Specify the root of (the client or LSP context),+    -- if Nothing it is the same as the testDirLocation+    -- if Just, it is subdirectory of the testDirLocation+  , testServerRoot           :: Maybe FilePath+    -- ^ Specify root of the server, in exe, it can be specify in command line --cwd,+    -- or just the server start directory+    -- if Nothing it is the same as the testDirLocation+    -- if Just, it is subdirectory of the testDirLocation+  , testDisableKick          :: Bool+    -- ^ Whether to disable the kick action+  , testDisableDefaultPlugin :: Bool+    -- ^ Whether to disable the default plugin comes with ghcide+  , testCheckProject         :: Bool+    -- ^ Whether to typecheck check the project after the session is loaded+  , testPluginDescriptor     :: PluginTestDescriptor b+    -- ^ Plugin to load on the server.+  , testLspConfig            :: Config+    -- ^ lsp config for the server+  , testConfigSession        :: SessionConfig+    -- ^ config for the test session+  , testConfigCaps           :: ClientCapabilities+    -- ^ Client capabilities+  } -    -- Allow three environment variables, because "LSP_TEST_LOG_STDERR" has been used before,-    -- (thus, backwards compatibility) and "HLS_TEST_SERVER_LOG_STDERR" because it-    -- uses a more descriptive name.-    -- It is also in better accordance with 'pluginTestRecorder' which uses "HLS_TEST_PLUGIN_LOG_STDERR".-    -- At last, "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins-    -- under test.-    recorder <- initialiseTestRecorder-      ["LSP_TEST_LOG_STDERR", "HLS_TEST_SERVER_LOG_STDERR", "HLS_TEST_LOG_STDERR"] -    let-        sconf' = sconf { lspConfig = hlsConfigToClientConfig conf }--        hlsPlugins = IdePlugins [Test.blockCommandDescriptor "block-command"] <> plugins+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) -        arguments@Arguments{ argsIdeOptions } =-            testing (cmapWithPrio LogIDEMain recorder) hlsPlugins+-- | Host a server, and run a test session on it.+-- For setting custom timeout, set the environment variable 'LSP_TIMEOUT'+-- * LSP_TIMEOUT=10 cabal test+-- 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+    (inR, inW) <- createPipe+    (outR, outW) <- createPipe+    let serverRoot = fromMaybe root testServerRoot+    let clientRoot = fromMaybe root testClientRoot -        ideOptions config ghcSession =-            let defIdeOptions = argsIdeOptions config ghcSession-            in defIdeOptions-                    { optTesting = IdeTesting True-                    , optCheckProject = pure False-                    }+    (recorder, cb1) <- wrapClientLogger =<< hlsPluginTestRecorder+    (recorderIde, cb2) <- wrapClientLogger =<< 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     server <- async $-        IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder)-            arguments-                { argsHandleIn = pure inR-                , argsHandleOut = pure outW-                , argsDefaultHlsConfig = conf-                , argsIdeOptions = ideOptions-                , argsProjectRoot = Just root-                }--    x <- runSessionWithHandles inW outR sconf' caps root s+        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 ()@@ -639,8 +766,45 @@             putStrLn "Server does not exit in 3s, canceling the async task..."             (t, _) <- duration $ cancel server             putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)"-    pure x+    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+            act root+        runSessionInVFS (Right vfs) act = runWithLockInTempDir vfs $ \fs -> 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+                }++-- | 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@@ -670,7 +834,7 @@         -- assume a ghcide binary lacking the WaitForShakeQueue method         _                                    -> return 0 -callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)+callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) b) callTestPlugin cmd = do     let cm = SMethod_CustomMethod (Proxy @"test")     waitId <- sendRequest cm (A.toJSON cmd)@@ -678,17 +842,17 @@     return $ do       e <- _result       case A.fromJSON e of-        A.Error err -> Left $ ResponseError (InR ErrorCodes_InternalError) (T.pack err) Nothing+        A.Error err -> Left $ TResponseError (InR ErrorCodes_InternalError) (T.pack err) Nothing         A.Success a -> pure a -waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)+waitForAction :: String -> TextDocumentIdentifier -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) WaitForIdeRuleResult) waitForAction key TextDocumentIdentifier{_uri} =     callTestPlugin (WaitForIdeRule key _uri) -waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool)+waitForTypecheck :: TextDocumentIdentifier -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) Bool) waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid -getLastBuildKeys :: Session (Either ResponseError [T.Text])+getLastBuildKeys :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text]) getLastBuildKeys = callTestPlugin GetBuildKeysBuilt  hlsConfigToClientConfig :: Config -> A.Object

@@ -20,6 +20,7 @@   , directory   , text   , ref+  , copyDir   -- * Cradle helpers   , directCradle   , simpleCabalCradle@@ -37,6 +38,7 @@ import           Language.LSP.Protocol.Types (toNormalizedFilePath) import           System.Directory import           System.FilePath             as FP+import           System.Process.Extra        (readProcess)  -- ---------------------------------------------------------------------------- -- Top Level definitions@@ -64,8 +66,9 @@     } deriving (Eq, Ord, Show)  data FileTree-  = File FilePath Content-  | Directory FilePath [FileTree]+  = File FilePath Content -- ^ Create a file with the given content.+  | Directory FilePath [FileTree] -- ^ Create a directory with the given files.+  | CopiedDirectory FilePath -- ^ Copy a directory from the test data dir.   deriving (Show, Eq, Ord)  data Content@@ -99,13 +102,22 @@       rootDir = FP.normalise rootDir'        persist :: FilePath -> FileTree -> IO ()-      persist fp (File name cts) = case cts of-        Inline txt -> T.writeFile (fp </> name) txt-        Ref path -> copyFile (testDataDir </> FP.normalise path) (fp </> takeFileName name)-      persist fp (Directory name nodes) = do-        createDirectory (fp </> name)-        mapM_ (persist (fp </> name)) nodes+      persist root (File name cts) = case cts of+        Inline txt -> T.writeFile (root </> name) txt+        Ref path -> copyFile (testDataDir </> FP.normalise path) (root </> takeFileName name)+      persist root (Directory name nodes) = do+        createDirectory (root </> name)+        mapM_ (persist (root </> name)) nodes+      persist root (CopiedDirectory name) = do+        copyDir' root name +      copyDir' :: FilePath -> FilePath -> IO ()+      copyDir' root dir = do+        files <- fmap FP.normalise . lines <$> withCurrentDirectory (testDataDir </> dir) (readProcess "git" ["ls-files", "--cached", "--modified", "--others"] "")+        mapM_ (createDirectoryIfMissing True . ((root </>) . takeDirectory)) files+        mapM_ (\f -> copyFile (testDataDir </> dir </> f) (root </> f)) files+        return ()+   traverse_ (persist rootDir) fileTree   pure $ FileSystem rootDir fileTree testDataDir @@ -115,8 +127,7 @@ -- -- File references in 'virtualFileTree' are resolved relative to the @vftOriginalRoot@. materialiseVFT :: FilePath -> VirtualFileTree -> IO FileSystem-materialiseVFT root fs =-  materialise root (vftTree fs) (vftOriginalRoot fs)+materialiseVFT root fs = materialise root (vftTree fs) (vftOriginalRoot fs)  -- ---------------------------------------------------------------------------- -- Test definition helpers@@ -153,6 +164,11 @@ -- 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

@@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds             #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs                 #-}-{-# LANGUAGE OverloadedLabels      #-} {-# LANGUAGE OverloadedStrings     #-} module Test.Hls.Util   (  -- * Test Capabilities@@ -30,14 +29,12 @@     , dontExpectCodeAction     , expectDiagnostic     , expectNoMoreDiagnostics-    , expectSameLocations     , failIfSessionTimeout     , getCompletionByLabel     , noLiteralCaps     , inspectCodeAction     , inspectCommand     , inspectDiagnostic-    , SymbolLocation     , waitForDiagnosticsFrom     , waitForDiagnosticsFromSource     , waitForDiagnosticsFromSourceWithTimeout@@ -45,39 +42,49 @@     , withCurrentDirectoryInTmp     , withCurrentDirectoryInTmp'     , withCanonicalTempDir+    -- * Extract positions from input file.+    , extractCursorPositions+    , mkParameterisedLabel+    , trimming   ) where -import           Control.Applicative.Combinators (skipManyTill, (<|>))-import           Control.Exception               (catch, throwIO)-import           Control.Lens                    (_Just, (&), (.~), (?~), (^.))+import           Control.Applicative.Combinators          (skipManyTill, (<|>))+import           Control.Exception                        (catch, throwIO)+import           Control.Lens                             (_Just, (&), (.~),+                                                           (?~), (^.)) import           Control.Monad import           Control.Monad.IO.Class-import qualified Data.Aeson                      as A-import           Data.Bool                       (bool)+import qualified Data.Aeson                               as A+import           Data.Bool                                (bool) import           Data.Default-import           Data.List.Extra                 (find)+import           Data.List.Extra                          (find) import           Data.Proxy-import           Data.Row-import qualified Data.Set                        as Set-import qualified Data.Text                       as T-import           Development.IDE                 (GhcVersion (..), ghcVersion)-import qualified Language.LSP.Protocol.Lens      as L+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 qualified Language.LSP.Test                        as Test import           System.Directory import           System.FilePath-import           System.Info.Extra               (isMac, isWindows)+import           System.Info.Extra                        (isMac, isWindows) import qualified System.IO.Extra import           System.IO.Temp-import           System.Time.Extra               (Seconds, sleep)-import           Test.Tasty                      (TestTree)-import           Test.Tasty.ExpectedFailure      (expectFailBecause,-                                                  ignoreTestBecause)-import           Test.Tasty.HUnit                (Assertion, assertFailure,-                                                  (@?=))+import           System.Time.Extra                        (Seconds, sleep)+import           Test.Tasty                               (TestTree)+import           Test.Tasty.ExpectedFailure               (expectFailBecause,+                                                           ignoreTestBecause)+import           Test.Tasty.HUnit                         (assertFailure) +import qualified Data.List                                as List+import 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 (..))+import           NeatInterpolation                        (trimming)+ noLiteralCaps :: ClientCapabilities noLiteralCaps = def & L.textDocument ?~ textDocumentCaps   where@@ -89,15 +96,15 @@   where     textDocumentCaps = def { _codeAction = Just codeActionCaps }     codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing-    literalSupport = #codeActionKind .==  (#valueSet .== [])+    literalSupport = ClientCodeActionLiteralOptions (ClientCodeActionKindOptions [])  codeActionResolveCaps :: ClientCapabilities-codeActionResolveCaps = Test.fullCaps-                          & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ (#properties .== ["edit"])+codeActionResolveCaps = Test.fullLatestClientCaps+                          & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ ClientCodeActionResolveOptions {_properties= ["edit"]}                           & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ True  codeActionNoResolveCaps :: ClientCapabilities-codeActionNoResolveCaps = Test.fullCaps+codeActionNoResolveCaps = Test.fullLatestClientCaps                           & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing                           & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False -- ---------------------------------------------------------------------@@ -316,23 +323,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 =@@ -348,3 +338,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+    }