module Test.TBC
(
module Test.TBC.Convention
, module Test.TBC.Core
, module Test.TBC.Drivers
, tbc
, tbcWithHooks
, tbcCabal
, defaultMain
) where
import Prelude hiding ( catch )
import Control.Exception ( catch, SomeException )
import System.Exit ( ExitCode(ExitFailure), exitFailure, exitWith )
import System.FilePath ( (</>), replaceExtension )
import System.Posix.Signals ( installHandler, sigINT, Handler(..) )
import Distribution.Package ( packageId )
import Distribution.PackageDescription
( PackageDescription, allBuildInfo
, BuildInfo(cSources, extraLibs, extraLibDirs) )
import qualified Distribution.Simple as DS
import Distribution.Simple.BuildPaths ( objExtension )
import Distribution.Simple.GHC ( ghcOptions )
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo, buildDir, withLibLBI, withPrograms )
import Distribution.Simple.Program ( ghcProgram, lookupProgram, programPath )
import Distribution.Text ( display )
import Test.TBC.Convention as Conv
import Test.TBC.Drivers as Drivers
import Test.TBC.Renderers as Renderers
import Test.TBC.Core as Core
import Test.TBC.Convention
import Test.TBC.Drivers
import Test.TBC.Core
tbcWithHooks :: Conventions s -> RenderFns s -> Driver -> [FilePath] -> IO ExitCode
tbcWithHooks convs renderer driver testRoots =
( rInitialState renderer
>>= traverseDirectories convs driver renderer testRoots
>>= rFinal renderer
) `catch` handler
where
handler :: SomeException -> IO ExitCode
handler e = putStrLn ("TBC: " ++ show e) >> return (ExitFailure 1)
tbc :: Driver -> [FilePath] -> IO ()
tbc driver testRoots =
tbcWithHooks Conv.std (Renderers.quiet Core.normal) driver testRoots
>> return ()
defaultMain :: IO ()
defaultMain = DS.defaultMainWithHooks hooks
where hooks = DS.simpleUserHooks { DS.runTests = tbcCabal normal }
tbcCabal :: Verbosity
-> DS.Args
-> Bool -> PackageDescription -> LocalBuildInfo -> IO ()
tbcCabal verbosity args _wtf pkg_descr localbuildinfo =
cabalDriver verbosity args pkg_descr localbuildinfo >> return ()
cabalDriver :: Verbosity -> DS.Args -> PackageDescription -> LocalBuildInfo -> IO ()
cabalDriver verbosity args pkg_descr localbuildinfo =
withLibLBI pkg_descr localbuildinfo $ \_lib clbi ->
do let
testRoots
| null args = ["Tests"]
| otherwise = args
cmd = fmap programPath (lookupProgram ghcProgram (withPrograms localbuildinfo))
pkgid = packageId pkg_descr
buildInfo = head (allBuildInfo pkg_descr)
cObjs = [ buildDir localbuildinfo </> c `replaceExtension` objExtension
| c <- cSources buildInfo ]
flags =
["-v1", "--interactive", "-package-name", display pkgid ]
++ [ "-l" ++ extraLib | extraLib <- extraLibs buildInfo ]
++ [ "-L" ++ extraLibDir | extraLibDir <- extraLibDirs buildInfo ]
++ cObjs
++ ghcOptions localbuildinfo
buildInfo
clbi
(buildDir localbuildinfo)
case cmd of
Nothing -> putStrLn "GHC not found."
Just hc_cmd ->
do driver <- ghci verbosity hc_cmd flags
_ <- installHandler sigINT (Catch $ do
hci_kill driver
exitFailure
) Nothing
exitCode <- tbcWithHooks Conv.std (Renderers.quiet Core.normal) driver testRoots
_ <- hci_close driver
exitWith exitCode