{-# LANGUAGE CPP, OverloadedStrings, NamedFieldPuns, MultiParamTypeClasses #-}
module Test.Hls.Util
(
codeActionSupportCaps
, dummyLspFuncs
, expectCodeAction
, expectDiagnostic
, expectNoMoreDiagnostics
, failIfSessionTimeout
, flushStackEnvironment
, fromAction
, fromCommand
, getHspecFormattedConfig
, ghcVersion, GhcVersion(..)
, hlsCommand
, hlsCommandExamplePlugin
, hlsCommandVomit
, ignoreForGhcVersions
, inspectCodeAction
, inspectCommand
, inspectDiagnostic
, knownBrokenForGhcVersions
, logConfig
, logFilePath
, noLogConfig
, setupBuildToolFiles
, waitForDiagnosticsFrom
, waitForDiagnosticsFromSource
, waitForDiagnosticsFromSourceWithTimeout
, withFileLogging
, withCurrentDirectoryInTmp
)
where
import Control.Exception (throwIO, catch)
import Control.Monad
import Control.Monad.IO.Class
import Control.Applicative.Combinators (skipManyTill, (<|>))
import Control.Lens ((^.))
import Data.Default
import Data.List (intercalate)
import Data.List.Extra (find)
import Data.Maybe
import qualified Data.Text as T
import Language.Haskell.LSP.Core
import Language.Haskell.LSP.Messages (FromServerMessage(NotLogMessage))
import Language.Haskell.LSP.Types
import qualified Language.Haskell.LSP.Test as Test
import qualified Language.Haskell.LSP.Types.Lens as L
import qualified Language.Haskell.LSP.Types.Capabilities as C
import System.Directory
import System.Environment
import System.Time.Extra (Seconds, sleep)
import System.FilePath
import qualified System.Log.Logger as L
import System.IO.Temp
import System.IO.Unsafe
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 (assertFailure)
import Text.Blaze.Renderer.String (renderMarkup)
import Text.Blaze.Internal hiding (null)
noLogConfig :: Test.SessionConfig
noLogConfig = Test.defaultConfig { Test.logMessages = False }
logConfig :: Test.SessionConfig
logConfig = Test.defaultConfig { Test.logMessages = True }
codeActionSupportCaps :: C.ClientCapabilities
codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps }
where
textDocumentCaps = def { C._codeAction = Just codeActionCaps }
codeActionCaps = C.CodeActionClientCapabilities (Just True) (Just literalSupport)
literalSupport = C.CodeActionLiteralSupport def
withFileLogging :: FilePath -> IO a -> IO a
withFileLogging logFile f = do
let logDir = "./test-logs"
logPath = logDir </> logFile
dirExists <- doesDirectoryExist logDir
unless dirExists $ createDirectory logDir
exists <- doesFileExist logPath
when exists $ removeFile logPath
setupLogger (Just logPath) ["hie"] L.DEBUG
f
-- ---------------------------------------------------------------------
setupBuildToolFiles :: IO ()
setupBuildToolFiles = do
forM_ files setupDirectFilesIn
setupDirectFilesIn :: FilePath -> IO ()
setupDirectFilesIn f =
writeFile (f ++ "hie.yaml") hieYamlCradleDirectContents
-- ---------------------------------------------------------------------
files :: [FilePath]
files =
[ "./test/testdata/"
-- , "./test/testdata/addPackageTest/cabal-exe/"
-- , "./test/testdata/addPackageTest/hpack-exe/"
-- , "./test/testdata/addPackageTest/cabal-lib/"
-- , "./test/testdata/addPackageTest/hpack-lib/"
-- , "./test/testdata/addPragmas/"
-- , "./test/testdata/badProjects/cabal/"
-- , "./test/testdata/completion/"
-- , "./test/testdata/definition/"
-- , "./test/testdata/gototest/"
-- , "./test/testdata/redundantImportTest/"
-- , "./test/testdata/wErrorTest/"
]
data GhcVersion
= GHC810
| GHC88
| GHC86
| GHC84
deriving (Eq,Show)
ghcVersion :: GhcVersion
#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)))
ghcVersion = GHC810
#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)))
ghcVersion = GHC88
#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)))
ghcVersion = GHC86
#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)))
ghcVersion = GHC84
#endif
knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
knownBrokenForGhcVersions vers reason
| ghcVersion `elem` vers = expectFailBecause reason
| otherwise = id
ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
ignoreForGhcVersions vers reason
| ghcVersion `elem` vers = ignoreTestBecause reason
| otherwise = id
logFilePath :: String
logFilePath = "hls-" ++ show ghcVersion ++ ".log"
-- | The command to execute the version of hls for the current compiler.
--
-- Both @stack test@ and @cabal new-test@ setup the environment so @hls@ is
-- on PATH. Cabal seems to respond to @build-tool-depends@ specifically while
-- stack just puts all project executables on PATH.
hlsCommand :: String
hlsCommand = unsafePerformIO $ do
testExe <- fromMaybe "haskell-language-server" <$> lookupEnv "HLS_TEST_EXE"
pure $ testExe ++ " --lsp -d -j2 -l test-logs/" ++ logFilePath
hlsCommandVomit :: String
hlsCommandVomit = hlsCommand ++ " --vomit"
hlsCommandExamplePlugin :: String
hlsCommandExamplePlugin = hlsCommand ++ " --example"
-- ---------------------------------------------------------------------
hieYamlCradleDirectContents :: String
hieYamlCradleDirectContents = unlines
[ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN"
, "cradle:"
, " direct:"
, " arguments:"
, " - -i."
]
-- ---------------------------------------------------------------------
getHspecFormattedConfig :: String -> IO Config
getHspecFormattedConfig name = do
-- https://circleci.com/docs/2.0/env-vars/#built-in-environment-variables
isCI <- isJust <$> lookupEnv "CI"
-- Only use the xml formatter on CI since it hides console output
if isCI
then do
let subdir = "test-results" </> name
createDirectoryIfMissing True subdir
return $ defaultConfig { configFormatter = Just xmlFormatter
, configOutputFile = Right $ subdir </> "results.xml"
}
else return defaultConfig
-- | A Hspec formatter for CircleCI.
-- Originally from https://github.com/LeastAuthority/hspec-jenkins
xmlFormatter :: Formatter
xmlFormatter = silent {
headerFormatter = do
writeLine "<?xml version='1.0' encoding='UTF-8'?>"
writeLine "<testsuite>"
, exampleSucceeded
, exampleFailed
, examplePending
, footerFormatter = writeLine "</testsuite>"
}
where
#if MIN_VERSION_hspec(2,5,0)
exampleSucceeded path _ =
#else
exampleSucceeded path =
#endif
writeLine $ renderMarkup $ testcase path ""
#if MIN_VERSION_hspec(2,5,0)
exampleFailed path _ err =
#else
exampleFailed path (Left err) =
writeLine $ renderMarkup $ testcase path $
failure ! message (show err) $ ""
exampleFailed path (Right err) =
#endif
writeLine $ renderMarkup $ testcase path $
failure ! message (reasonAsString err) $ ""
#if MIN_VERSION_hspec(2,5,0)
examplePending path _ reason =
#else
examplePending path reason =
#endif
writeLine $ renderMarkup $ testcase path $
case reason of
Just desc -> skipped ! message desc $ ""
Nothing -> skipped ""
failure, skipped :: Markup -> Markup
failure = customParent "failure"
skipped = customParent "skipped"
name, className, message :: String -> Attribute
name = customAttribute "name" . stringValue
className = customAttribute "classname" . stringValue
message = customAttribute "message" . stringValue
testcase :: Path -> Markup -> Markup
testcase (xs,x) = customParent "testcase" ! name x ! className (intercalate "." xs)
reasonAsString :: FailureReason -> String
reasonAsString NoReason = "no reason given"
reasonAsString (Reason x) = x
reasonAsString (ExpectedButGot Nothing expected got) = "Expected " ++ expected ++ " but got " ++ got
reasonAsString (ExpectedButGot (Just src) expected got) = src ++ " expected " ++ expected ++ " but got " ++ got
#if MIN_VERSION_hspec(2,5,0)
reasonAsString (Error Nothing err ) = show err
reasonAsString (Error (Just s) err) = s ++ show err
#endif
-- ---------------------------------------------------------------------
flushStackEnvironment :: IO ()
flushStackEnvironment = do
-- We need to clear these environment variables to prevent
-- collisions with stack usages
-- See https://github.com/commercialhaskell/stack/issues/4875
unsetEnv "GHC_PACKAGE_PATH"
unsetEnv "GHC_ENVIRONMENT"
unsetEnv "HASKELL_PACKAGE_SANDBOX"
unsetEnv "HASKELL_PACKAGE_SANDBOXES"
-- ---------------------------------------------------------------------
dummyLspFuncs :: Default a => LspFuncs a
dummyLspFuncs = LspFuncs { clientCapabilities = def
, config = return (Just def)
, sendFunc = const (return ())
, getVirtualFileFunc = const (return Nothing)
, persistVirtualFileFunc = \uri -> return (uriToFilePath (fromNormalizedUri uri))
, reverseFileMapFunc = return id
, publishDiagnosticsFunc = mempty
, flushDiagnosticsBySourceFunc = mempty
, getNextReqId = pure (IdInt 0)
, rootPath = Nothing
, getWorkspaceFolders = return Nothing
, withProgress = \_ _ f -> f (const (return ()))
, withIndefiniteProgress = \_ _ f -> f
}
-- | 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
withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a
withCurrentDirectoryInTmp dir f =
withTempCopy dir $ \newDir ->
withCurrentDirectory newDir f
withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a
withTempCopy srcDir f = do
withSystemTempDirectory "hls-test" $ \newDir -> do
copyDir srcDir newDir
f newDir
copyDir :: FilePath -> FilePath -> IO ()
copyDir src dst = do
cnts <- listDirectory src
forM_ cnts $ \file -> do
unless (file `elem` ignored) $ do
let srcFp = src </> file
dstFp = dst </> file
isDir <- doesDirectoryExist srcFp
if isDir
then createDirectory dstFp >> copyDir srcFp dstFp
else copyFile srcFp dstFp
where ignored = ["dist", "dist-newstyle", ".stack-work"]
fromAction :: CAResult -> CodeAction
fromAction (CACodeAction action) = action
fromAction _ = error "Not a code action"
fromCommand :: CAResult -> Command
fromCommand (CACommand command) = command
fromCommand _ = error "Not a command"
onMatch :: [a] -> (a -> Bool) -> String -> IO a
onMatch as predicate err = maybe (fail err) return (find predicate as)
inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic
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"
expectDiagnostic :: [Diagnostic] -> [T.Text] -> IO ()
expectDiagnostic diags s = void $ inspectDiagnostic diags s
inspectCodeAction :: [CAResult] -> [T.Text] -> IO CodeAction
inspectCodeAction cars s = fromAction <$> onMatch cars predicate err
where predicate (CACodeAction ca) = all (`T.isInfixOf` (ca ^. L.title)) s
predicate _ = False
err = "expected code action matching '" ++ show s ++ "' but did not find one"
expectCodeAction :: [CAResult] -> [T.Text] -> IO ()
expectCodeAction cars s = void $ inspectCodeAction cars s
inspectCommand :: [CAResult] -> [T.Text] -> IO Command
inspectCommand cars s = fromCommand <$> onMatch cars predicate err
where predicate (CACommand command) = all (`T.isInfixOf` (command ^. L.title)) s
predicate _ = False
err = "expected code action matching '" ++ show s ++ "' but did not find one"
waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic]
waitForDiagnosticsFrom doc = do
diagsNot <- skipManyTill Test.anyMessage Test.message :: Test.Session PublishDiagnosticsNotification
let (List diags) = diagsNot ^. L.params . L.diagnostics
if doc ^. L.uri /= diagsNot ^. L.params . L.uri
then waitForDiagnosticsFrom doc
else return diags
waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Test.Session [Diagnostic]
waitForDiagnosticsFromSource doc src = do
diagsNot <- skipManyTill Test.anyMessage Test.message :: Test.Session PublishDiagnosticsNotification
let (List diags) = diagsNot ^. L.params . L.diagnostics
let res = filter matches diags
if doc ^. L.uri /= diagsNot ^. L.params . L.uri || null res
then waitForDiagnosticsFromSource doc src
else return res
where
matches :: Diagnostic -> Bool
matches d = d ^. L.source == Just (T.pack src)
-- | wait for @timeout@ seconds and report an assertion failure
-- if any diagnostic messages arrive in that period
expectNoMoreDiagnostics :: Seconds -> TextDocumentIdentifier -> String -> Test.Session ()
expectNoMoreDiagnostics timeout doc src = do
diags <- waitForDiagnosticsFromSourceWithTimeout timeout doc src
unless (null diags) $
liftIO $ assertFailure $
"Got unexpected diagnostics for " <> show (doc ^. L.uri) <>
" got " <> show diags
-- | wait for @timeout@ seconds and return diagnostics for the given @document and @source.
-- If timeout is 0 it will wait until the session timeout
waitForDiagnosticsFromSourceWithTimeout :: Seconds -> TextDocumentIdentifier -> String -> Test.Session [Diagnostic]
waitForDiagnosticsFromSourceWithTimeout timeout document source = do
when (timeout > 0) $ 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.
void $ Test.sendRequest (CustomClientMethod "non-existent-method") ()
handleMessages
where
matches :: Diagnostic -> Bool
matches d = d ^. L.source == Just (T.pack source)
handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers
handleDiagnostic = do
diagsNot <- Test.message :: Test.Session PublishDiagnosticsNotification
let fileUri = diagsNot ^. L.params . L.uri
(List diags) = diagsNot ^. L.params . L.diagnostics
res = filter matches diags
if fileUri == document ^. L.uri && not (null res)
then return diags else handleMessages
handleCustomMethodResponse =
-- the CustomClientMethod triggers a RspCustomServer
-- handle that and then exit
void (Test.satisfyMaybe responseForNonExistentMethod) >> return []
responseForNonExistentMethod notif
| NotLogMessage logMsg <- notif,
"non-existent-method" `T.isInfixOf` (logMsg ^. L.params . L.message) = Just notif
| otherwise = Nothing
ignoreOthers = void Test.anyMessage >> handleMessages
failIfSessionTimeout :: IO a -> IO a
failIfSessionTimeout action = action `catch` errorHandler
where errorHandler :: Test.SessionException -> IO a
errorHandler e@(Test.Timeout _) = assertFailure $ show e
errorHandler e = throwIO e