git.iko.soy/stackage
on 3199abe help sign in
stackage/Stackage/Test.hs
81 lines 3.6 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2module Stackage.Test
3 ( runTestSuites
4 ) where
6import Control.Exception (Exception, handle, throwIO)
7import Control.Monad (foldM, unless, when)
8import qualified Data.Map as Map
9import qualified Data.Set as Set
10import Data.Typeable (Typeable)
11import Stackage.Config
12import Stackage.Types
13import Stackage.Util
14import System.Directory (canonicalizePath, createDirectory,
15 removeFile)
16import System.Environment (getEnvironment)
17import System.Exit (ExitCode (ExitSuccess))
18import System.FilePath ((<.>), (</>))
19import System.IO (IOMode (WriteMode, AppendMode),
20 withBinaryFile)
21import System.Process (runProcess, waitForProcess)
23runTestSuites :: BuildSettings -> InstallInfo -> IO ()
24runTestSuites settings ii = do
25 let testdir = "runtests"
26 rm_r testdir
27 createDirectory testdir
28 allPass <- foldM (runTestSuite settings testdir hasTestSuites) True $ Map.toList $ iiPackages ii
29 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
30 where
31 PackageDB pdb = iiPackageDB ii
33 hasTestSuites name = maybe defaultHasTestSuites piHasTests $ Map.lookup name pdb
35data TestException = TestException
36 deriving (Show, Typeable)
37instance Exception TestException
39runTestSuite :: BuildSettings
40 -> FilePath
41 -> (PackageName -> Bool) -- ^ do we have any test suites?
42 -> Bool
43 -> (PackageName, (Version, Maintainer))
44 -> IO Bool
45runTestSuite settings testdir hasTestSuites prevPassed (packageName, (version, Maintainer maintainer)) = do
46 -- Set up a new environment that includes the sandboxed bin folder in PATH.
47 env' <- getModifiedEnv settings
48 let menv addGPP
49 = Just $ (if addGPP then (("GHC_PACKAGE_PATH", packageDir settings ++ ":"):) else id)
50 $ ("HASKELL_PACKAGE_SANDBOX", packageDir settings)
51 : env'
53 let runGen addGPP cmd args wdir handle = do
54 ph <- runProcess cmd args (Just wdir) (menv addGPP) Nothing (Just handle) (Just handle)
55 ec <- waitForProcess ph
56 unless (ec == ExitSuccess) $ throwIO TestException
58 let run = runGen False
59 runGhcPackagePath = runGen True
61 passed <- handle (\TestException -> return False) $ do
62 getHandle WriteMode $ run "cabal" ["unpack", package] testdir
63 getHandle AppendMode $ run "cabal" (addCabalArgs settings ["configure", "--enable-tests"]) dir
64 when (hasTestSuites packageName) $ do
65 getHandle AppendMode $ run "cabal" ["build"] dir
66 getHandle AppendMode $ runGhcPackagePath "cabal" ["test"] dir
67 getHandle AppendMode $ run "cabal" ["haddock"] dir
68 return True
69 let expectedFailure = packageName `Set.member` expectedFailures settings
70 if passed
71 then do
72 removeFile logfile
73 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
74 else unless expectedFailure $ putStrLn $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
75 rm_r dir
76 return $! prevPassed && (passed || expectedFailure)
77 where
78 logfile = testdir </> package <.> "log"
79 dir = testdir </> package
80 getHandle mode = withBinaryFile logfile mode
81 package = packageVersionString (packageName, version)