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.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 @@ -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 diff --git a/src/Test/Hls.hs b/src/Test/Hls.hs --- a/src/Test/Hls.hs +++ b/src/Test/Hls.hs @@ -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 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,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.)