{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}
module Test.Tasty.CmdLine
( optionParser
, suiteOptions
, suiteOptionParser
, defaultMainWithIngredients
) where
import Options.Applicative
import Data.Monoid ((<>))
import Data.Proxy
import Data.Foldable (foldMap)
import Prelude
import System.Exit
import System.IO
#define INSTALL_HANDLERS defined UNIX && MIN_VERSION_base(4,6,0)
#if INSTALL_HANDLERS
import Control.Concurrent (mkWeakThreadId, myThreadId)
import Control.Exception (Exception(..), throwTo)
import Control.Monad (forM_)
import Data.Typeable (Typeable)
import System.Posix.Signals
import System.Mem.Weak (deRefWeak)
#endif
#if !MIN_VERSION_base(4,9,0)
import Data.Monoid
#endif
import Test.Tasty.Core
import Test.Tasty.Ingredients
import Test.Tasty.Options
import Test.Tasty.Options.Env
import Test.Tasty.Runners.Reducers
optionParser :: [OptionDescription] -> Parser OptionSet
optionParser :: [OptionDescription] -> Parser OptionSet
optionParser = Ap Parser OptionSet -> Parser OptionSet
forall (f :: * -> *) a. Ap f a -> f a
getApp (Ap Parser OptionSet -> Parser OptionSet)
-> ([OptionDescription] -> Ap Parser OptionSet)
-> [OptionDescription]
-> Parser OptionSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OptionDescription -> Ap Parser OptionSet)
-> [OptionDescription] -> Ap Parser OptionSet
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap OptionDescription -> Ap Parser OptionSet
toSet where
toSet :: OptionDescription -> Ap Parser OptionSet
toSet :: OptionDescription -> Ap Parser OptionSet
toSet (Option (Proxy v
Proxy :: Proxy v)) = Parser OptionSet -> Ap Parser OptionSet
forall (f :: * -> *) a. f a -> Ap f a
Ap (Parser OptionSet -> Ap Parser OptionSet)
-> Parser OptionSet -> Ap Parser OptionSet
forall a b. (a -> b) -> a -> b
$
(v -> OptionSet
forall v. IsOption v => v -> OptionSet
singleOption (v -> OptionSet) -> Parser v -> Parser OptionSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser v
forall v. IsOption v => Parser v
optionCLParser :: Parser v)) Parser OptionSet -> Parser OptionSet -> Parser OptionSet
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> OptionSet -> Parser OptionSet
forall (f :: * -> *) a. Applicative f => a -> f a
pure OptionSet
forall a. Monoid a => a
mempty
suiteOptionParser :: [Ingredient] -> TestTree -> Parser OptionSet
suiteOptionParser :: [Ingredient] -> TestTree -> Parser OptionSet
suiteOptionParser ins :: [Ingredient]
ins tree :: TestTree
tree = [OptionDescription] -> Parser OptionSet
optionParser ([OptionDescription] -> Parser OptionSet)
-> [OptionDescription] -> Parser OptionSet
forall a b. (a -> b) -> a -> b
$ [Ingredient] -> TestTree -> [OptionDescription]
suiteOptions [Ingredient]
ins TestTree
tree
defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients ins :: [Ingredient]
ins testTree :: TestTree
testTree = do
IO ()
installSignalHandlers
OptionSet
cmdlineOpts <- ParserInfo OptionSet -> IO OptionSet
forall a. ParserInfo a -> IO a
execParser (ParserInfo OptionSet -> IO OptionSet)
-> ParserInfo OptionSet -> IO OptionSet
forall a b. (a -> b) -> a -> b
$
Parser OptionSet -> InfoMod OptionSet -> ParserInfo OptionSet
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (OptionSet -> OptionSet)
forall a. Parser (a -> a)
helper Parser (OptionSet -> OptionSet)
-> Parser OptionSet -> Parser OptionSet
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Ingredient] -> TestTree -> Parser OptionSet
suiteOptionParser [Ingredient]
ins TestTree
testTree)
( InfoMod OptionSet
forall a. InfoMod a
fullDesc InfoMod OptionSet -> InfoMod OptionSet -> InfoMod OptionSet
forall a. Semigroup a => a -> a -> a
<>
String -> InfoMod OptionSet
forall a. String -> InfoMod a
header "Mmm... tasty test suite"
)
OptionSet
envOpts <- [Ingredient] -> TestTree -> IO OptionSet
suiteEnvOptions [Ingredient]
ins TestTree
testTree
let opts :: OptionSet
opts = OptionSet
envOpts OptionSet -> OptionSet -> OptionSet
forall a. Semigroup a => a -> a -> a
<> OptionSet
cmdlineOpts
case [Ingredient] -> OptionSet -> TestTree -> Maybe (IO Bool)
tryIngredients [Ingredient]
ins OptionSet
opts TestTree
testTree of
Nothing -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr
"No ingredients agreed to run. Something is wrong either with your ingredient set or the options."
IO ()
forall a. IO a
exitFailure
Just act :: IO Bool
act -> do
Bool
ok <- IO Bool
act
if Bool
ok then IO ()
forall a. IO a
exitSuccess else IO ()
forall a. IO a
exitFailure
installSignalHandlers :: IO ()
installSignalHandlers :: IO ()
installSignalHandlers = do
#if INSTALL_HANDLERS
ThreadId
main_thread_id <- IO ThreadId
myThreadId
Weak ThreadId
weak_tid <- ThreadId -> IO (Weak ThreadId)
mkWeakThreadId ThreadId
main_thread_id
[CInt] -> (CInt -> IO Handler) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ CInt
sigABRT, CInt
sigBUS, CInt
sigFPE, CInt
sigHUP, CInt
sigILL, CInt
sigQUIT, CInt
sigSEGV,
CInt
sigSYS, CInt
sigTERM, CInt
sigUSR1, CInt
sigUSR2, CInt
sigXCPU, CInt
sigXFSZ ] ((CInt -> IO Handler) -> IO ()) -> (CInt -> IO Handler) -> IO ()
forall a b. (a -> b) -> a -> b
$ \sig :: CInt
sig ->
CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig (IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ Weak ThreadId -> CInt -> IO ()
send_exception Weak ThreadId
weak_tid CInt
sig) Maybe SignalSet
forall a. Maybe a
Nothing
where
send_exception :: Weak ThreadId -> CInt -> IO ()
send_exception weak_tid :: Weak ThreadId
weak_tid sig :: CInt
sig = do
Maybe ThreadId
m <- Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
weak_tid
case Maybe ThreadId
m of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just tid :: ThreadId
tid -> ThreadId -> SomeException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid (SignalException -> SomeException
forall e. Exception e => e -> SomeException
toException (SignalException -> SomeException)
-> SignalException -> SomeException
forall a b. (a -> b) -> a -> b
$ CInt -> SignalException
SignalException CInt
sig)
newtype SignalException = SignalException Signal
deriving (Int -> SignalException -> ShowS
[SignalException] -> ShowS
SignalException -> String
(Int -> SignalException -> ShowS)
-> (SignalException -> String)
-> ([SignalException] -> ShowS)
-> Show SignalException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SignalException] -> ShowS
$cshowList :: [SignalException] -> ShowS
show :: SignalException -> String
$cshow :: SignalException -> String
showsPrec :: Int -> SignalException -> ShowS
$cshowsPrec :: Int -> SignalException -> ShowS
Show, Typeable)
instance Exception SignalException
#else
return ()
#endif