hls-test-utils 1.0.0.0 → 1.0.1.0
raw patch · 3 files changed
+136/−45 lines, 3 filesdep +hls-graphdep −shakedep ~ghcidenew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: hls-graph
Dependencies removed: shake
Dependency ranges changed: ghcide
API changes (from Hackage documentation)
+ Test.Hls: goldenWithHaskellDoc :: PluginDescriptor IdeState -> TestName -> FilePath -> FilePath -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
+ Test.Hls: goldenWithHaskellDocFormatter :: PluginDescriptor IdeState -> String -> TestName -> FilePath -> FilePath -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
+ Test.Hls: waitForProgressDone :: Session ()
+ Test.Hls.Util: withCurrentDirectoryInTmp' :: [FilePath] -> FilePath -> IO a -> IO a
Files
- hls-test-utils.cabal +5/−5
- src/Test/Hls.hs +61/−3
- src/Test/Hls/Util.hs +70/−37
hls-test-utils.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-test-utils-version: 1.0.0.0+version: 1.0.1.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>@@ -33,7 +33,7 @@ build-depends: , aeson , async- , base >=4.12 && <5+ , base >=4.12 && <5 , blaze-markup , bytestring , containers@@ -41,15 +41,15 @@ , directory , extra , filepath- , ghcide ^>=1.2+ , ghcide ^>=1.4+ , hls-graph , hls-plugin-api ^>=1.1- , hspec+ , hspec <2.8 , hspec-core , lens , lsp ^>=1.2 , lsp-test ==0.14.0.0 , lsp-types ^>=1.2- , shake , tasty , tasty-expected-failure , tasty-golden
src/Test/Hls.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty,@@ -10,10 +12,13 @@ module Control.Applicative.Combinators, defaultTestRunner, goldenGitDiff,+ goldenWithHaskellDoc,+ goldenWithHaskellDocFormatter, def, runSessionWithServer, runSessionWithServerFormatter, runSessionWithServer',+ waitForProgressDone, PluginDescriptor, IdeState, )@@ -23,17 +28,20 @@ import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Base+import Control.Monad (unless) import Control.Monad.IO.Class import Data.ByteString.Lazy (ByteString) import Data.Default (def) import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL import Development.IDE (IdeState, hDuplicateTo', noLogging)+import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main import qualified Development.IDE.Main as Ghcide import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Development.IDE.Types.Options-import Development.Shake (ShakeOptions (shakeThreads)) import GHC.IO.Handle import Ide.Plugin.Config (Config, formattingProvider) import Ide.PluginUtils (pluginDescToIdePlugins)@@ -43,6 +51,7 @@ import Language.LSP.Types.Capabilities (ClientCapabilities) import System.Directory (getCurrentDirectory, setCurrentDirectory)+import System.FilePath import System.IO.Extra import System.IO.Unsafe (unsafePerformIO) import System.Process.Extra (createPipe)@@ -59,11 +68,48 @@ defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000) gitDiff :: FilePath -> FilePath -> [String]-gitDiff fRef fNew = ["git", "diff", "--no-index", "--text", "--exit-code", fRef, fNew]+gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "--no-index", "--text", "--exit-code", fRef, fNew] goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree goldenGitDiff name = goldenVsStringDiff name gitDiff +goldenWithHaskellDoc+ :: PluginDescriptor IdeState+ -> TestName+ -> FilePath+ -> FilePath+ -> FilePath+ -> FilePath+ -> (TextDocumentIdentifier -> Session ())+ -> TestTree+goldenWithHaskellDoc plugin title testDataDir path desc ext act =+ goldenGitDiff title (testDataDir </> path <.> desc <.> ext)+ $ runSessionWithServer plugin testDataDir+ $ TL.encodeUtf8 . TL.fromStrict+ <$> do+ doc <- openDoc (path <.> ext) "haskell"+ act doc+ documentContents doc++goldenWithHaskellDocFormatter+ :: PluginDescriptor IdeState+ -> String+ -> TestName+ -> FilePath+ -> FilePath+ -> FilePath+ -> FilePath+ -> (TextDocumentIdentifier -> Session ())+ -> TestTree+goldenWithHaskellDocFormatter plugin formatter title testDataDir path desc ext act =+ goldenGitDiff title (testDataDir </> path <.> desc <.> ext)+ $ runSessionWithServerFormatter plugin formatter testDataDir+ $ TL.encodeUtf8 . TL.fromStrict+ <$> do+ doc <- openDoc (path <.> ext) "haskell"+ act doc+ documentContents doc+ runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps @@ -134,3 +180,15 @@ (t, _) <- duration $ cancel server putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" pure x++-- | Wait for all progress to be done+-- Needs at least one progress done notification to return+waitForProgressDone :: Session ()+waitForProgressDone = loop+ where+ loop = do+ () <- skipManyTill anyMessage $ satisfyMaybe $ \case+ FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()+ _ -> Nothing+ done <- null <$> getIncompleteProgressSessions+ unless done loop
src/Test/Hls/Util.hs view
@@ -1,5 +1,11 @@-{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns, MultiParamTypeClasses, DuplicateRecordFields, TypeOperators, GADTs #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-} module Test.Hls.Util ( codeActionSupportCaps@@ -29,38 +35,41 @@ , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout , withCurrentDirectoryInTmp+ , withCurrentDirectoryInTmp' ) where -import qualified Data.Aeson as A-import Control.Exception (throwIO, catch)+import Control.Applicative.Combinators (skipManyTill, (<|>))+import Control.Exception (catch, throwIO)+import Control.Lens ((^.)) import Control.Monad import Control.Monad.IO.Class-import Control.Applicative.Combinators (skipManyTill, (<|>))-import Control.Lens ((^.))+import qualified Data.Aeson as A import Data.Default-import Data.List (intercalate)-import Data.List.Extra (find)+import Data.List (intercalate)+import Data.List.Extra (find) import Data.Maybe-import qualified Data.Set as Set-import qualified Data.Text as T-import Language.LSP.Types hiding (Reason(..))-import qualified Language.LSP.Test as Test-import qualified Language.LSP.Types.Lens as L+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Language.LSP.Test as Test+import Language.LSP.Types hiding (Reason (..)) import qualified Language.LSP.Types.Capabilities as C+import qualified Language.LSP.Types.Lens as L import System.Directory import System.Environment-import System.Time.Extra (Seconds, sleep) import System.FilePath import System.IO.Temp+import System.Info.Extra (isMac, isWindows)+import System.Time.Extra (Seconds, sleep)+import Test.Hspec.Core.Formatters hiding (Seconds) import Test.Hspec.Runner-import Test.Hspec.Core.Formatters hiding (Seconds)-import Test.Tasty (TestTree)-import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause)-import Test.Tasty.HUnit (Assertion, assertFailure, (@?=))-import Text.Blaze.Renderer.String (renderMarkup)-import Text.Blaze.Internal hiding (null)-import System.Info.Extra (isWindows, isMac)+import Test.Tasty (TestTree)+import Test.Tasty.ExpectedFailure (expectFailBecause,+ ignoreTestBecause)+import Test.Tasty.HUnit (Assertion, assertFailure,+ (@?=))+import Text.Blaze.Internal hiding (null)+import Text.Blaze.Renderer.String (renderMarkup) codeActionSupportCaps :: C.ClientCapabilities codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps }@@ -120,7 +129,7 @@ deriving (Show, Eq) matchesCurrentEnv :: EnvSpec -> Bool-matchesCurrentEnv (HostOS os) = hostOS == os+matchesCurrentEnv (HostOS os) = hostOS == os matchesCurrentEnv (GhcVer ver) = ghcVersion == ver data OS = Windows | MacOS | Linux@@ -229,7 +238,7 @@ writeLine $ renderMarkup $ testcase path $ case reason of Just desc -> skipped ! message desc $ ""- Nothing -> skipped ""+ Nothing -> skipped "" failure, skipped :: Markup -> Markup failure = customParent "failure"@@ -269,20 +278,45 @@ -- | Like 'withCurrentDirectory', but will copy the directory over to the system -- temporary directory first to avoid haskell-language-server's source tree from--- interfering with the cradle+-- interfering with the cradle.+--+-- Ignores directories containing build artefacts to avoid interference and+-- provide reproducible test-behaviour. withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a withCurrentDirectoryInTmp dir f =- withTempCopy dir $ \newDir ->+ withTempCopy ignored dir $ \newDir -> withCurrentDirectory newDir f+ where+ ignored = ["dist", "dist-newstyle", ".stack-work"] -withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a-withTempCopy srcDir f = do++-- | Like 'withCurrentDirectory', but will copy the directory over to the system+-- temporary directory first to avoid haskell-language-server's source tree from+-- interfering with the cradle.+--+-- You may specify directories to ignore, but should be careful to maintain reproducibility.+withCurrentDirectoryInTmp' :: [FilePath] -> FilePath -> IO a -> IO a+withCurrentDirectoryInTmp' ignored dir f =+ withTempCopy ignored dir $ \newDir ->+ withCurrentDirectory newDir f++-- | Example call: @withTempCopy ignored src f@+--+-- Copy directory 'src' to into a temporary directory ignoring any directories+-- (and files) that are listed in 'ignored'. Pass the temporary directory+-- containing the copied sources to the continuation.+withTempCopy :: [FilePath] -> FilePath -> (FilePath -> IO a) -> IO a+withTempCopy ignored srcDir f = do withSystemTempDirectory "hls-test" $ \newDir -> do- copyDir srcDir newDir+ copyDir ignored srcDir newDir f newDir -copyDir :: FilePath -> FilePath -> IO ()-copyDir src dst = do+-- | Example call: @copyDir ignored src dst@+--+-- Copy directory 'src' to 'dst' ignoring any directories (and files)+-- that are listed in 'ignored'.+copyDir :: [FilePath] -> FilePath -> FilePath -> IO ()+copyDir ignored src dst = do cnts <- listDirectory src forM_ cnts $ \file -> do unless (file `elem` ignored) $ do@@ -290,17 +324,16 @@ dstFp = dst </> file isDir <- doesDirectoryExist srcFp if isDir- then createDirectory dstFp >> copyDir srcFp dstFp+ then createDirectory dstFp >> copyDir ignored srcFp dstFp else copyFile srcFp dstFp- where ignored = ["dist", "dist-newstyle", ".stack-work"] fromAction :: (Command |? CodeAction) -> CodeAction fromAction (InR action) = action-fromAction _ = error "Not a code action"+fromAction _ = error "Not a code action" fromCommand :: (Command |? CodeAction) -> Command fromCommand (InL command) = command-fromCommand _ = error "Not a command"+fromCommand _ = error "Not a command" onMatch :: [a] -> (a -> Bool) -> String -> IO a onMatch as predicate err = maybe (fail err) return (find predicate as)@@ -315,7 +348,7 @@ inspectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO CodeAction inspectCodeAction cars s = fromAction <$> onMatch cars predicate err where predicate (InR ca) = all (`T.isInfixOf` (ca ^. L.title)) s- predicate _ = False+ predicate _ = False err = "expected code action matching '" ++ show s ++ "' but did not find one" expectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO ()@@ -324,7 +357,7 @@ inspectCommand :: [Command |? CodeAction] -> [T.Text] -> IO Command inspectCommand cars s = fromCommand <$> onMatch cars predicate err where predicate (InL command) = all (`T.isInfixOf` (command ^. L.title)) s- predicate _ = False+ predicate _ = False err = "expected code action matching '" ++ show s ++ "' but did not find one" waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic]@@ -398,7 +431,7 @@ failIfSessionTimeout action = action `catch` errorHandler where errorHandler :: Test.SessionException -> IO a errorHandler e@(Test.Timeout _) = assertFailure $ show e- errorHandler e = throwIO 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.)