-- | Ingredient for listing test names
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
module Test.Tasty.Ingredients.ListTests
  ( ListTests(..)
  , testsNames
  , listingTests
  ) where

import Data.Proxy
import Data.Typeable
import Options.Applicative

import Test.Tasty.Core
import Test.Tasty.Options
import Test.Tasty.Ingredients

-- | This option, when set to 'True', specifies that we should run in the
-- «list tests» mode
newtype ListTests = ListTests Bool
  deriving (ListTests -> ListTests -> Bool
(ListTests -> ListTests -> Bool)
-> (ListTests -> ListTests -> Bool) -> Eq ListTests
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ListTests -> ListTests -> Bool
$c/= :: ListTests -> ListTests -> Bool
== :: ListTests -> ListTests -> Bool
$c== :: ListTests -> ListTests -> Bool
Eq, Eq ListTests
Eq ListTests
-> (ListTests -> ListTests -> Ordering)
-> (ListTests -> ListTests -> Bool)
-> (ListTests -> ListTests -> Bool)
-> (ListTests -> ListTests -> Bool)
-> (ListTests -> ListTests -> Bool)
-> (ListTests -> ListTests -> ListTests)
-> (ListTests -> ListTests -> ListTests)
-> Ord ListTests
ListTests -> ListTests -> Bool
ListTests -> ListTests -> Ordering
ListTests -> ListTests -> ListTests
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ListTests -> ListTests -> ListTests
$cmin :: ListTests -> ListTests -> ListTests
max :: ListTests -> ListTests -> ListTests
$cmax :: ListTests -> ListTests -> ListTests
>= :: ListTests -> ListTests -> Bool
$c>= :: ListTests -> ListTests -> Bool
> :: ListTests -> ListTests -> Bool
$c> :: ListTests -> ListTests -> Bool
<= :: ListTests -> ListTests -> Bool
$c<= :: ListTests -> ListTests -> Bool
< :: ListTests -> ListTests -> Bool
$c< :: ListTests -> ListTests -> Bool
compare :: ListTests -> ListTests -> Ordering
$ccompare :: ListTests -> ListTests -> Ordering
$cp1Ord :: Eq ListTests
Ord, Typeable)
instance IsOption ListTests where
  defaultValue :: ListTests
defaultValue = Bool -> ListTests
ListTests Bool
False
  parseValue :: String -> Maybe ListTests
parseValue = (Bool -> ListTests) -> Maybe Bool -> Maybe ListTests
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> ListTests
ListTests (Maybe Bool -> Maybe ListTests)
-> (String -> Maybe Bool) -> String -> Maybe ListTests
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
safeReadBool
  optionName :: Tagged ListTests String
optionName = String -> Tagged ListTests String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"list-tests"
  optionHelp :: Tagged ListTests String
optionHelp = String -> Tagged ListTests String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Do not run the tests; just print their names"
  optionCLParser :: Parser ListTests
optionCLParser = Mod FlagFields ListTests -> ListTests -> Parser ListTests
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser (Char -> Mod FlagFields ListTests
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'l') (Bool -> ListTests
ListTests Bool
True)

-- | Obtain the list of all tests in the suite
testsNames :: OptionSet -> TestTree -> [TestName]
testsNames :: OptionSet -> TestTree -> [String]
testsNames {- opts -} {- tree -} =
  TreeFold [String] -> OptionSet -> TestTree -> [String]
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
    TreeFold [String]
forall b. Monoid b => TreeFold b
trivialFold
      { foldSingle :: forall t. IsTest t => OptionSet -> String -> t -> [String]
foldSingle = \OptionSet
_opts String
name t
_test -> [String
name]
      , foldGroup :: OptionSet -> String -> [String] -> [String]
foldGroup = \OptionSet
_opts String
groupName [String]
names -> (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
groupName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
names
      }

-- | The ingredient that provides the test listing functionality
listingTests :: Ingredient
listingTests :: Ingredient
listingTests = [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager [Proxy ListTests -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy ListTests
forall k (t :: k). Proxy t
Proxy :: Proxy ListTests)] ((OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient)
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
forall a b. (a -> b) -> a -> b
$
  \OptionSet
opts TestTree
tree ->
    case OptionSet -> ListTests
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
      ListTests Bool
False -> Maybe (IO Bool)
forall a. Maybe a
Nothing
      ListTests Bool
True -> IO Bool -> Maybe (IO Bool)
forall a. a -> Maybe a
Just (IO Bool -> Maybe (IO Bool)) -> IO Bool -> Maybe (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
        (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ OptionSet -> TestTree -> [String]
testsNames OptionSet
opts TestTree
tree
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True