git.iko.soy/stackage
on master help sign in
Cleaner test running
fd62aeeMichael Snoyman
Stackage/Test.hs+19−24
compare with master
unifiedsplit
@@ -1,4 +1,5 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
2module Stackage.Test
3module Stackage.Test
3 ( runTestSuites
4 ( runTestSuites
4 ) where
5 ) where
@@ -16,6 +17,8 @@ import System.FilePath ((<.>), (</>))
16import System.IO (IOMode (WriteMode, AppendMode),
17import System.IO (IOMode (WriteMode, AppendMode),
17 withBinaryFile)
18 withBinaryFile)
18import System.Process (runProcess, waitForProcess)
19import System.Process (runProcess, waitForProcess)
20+import Control.Exception (handle, Exception, throwIO)
21+import Data.Typeable (Typeable)
19
22
20runTestSuites :: InstallInfo -> IO ()
23runTestSuites :: InstallInfo -> IO ()
21runTestSuites ii = do
24runTestSuites ii = do
@@ -41,6 +44,10 @@ fixEnv :: FilePath -> (String, String) -> (String, String)
41fixEnv bin (p@"PATH", x) = (p, bin ++ pathSep : x)
44fixEnv bin (p@"PATH", x) = (p, bin ++ pathSep : x)
42fixEnv _ x = x
45fixEnv _ x = x
43
46
47+data TestException = TestException
48+ deriving (Show, Typeable)
49+instance Exception TestException
50+
44runTestSuite :: FilePath -> Bool -> (PackageName, (Version, Maintainer)) -> IO Bool
51runTestSuite :: FilePath -> Bool -> (PackageName, (Version, Maintainer)) -> IO Bool
45runTestSuite testdir prevPassed (packageName, (version, Maintainer maintainer)) = do
52runTestSuite testdir prevPassed (packageName, (version, Maintainer maintainer)) = do
46 -- Set up a new environment that includes the cabal-dev/bin folder in PATH.
53 -- Set up a new environment that includes the cabal-dev/bin folder in PATH.
@@ -48,30 +55,18 @@ runTestSuite testdir prevPassed (packageName, (version, Maintainer maintainer))
48 bin <- canonicalizePath "cabal-dev/bin"
55 bin <- canonicalizePath "cabal-dev/bin"
49 let menv = Just $ map (fixEnv bin) env'
56 let menv = Just $ map (fixEnv bin) env'
50
57
51− passed <- do
58+ let run cmd args wdir handle = do
59+ ph <- runProcess cmd args (Just wdir) menv Nothing (Just handle) (Just handle)
60+ ec <- waitForProcess ph
61+ unless (ec == ExitSuccess) $ throwIO TestException
62+
63+ passed <- handle (\TestException -> return False) $ do
52− ph1 <- getHandle WriteMode $ \handle -> runProcess "cabal" ["unpack", package] (Just testdir) menv Nothing (Just handle) (Just handle)
64+ getHandle WriteMode $ run "cabal" ["unpack", package] testdir
53− ec1 <- waitForProcess ph1
54− if (ec1 /= ExitSuccess)
55− then return False
56− else do
57− ph2 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["-s", "../../cabal-dev", "configure", "--enable-tests"] (Just dir) menv Nothing (Just handle) (Just handle)
65+ getHandle AppendMode $ run "cabal-dev" ["-s", "../../cabal-dev", "configure", "--enable-tests"] dir
58− ec2 <- waitForProcess ph2
59− if (ec2 /= ExitSuccess)
60− then return False
61− else do
62− ph3 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["build"] (Just dir) menv Nothing (Just handle) (Just handle)
66+ getHandle AppendMode $ run "cabal-dev" ["build"] dir
63− ec3 <- waitForProcess ph3
64− if (ec3 /= ExitSuccess)
65− then return False
66− else do
67− ph4 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["test"] (Just dir) menv Nothing (Just handle) (Just handle)
67+ getHandle AppendMode $ run "cabal-dev" ["test"] dir
68− ec4 <- waitForProcess ph4
69− if (ec4 /= ExitSuccess)
70− then return False
71− else do
72− ph5 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["haddock"] (Just dir) menv Nothing (Just handle) (Just handle)
68+ getHandle AppendMode $ run "cabal-dev" ["haddock"] dir
73− ec5 <- waitForProcess ph5
74− return $ ec5 == ExitSuccess
69+ return True
75 let expectedFailure = packageName `Set.member` expectedFailures
70 let expectedFailure = packageName `Set.member` expectedFailures
76 if passed
71 if passed
77 then do
72 then do