{-# 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.Integration.SelfDebug (selfDebugTests) 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 let individualTimeout = 5*60*1_000_000 defaultMain $ localOption (mkTimeout individualTimeout) $ 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 , selfDebugTests ] -- | 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 = do cwd <- getCurrentDirectory -- a bit dangerous! used in the self-debug-cli test withTmpDirFromRepo keepTmpDirs cwd (testAction path) | 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: " ) , ( "\\\\\\\\", "/" ) -- Use forward slash , ( "\\\\", "/" ) -- Use forward slash , ( posixTempDirRegex {- the folder in which the test is run, inside the canonical temp dir-} , "" ) , ( "\\.hdb-cache/[^/]+/" , ".hdb-cache//" ) , ( escapeRegex cwd , "" ) ] 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