{-# LANGUAGE LambdaCase, OverloadedStrings, ViewPatterns, QuasiQuotes, CPP #-}
module Main (main) where
import Data.List (isSuffixOf, isInfixOf)
import qualified Data.Set as Set
import Text.RE.TDFA.Text.Lazy
import Text.Printf
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import qualified Data.Text.Lazy.IO as LT
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified System.Process as P
import System.Directory
import System.FilePath
import qualified System.FilePath.Posix as Posix
import System.IO.Temp
import System.Exit
import System.IO
import System.Environment
import Control.Exception
import Test.Tasty
import Test.Tasty.ExpectedFailure
import Test.Tasty.Golden as G
import Test.Tasty.Golden.Advanced as G
import Test.Integration.LogMessage (logMessageTests)
import Test.Integration.Persistent (persistentTests)
import Test.Integration.RunInTerminal (runInTerminalTests)
import Test.Integration.Scopes (scopesTests)
import Test.Integration.Basic (basicTests)
import Test.Integration.Exceptions (exceptionTests)
import Test.Integration.MultiMain (multiMainTests)
import Test.Integration.MultiHomeUnit (multiHomeUnitTests)
import Test.Integration.Variables (variableTests)
import Test.Integration.StepOut (stepOutTests)
import Test.Integration.Stdout (stdoutTests)
import Test.Integration.Conditional (conditionalTests)
import Test.Integration.Evaluate (evaluateTests)
import Test.Integration.StackTrace (stackTraceTests)
import Test.Utils
import qualified Data.Char as C
import qualified Data.Text as T
main :: IO ()
main = do
env <- getEnvironment
let mkTest = mkGoldenTest (maybe False read (lookup "KEEP_TEMP_DIRS" env)) env
golden_tests_paths <- findByExtension [".hdb-test"] "test/golden"
`catch` \(e::IOException) -> do
hPutStrLn stderr "-- !! ERROR !! -----------------------------------------------------------------"
hPutStrLn stderr "Failed to find golden tests by `*.hdb-test` extension."
hPutStrLn stderr "Make sure that the testsuite is being run from the project root (where the relative path `test/golden` is valid)."
hPutStrLn stderr "--------------------------------------------------------------------------------"
throwIO e
let internalOnlyTests = filter (\p -> ".internal" `isSuffixOf` takeBaseName p) golden_tests_paths
let externalOnlyTests = filter (\p -> ".external" `isSuffixOf` takeBaseName p) golden_tests_paths
let internalOnlySet = Set.fromList internalOnlyTests
let externalOnlySet = Set.fromList externalOnlyTests
let allTestsSet = Set.fromList golden_tests_paths
let defaultTestsSet = allTestsSet `Set.difference` (internalOnlySet `Set.union` externalOnlySet)
let testsForInternal = Set.toList $ internalOnlySet `Set.union` defaultTestsSet
let testsForExternal = Set.toList $ externalOnlySet `Set.union` defaultTestsSet
-- Disable IPE backtraces in tests to ensure consistent output between
-- internal and external interpreter modes. When using the internal interpreter,
-- IPE backtraces appear in debugger output but not with the external interpreter
-- (since they run as separate processes). To use a single golden test file for
-- both modes, we disable IPE backtraces by default in tests.
let baseFlags = "--disable-ipe-backtraces"
let default_goldens = map (mkTest baseFlags) testsForExternal
let intinterp_goldens = map (mkTest ("--internal-interpreter " ++ baseFlags)) testsForInternal
defaultMain $
testGroup "Tests"
[ testGroup "Golden tests" default_goldens
,
#ifdef mingw32_HOST_OS
ignoreTestBecause "Internal interpreter is not supported on Windows (#149 / ghc#22146)" $
#endif
testGroup "Golden tests (--internal-interpreter)" intinterp_goldens
, testGroup "Unit tests" unitTests
]
unitTests :: [TestTree]
unitTests =
[ runInTerminalTests
, scopesTests
, logMessageTests
, persistentTests
, basicTests
, exceptionTests
, multiMainTests
, multiHomeUnitTests
, variableTests
, stepOutTests
, stdoutTests
, conditionalTests
, evaluateTests
, stackTraceTests
]
-- | Receives as an argument the path to the @*.hdb-test@ which contains the
-- shell invocation for running
mkGoldenTest :: Bool -> [(String, String)] -> FilePath -> String -> TestTree
mkGoldenTest keepTmpDirs inheritedEnv flags path = goldenVsStringComparing testName goldenPath topAction
where
ghcVersionTag :: String
ghcVersionTag = show (__GLASGOW_HASKELL__ :: Int)
testName = takeBaseName path
goldenPath = replaceExtension path (".ghc-" ++ ghcVersionTag ++ ".hdb-stdout")
noTmpDir = ".no-tmp-dir" `isInfixOf` testName
topAction :: IO LBS.ByteString
topAction | noTmpDir = testAction path =<< getCurrentDirectory -- a bit dangerous! used in the self-debug-cli test
| otherwise = withHermeticDir keepTmpDirs (takeDirectory path) (testAction (takeFileName path))
testAction :: FilePath -> FilePath -> IO LBS.ByteString
testAction test_path test_dir = do
(_, Just hout, _, p)
<- P.createProcess (P.proc "sh" [test_path])
{ P.cwd = Just test_dir, P.std_out = P.CreatePipe
, P.env = Just $
inheritedEnv ++
[ ("HDB_CACHE_DIR", test_dir </> ".hdb-cache")
, ("HDB", "hdb " ++ flags)
]
}
P.waitForProcess p >>= \case
ExitSuccess -> LBS.hGetContents hout
ExitFailure c -> error $ "Test script in " ++ test_dir ++ " failed with exit code: " ++ show c
--------------------------------------------------------------------------------
-- Tasty Golden Advanced wrapper
--------------------------------------------------------------------------------
-- | Compare a given string against the golden file's contents using the given normalising function
-- This is inlined from 'goldenVsString' and the accompanying functions. We
-- wanted the same but with a normalising function.
goldenVsStringComparing
:: TestName -- ^ test name
-> FilePath -- ^ path to the «golden» file (the file that contains correct output)
-> IO LBS.ByteString
-- ^ action that returns a string
-> TestTree
-- ^ the test verifies that the returned string is the same as the golden file contents
goldenVsStringComparing name ref act =
maybeExpectFail $
-- Normalise the output. The test file should already be saved normalised.
goldenTest name (LT.decodeUtf8 <$> readFileStrict ref) normalisingAct cmpNormalising upd
where
upd = createDirectoriesAndWriteFile ref . LT.encodeUtf8
escapePathSeparators c =
if isPathSeparator c
then "\\" ++ [c]
else [c]
useForwardSlashes =
fmap useForwardSlash
useForwardSlash c =
if c == '\\'
then '/'
else c
escapeRegex :: String -> String
escapeRegex = concatMap escapePathSeparators
-- Normalise the action producing the output
normalisingAct = do
tmpDir <- getCanonicalTemporaryDirectory
cwd <- getCurrentDirectory
let
winTempDirWithForwardSlashes = useForwardSlashes tmpDir
let posixTempDirRegex =
escapeRegex $
Posix.joinPath $
[ winTempDirWithForwardSlashes
, "[^/\\]+"
, takeBaseName (takeDirectory ref)
]
replaceREs <- traverse (uncurry compileSearchReplace)
[ ( "Using cabal specification: .*"
, "Using cabal specification: <VERSION>" )
, ( "\\\\\\\\", "/" ) -- Use forward slash
, ( "\\\\", "/" ) -- Use forward slash
, ( posixTempDirRegex {- the folder in which the test is run, inside the canonical temp dir-}
, "<TEMPORARY-DIRECTORY>" )
, ( "\\.hdb-cache/[^/]+/"
, ".hdb-cache/<CACHE-ENTRY>/" )
, ( escapeRegex cwd
, "<PROJECT-ROOT>" )
]
let normalising (LT.decodeUtf8 -> txt) = LT.filter (/= '\r') $ foldl' (*=~/) txt replaceREs
normalising <$> act
readFileStrict :: FilePath -> IO LBS.ByteString
readFileStrict path = do
s <- LBS.readFile path
evaluate $ forceLbs s
return s
forceLbs :: LBS.ByteString -> ()
forceLbs = LBS.foldr seq ()
-- if testname contains `.fails-234` we expect a failure described by ticket #234
maybeExpectFail = case T.breakOn ".fails-" (T.pack name) of
(_, rest)
| let num = T.takeWhile C.isDigit (T.drop (T.length ".fails-") rest)
, not (T.null num) -> expectFailBecause ("#" ++ T.unpack num)
| otherwise -> id
--------------------------------------------------------------------------------
-- Normalisation
--------------------------------------------------------------------------------
-- | Compare the golden test against the actual output after normalisation
cmpNormalising :: LT.Text -> LT.Text -> IO (Maybe String)
cmpNormalising x y = do
let
msg = printf "Test output was different from '%s'. It was:\n" ref <> (LT.unpack y)
if x == y
then return Nothing
else do
-- Call diff to show the difference
withSystemTempFile "x.txt" $ \xf xH -> do
withSystemTempFile "y.txt" $ \yf yH -> do
LT.hPutStr xH x
LT.hPutStr yH y
hFlush xH
hFlush yH
hClose xH
hClose yH
(_exitCode, out, err) <- P.readProcessWithExitCode "diff"
["-u", xf, yf] ""
return $ Just $ msg ++ "\nDiff output:\n" ++ out ++ err